From 46e60fb6904b05340446e12d4a88a090b19b85fa Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 2 Mar 2010 16:00:48 -0500 Subject: Tone down Reduce and compensate with a new push-lambda-inside-case rule in MonoOpt; expand more Basis synonyms in Monoize --- demo/metaform.ur | 2 +- src/jscomp.sml | 5 +++-- src/mono_opt.sml | 16 ++++++++++++++++ src/monoize.sml | 6 ++++++ src/reduce.sml | 6 +++--- 5 files changed, 29 insertions(+), 6 deletions(-) diff --git a/demo/metaform.ur b/demo/metaform.ur index 606b3863..0a664005 100644 --- a/demo/metaform.ur +++ b/demo/metaform.ur @@ -5,7 +5,7 @@ functor Make (M : sig 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 --git a/src/jscomp.sml b/src/jscomp.sml index b99a6858..ed913168 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -445,7 +445,7 @@ fun process file = 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 @@ fun process file = | 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 --git a/src/mono_opt.sml b/src/mono_opt.sml index 5d81d24d..fb6ff264 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -348,6 +348,22 @@ fun exp e = 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 --git a/src/monoize.sml b/src/monoize.sml index a5dc3929..5f616c05 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -155,6 +155,12 @@ fun monoType env = | 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 --git a/src/reduce.sml b/src/reduce.sml index cc8ba0fd..eadc8273 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -327,12 +327,12 @@ fun kindConAndExp (namedC, namedE) = 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 @@ fun kindConAndExp (namedC, namedE) = 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) => -- cgit v1.2.3