diff options
| author |  Adam Chlipala <adamc@hcoop.net> | 2010-03-02 16:00:48 -0500 |
|---|---|---|
| committer | Adam Chlipala <adamc@hcoop.net> | 2010-03-02 16:00:48 -0500 |
| commit | 46e60fb6904b05340446e12d4a88a090b19b85fa (patch) | |
| tree | 35ff2e860464207021d5a23b6c819398e9d19a7c | |
| parent | 74e835c7db56fb5e716add3bb8fe19534b557282 (diff) | |
Tone down Reduce and compensate with a new push-lambda-inside-case rule in MonoOpt; expand more Basis synonyms in Monoize
| -rw-r--r-- | demo/metaform.ur | 2 | ||||
| -rw-r--r-- | src/jscomp.sml | 5 | ||||
| -rw-r--r-- | src/mono_opt.sml | 16 | ||||
| -rw-r--r-- | src/monoize.sml | 6 | ||||
| -rw-r--r-- | 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 <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>) 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) => |