changeset 1176:51e596feec37

Tone down Reduce and compensate with a new push-lambda-inside-case rule in MonoOpt; expand more Basis synonyms in Monoize
author Adam Chlipala <adamc@hcoop.net>
date Tue, 02 Mar 2010 16:00:48 -0500
parents 79f487f51d9f
children 26fed2c4f5be
files demo/metaform.ur src/jscomp.sml src/mono_opt.sml src/monoize.sml src/reduce.sml
diffstat 5 files changed, 29 insertions(+), 6 deletions(-) [+]
line wrap: on
line diff
--- a/demo/metaform.ur	Tue Mar 02 10:33:49 2010 -0500
+++ b/demo/metaform.ur	Tue Mar 02 16:00:48 2010 -0500
@@ -5,7 +5,7 @@
               end) = struct
 
     fun handler values = return <xml><body>
-      {@foldURX2 [string] [string] [body]
+      {@mapUX2 [string] [string] [body]
         (fn [nm :: Name] [rest :: {Unit}] [[nm] ~ rest] name value => <xml>
           <li> {[name]} = {[value]}</li>
         </xml>)
--- a/src/jscomp.sml	Tue Mar 02 10:33:49 2010 -0500
+++ b/src/jscomp.sml	Tue Mar 02 16:00:48 2010 -0500
@@ -445,7 +445,7 @@
                                 case p of
                                     Prim.String s =>
                                     str ("\"" ^ String.translate jsChar s ^ "\"")
-                                  | Prim.Char ch => str ("'" ^ jsChar ch ^ "'")
+                                  | Prim.Char ch => str ("\"" ^ jsChar ch ^ "\"")
                                   | _ => str (Prim.toString p)
                             end
 
@@ -1173,7 +1173,8 @@
                | EJavaScript (m, e') =>
                  (foundJavaScript := true;
                   jsExp m outer (e', st)
-                  handle CantEmbed _ => (e, st))
+                  handle CantEmbed t => ((*Print.preface ("Can't embed", MonoPrint.p_typ MonoEnv.empty t);*)
+                                         (e, st)))
 
                | ESignalReturn e =>
                  let
--- a/src/mono_opt.sml	Tue Mar 02 10:33:49 2010 -0500
+++ b/src/mono_opt.sml	Tue Mar 02 16:00:48 2010 -0500
@@ -348,6 +348,22 @@
                             result = ran}), loc)
         end
 
+      | ECase (discE, pes, {disc, result = (TFun (dom, ran), loc)}) =>
+        let
+            fun doBody (p, e) =
+                let
+                    val pb = MonoEnv.patBindsN p
+                in
+                    (EApp (MonoEnv.liftExpInExp pb e, (ERel pb, loc)), loc)
+                end
+        in
+            EAbs ("x", dom, ran,
+                  (optExp (ECase (MonoEnv.liftExpInExp 0 discE,
+                                  map (fn (p, e) => (p, doBody (p, e))) pes,
+                                  {disc = disc,
+                                   result = ran}), loc), loc))
+        end
+
       | EWrite (EQuery {exps, tables, state, query,
                         initial = (EPrim (Prim.String ""), _),
                         body = (EStrcat ((EPrim (Prim.String s), _),
--- a/src/monoize.sml	Tue Mar 02 10:33:49 2010 -0500
+++ b/src/monoize.sml	Tue Mar 02 16:00:48 2010 -0500
@@ -155,6 +155,12 @@
                   | L.CApp ((L.CFfi ("Basis", "read"), _), t) =>
                     readType (mt env dtmap t, loc)
 
+                  | L.CFfi ("Basis", "unit") => (L'.TRecord [], loc)
+                  | L.CFfi ("Basis", "page") => (L'.TFfi ("Basis", "string"), loc)
+                  | L.CFfi ("Basis", "xbody") => (L'.TFfi ("Basis", "string"), loc)
+                  | L.CFfi ("Basis", "xtr") => (L'.TFfi ("Basis", "string"), loc)
+                  | L.CFfi ("Basis", "xform") => (L'.TFfi ("Basis", "string"), loc)
+
                   | L.CFfi ("Basis", "url") => (L'.TFfi ("Basis", "string"), loc)
                   | L.CFfi ("Basis", "mimeType") => (L'.TFfi ("Basis", "string"), loc)
                   | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "xml"), _), _), _), _), _), _) =>
--- a/src/reduce.sml	Tue Mar 02 10:33:49 2010 -0500
+++ b/src/reduce.sml	Tue Mar 02 16:00:48 2010 -0500
@@ -327,12 +327,12 @@
             let
                 (*val () = Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty all),
                                                ("env", Print.PD.string (e2s env))]*)
-                val () = if dangling (edepth env) all then
+                (*val () = if dangling (edepth env) all then
                              (Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty all),
                                                     ("env", Print.PD.string (e2s env))];
                               raise Fail "!")
                          else
-                             ()
+                             ()*)
 
                 val r = case e of
                             EPrim _ => all
@@ -516,7 +516,7 @@
 
                                 val e1 = exp env e1
                                 val e2 = exp env e2
-                                val e12 = reassoc (EApp (e1, e2), loc)
+                                val e12 = (*reassoc*) (EApp (e1, e2), loc)
                             in
                                 case #1 e12 of
                                     EApp ((EAbs (_, _, _, b), _), e2) =>