# HG changeset patch # User Adam Chlipala # Date 1267563648 18000 # Node ID 51e596feec37974899cc7a74259e4a0938517468 # Parent 79f487f51d9f91e813a2114258e4c4542f5ed720 Tone down Reduce and compensate with a new push-lambda-inside-case rule in MonoOpt; expand more Basis synonyms in Monoize diff -r 79f487f51d9f -r 51e596feec37 demo/metaform.ur --- 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 - {@foldURX2 [string] [string] [body] + {@mapUX2 [string] [string] [body] (fn [nm :: Name] [rest :: {Unit}] [[nm] ~ rest] name value =>

{[name]} = {[value]}

) diff -r 79f487f51d9f -r 51e596feec37 src/jscomp.sml --- 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 diff -r 79f487f51d9f -r 51e596feec37 src/mono_opt.sml --- 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), _), diff -r 79f487f51d9f -r 51e596feec37 src/monoize.sml --- 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"), _), _), _), _), _), _) => diff -r 79f487f51d9f -r 51e596feec37 src/reduce.sml --- 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) =>