Mercurial > urweb
changeset 815:493f44759879
Redo Jscomp
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sun, 17 May 2009 18:41:43 -0400 |
| parents | 3f3b211f9bca |
| children | 26e911ee924c |
| files | src/cjrize.sml src/jscomp.sml src/mono.sml src/mono_opt.sml src/mono_print.sml src/mono_reduce.sml src/mono_util.sml src/monoize.sml |
| diffstat | 8 files changed, 305 insertions(+), 126 deletions(-) [+] |
line wrap: on
line diff
--- a/src/cjrize.sml Sun May 17 14:36:55 2009 -0400 +++ b/src/cjrize.sml Sun May 17 18:41:43 2009 -0400 @@ -235,7 +235,6 @@ ((L'.PSome (t, p), loc), sm) end - fun cifyExp (eAll as (e, loc), sm) = case e of L.EPrim p => ((L'.EPrim p, loc), sm) @@ -470,7 +469,6 @@ ((L'.EUnurlify (e, t), loc), sm) end - | L.EJavaScript (_, _, SOME e) => cifyExp (e, sm) | L.EJavaScript _ => raise Fail "Cjrize: EJavaScript remains" | L.ESignalReturn _ => raise Fail "Cjrize: ESignalReturn remains"
--- a/src/jscomp.sml Sun May 17 14:36:55 2009 -0400 +++ b/src/jscomp.sml Sun May 17 18:41:43 2009 -0400 @@ -126,7 +126,7 @@ | EDml e => cu inner e | ENextval e => cu inner e | EUnurlify (e, _) => cu inner e - | EJavaScript (_, e, _) => cu inner e + | EJavaScript (_, e) => cu inner e | ESignalReturn e => cu inner e | ESignalBind (e1, e2) => cu inner e1 andalso cu inner e2 | ESignalSource e => cu inner e @@ -169,21 +169,8 @@ U.Exp.RelE _ => inner+1 | _ => inner} -val desourceify' = - U.Exp.map {typ = fn t => t, - exp = fn e => - case e of - EJavaScript (_, e, _) => #1 e - | _ => e} - -val desourceify = - U.File.map {typ = fn t => t, - exp = fn e => - case e of - EJavaScript (m, e, eo) => EJavaScript (m, desourceify' e, eo) - | _ => e, - decl = fn d => d} - +exception CantEmbed of typ + fun process file = let val (someTs, nameds) = @@ -387,9 +374,10 @@ ((EApp ((ENamed n', loc), e), loc), st) end) - | _ => (EM.errorAt loc "Don't know how to embed type in JavaScript"; + | _ => raise CantEmbed t + (*(EM.errorAt loc "Don't know how to embed type in JavaScript"; Print.prefaces "Can't embed" [("t", MonoPrint.p_typ MonoEnv.empty t)]; - (str loc "ERROR", st)) + (str loc "ERROR", st))*) fun unurlifyExp loc (t : typ, st) = case #1 t of @@ -773,14 +761,6 @@ end | EFfiApp (m, x, args) => let - val args = - case (m, x, args) of - ("Basis", "new_client_source", [(EJavaScript (_, e, _), _)]) => - (foundJavaScript := true; [e]) - | ("Basis", "set_client_source", [e1, (EJavaScript (_, e2, _), _)]) => - (foundJavaScript := true; [e1, e2]) - | _ => args - val name = case Settings.jsFunc (m, x) of NONE => (EM.errorAt loc ("Unsupported FFI function " ^ x ^ " in JavaScript"); @@ -985,15 +965,19 @@ str ")"], st) end - | EJavaScript (Source _, _, SOME _) => + | EJavaScript (Source _, e) => (foundJavaScript := true; - (e, st)) - | EJavaScript (_, _, SOME e) => - (foundJavaScript := true; - (strcat [str "cs(function(){return ", - compact inner e, - str "})"], - st)) + jsE inner (e, st)) + | EJavaScript (_, e) => + let + val (e, st) = jsE inner (e, st) + in + foundJavaScript := true; + (strcat [str "cs(function(){return ", + compact inner e, + str "})"], + st) + end | EClosure _ => unsupported "EClosure" | EQuery _ => unsupported "Query" @@ -1001,16 +985,6 @@ | ENextval _ => unsupported "Nextval" | EUnurlify _ => unsupported "EUnurlify" | EReturnBlob _ => unsupported "EUnurlify" - | EJavaScript (_, e, _) => - let - val (e, st) = jsE inner (e, st) - in - foundJavaScript := true; - (strcat [str "cs(function(){return ", - e, - str "})"], - st) - end | ESignalReturn e => let @@ -1094,56 +1068,274 @@ jsE end - val decl : state -> decl -> decl * state = - U.Decl.foldMapB {typ = fn x => x, - exp = fn (env, e, st) => - let - fun doCode m env e = - let - val len = length env - fun str s = (EPrim (Prim.String s), #2 e) - val locals = List.tabulate - (varDepth e, - fn i => str ("var _" ^ Int.toString (len + i) ^ ";")) - val old = e - val (e, st) = jsExp m env 0 (e, st) - val e = - case locals of - [] => e - | _ => - strcat (#2 e) (str "(function(){" - :: locals - @ [str "return ", - e, - str "}())"]) - in - (*Print.prefaces "jsify" [("old", MonoPrint.p_exp MonoEnv.empty old), - ("new", MonoPrint.p_exp MonoEnv.empty e)];*) - (EJavaScript (m, old, SOME e), st) - end - in - case e of - (*EJavaScript (m as Source t, orig, NONE) => - let - val loc = #2 orig - val (e, st) = doCode m (t :: env) (ERel 0, loc) - in - (ELet ("x", t, orig, (e, loc)), st) - end - |*) EJavaScript (m, orig, NONE) => - (foundJavaScript := true; - doCode m env orig) - | _ => (e, st) - end, - decl = fn (_, e, st) => (e, st), - bind = fn (env, U.Decl.RelE (_, t)) => t :: env - | (env, _) => env} - [] + fun patBinds ((p, _), env) = + case p of + PWild => env + | PVar (_, t) => t :: env + | PPrim _ => env + | PCon (_, _, NONE) => env + | PCon (_, _, SOME p) => patBinds (p, env) + | PRecord xpts => foldl (fn ((_, p, _), env) => patBinds (p, env)) env xpts + | PNone _ => env + | PSome (_, p) => patBinds (p, env) + + fun exp outer (e as (_, loc), st) = + ((*Print.preface ("exp", MonoPrint.p_exp MonoEnv.empty e);*) + case #1 e of + EPrim _ => (e, st) + | ERel _ => (e, st) + | ENamed _ => (e, st) + | ECon (_, _, NONE) => (e, st) + | ECon (dk, pc, SOME e) => + let + val (e, st) = exp outer (e, st) + in + ((ECon (dk, pc, SOME e), loc), st) + end + | ENone _ => (e, st) + | ESome (t, e) => + let + val (e, st) = exp outer (e, st) + in + ((ESome (t, e), loc), st) + end + | EFfi _ => (e, st) + | EFfiApp (m, x, es) => + let + val (es, st) = ListUtil.foldlMap (exp outer) st es + in + ((EFfiApp (m, x, es), loc), st) + end + | EApp (e1, e2) => + let + val (e1, st) = exp outer (e1, st) + val (e2, st) = exp outer (e2, st) + in + ((EApp (e1, e2), loc), st) + end + | EAbs (x, dom, ran, e) => + let + val (e, st) = exp (dom :: outer) (e, st) + in + ((EAbs (x, dom, ran, e), loc), st) + end + + | EUnop (s, e) => + let + val (e, st) = exp outer (e, st) + in + ((EUnop (s, e), loc), st) + end + | EBinop (s, e1, e2) => + let + val (e1, st) = exp outer (e1, st) + val (e2, st) = exp outer (e2, st) + in + ((EBinop (s, e1, e2), loc), st) + end + + | ERecord xets => + let + val (xets, st) = ListUtil.foldlMap (fn ((x, e, t), st) => + let + val (e, st) = exp outer (e, st) + in + ((x, e, t), st) + end) st xets + in + ((ERecord xets, loc), st) + end + | EField (e, s) => + let + val (e, st) = exp outer (e, st) + in + ((EField (e, s), loc), st) + end + + | ECase (e, pes, ts) => + let + val (e, st) = exp outer (e, st) + val (pes, st) = ListUtil.foldlMap (fn ((p, e), st) => + let + val (e, st) = exp (patBinds (p, outer)) (e, st) + in + ((p, e), st) + end) st pes + in + ((ECase (e, pes, ts), loc), st) + end + + | EStrcat (e1, e2) => + let + val (e1, st) = exp outer (e1, st) + val (e2, st) = exp outer (e2, st) + in + ((EStrcat (e1, e2), loc), st) + end + + | EError (e, t) => + let + val (e, st) = exp outer (e, st) + in + ((EError (e, t), loc), st) + end + | EReturnBlob {blob, mimeType, t} => + let + val (blob, st) = exp outer (blob, st) + val (mimeType, st) = exp outer (mimeType, st) + in + ((EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), st) + end + + | EWrite e => + let + val (e, st) = exp outer (e, st) + in + ((EWrite e, loc), st) + end + | ESeq (e1, e2) => + let + val (e1, st) = exp outer (e1, st) + val (e2, st) = exp outer (e2, st) + in + ((ESeq (e1, e2), loc), st) + end + | ELet (x, t, e1, e2) => + let + val (e1, st) = exp outer (e1, st) + val (e2, st) = exp (t :: outer) (e2, st) + in + ((ELet (x, t, e1, e2), loc), st) + end + + | EClosure (n, es) => + let + val (es, st) = ListUtil.foldlMap (exp outer) st es + in + ((EClosure (n, es), loc), st) + end + + | EQuery {exps, tables, state, query, body, initial} => + let + val (query, st) = exp outer (query, st) + val (body, st) = exp outer (body, st) + val (initial, st) = exp outer (initial, st) + in + ((EQuery {exps = exps, tables = tables, state = state, + query = query, body = body, initial = initial}, loc), st) + end + | EDml e => + let + val (e, st) = exp outer (e, st) + in + ((EDml e, loc), st) + end + | ENextval e => + let + val (e, st) = exp outer (e, st) + in + ((ENextval e, loc), st) + end + + | EUnurlify (e, t) => + let + val (e, st) = exp outer (e, st) + in + ((EUnurlify (e, t), loc), st) + end + + | EJavaScript (m, e') => + (let + val len = length outer + fun str s = (EPrim (Prim.String s), #2 e') + + val locals = List.tabulate + (varDepth e', + fn i => str ("var _" ^ Int.toString (len + i) ^ ";")) + + val (e', st) = jsExp m outer 0 (e', st) + + val e' = + case locals of + [] => e' + | _ => + strcat (#2 e') (str "(function(){" + :: locals + @ [str "return ", + e', + str "}())"]) + in + (e', st) + end handle CantEmbed _ => (e, st)) + + | ESignalReturn e => + let + val (e, st) = exp outer (e, st) + in + ((ESignalReturn e, loc), st) + end + | ESignalBind (e1, e2) => + let + val (e1, st) = exp outer (e1, st) + val (e2, st) = exp outer (e2, st) + in + ((ESignalBind (e1, e2), loc), st) + end + | ESignalSource e => + let + val (e, st) = exp outer (e, st) + in + ((ESignalSource e, loc), st) + end + + | EServerCall (e1, e2, t, ef) => + let + val (e1, st) = exp outer (e1, st) + val (e2, st) = exp outer (e2, st) + in + ((EServerCall (e1, e2, t, ef), loc), st) + end + | ERecv (e1, e2, t) => + let + val (e1, st) = exp outer (e1, st) + val (e2, st) = exp outer (e2, st) + in + ((ERecv (e1, e2, t), loc), st) + end + | ESleep (e1, e2) => + let + val (e1, st) = exp outer (e1, st) + val (e2, st) = exp outer (e2, st) + in + ((ESleep (e1, e2), loc), st) + end) + + fun decl (d as (_, loc), st) = + case #1 d of + DVal (x, n, t, e, s) => + let + val (e, st) = exp [] (e, st) + in + ((DVal (x, n, t, e, s), loc), st) + end + | DValRec vis => + let + val (vis, st) = ListUtil.foldlMap (fn ((x, n, t, e, s), st) => + let + val (e, st) = exp [] (e, st) + in + ((x, n, t, e, s), st) + end) st vis + in + ((DValRec vis, loc), st) + end + | _ => (d, st) fun doDecl (d, st) = let - val (d, st) = decl st d + (*val () = Print.preface ("doDecl", MonoPrint.p_decl MonoEnv.empty d)*) + val (d, st) = decl (d, st) in (List.revAppend (#decls st, [d]), {decls = [], @@ -1163,7 +1355,7 @@ listInjectors = TM.empty, decoders = IM.empty, maxName = U.File.maxName file + 1} - (desourceify file) + file val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Config.libJs, file = "urweb.js"}) fun lines acc =
--- a/src/mono.sml Sun May 17 14:36:55 2009 -0400 +++ b/src/mono.sml Sun May 17 18:41:43 2009 -0400 @@ -108,7 +108,7 @@ | EUnurlify of exp * typ - | EJavaScript of javascript_mode * exp * exp option + | EJavaScript of javascript_mode * exp | ESignalReturn of exp | ESignalBind of exp * exp
--- a/src/mono_opt.sml Sun May 17 14:36:55 2009 -0400 +++ b/src/mono_opt.sml Sun May 17 18:41:43 2009 -0400 @@ -376,8 +376,6 @@ | ESignalBind ((ESignalReturn e1, loc), e2) => optExp (EApp (e2, e1), loc) - | EJavaScript (_, _, SOME (e, _)) => e - | EFfiApp ("Basis", "bless", [(se as EPrim (Prim.String s), loc)]) => (if Settings.checkUrl s then ()
--- a/src/mono_print.sml Sun May 17 14:36:55 2009 -0400 +++ b/src/mono_print.sml Sun May 17 18:41:43 2009 -0400 @@ -310,13 +310,12 @@ | EUnurlify (e, _) => box [string "unurlify(", p_exp env e, string ")"] - | EJavaScript (m, e, NONE) => box [string "JavaScript(", - p_mode env m, - string ",", - space, - p_exp env e, - string ")"] - | EJavaScript (_, _, SOME e) => p_exp env e + | EJavaScript (m, e) => box [string "JavaScript(", + p_mode env m, + string ",", + space, + p_exp env e, + string ")"] | ESignalReturn e => box [string "Return(", p_exp env e,
--- a/src/mono_reduce.sml Sun May 17 14:36:55 2009 -0400 +++ b/src/mono_reduce.sml Sun May 17 18:41:43 2009 -0400 @@ -74,7 +74,7 @@ | ELet (_, _, e1, e2) => impure e1 orelse impure e2 | EClosure (_, es) => List.exists impure es - | EJavaScript (_, e, _) => impure e + | EJavaScript (_, e) => impure e | ESignalReturn e => impure e | ESignalBind (e1, e2) => impure e1 orelse impure e2 | ESignalSource e => impure e @@ -344,7 +344,7 @@ | EDml e => summarize d e @ [WriteDb] | ENextval e => summarize d e @ [WriteDb] | EUnurlify (e, _) => summarize d e - | EJavaScript (_, e, _) => summarize d e + | EJavaScript (_, e) => summarize d e | ESignalReturn e => summarize d e | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2 | ESignalSource e => summarize d e
--- a/src/mono_util.sml Sun May 17 14:36:55 2009 -0400 +++ b/src/mono_util.sml Sun May 17 18:41:43 2009 -0400 @@ -340,20 +340,12 @@ S.map2 (mft t, fn t' => (EUnurlify (e', t'), loc))) - | EJavaScript (m, e, NONE) => + | EJavaScript (m, e) => S.bind2 (mfmode ctx m, fn m' => S.map2 (mfe ctx e, fn e' => - (EJavaScript (m', e', NONE), loc))) - | EJavaScript (m, e, SOME e2) => - S.bind2 (mfmode ctx m, - fn m' => - S.bind2 (mfe ctx e, - fn e' => - S.map2 (mfe ctx e2, - fn e2' => - (EJavaScript (m, e', SOME e2'), loc)))) + (EJavaScript (m', e'), loc))) | ESignalReturn e => S.map2 (mfe ctx e,
--- a/src/monoize.sml Sun May 17 14:36:55 2009 -0400 +++ b/src/monoize.sml Sun May 17 18:41:43 2009 -0400 @@ -1173,7 +1173,7 @@ ((L'.EAbs ("x", t, (L'.TFun ((L'.TRecord [], loc), (L'.TSource, loc)), loc), (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TSource, loc), (L'.EFfiApp ("Basis", "new_client_source", - [(L'.EJavaScript (L'.Source t, (L'.ERel 1, loc), NONE), loc)]), + [(L'.EJavaScript (L'.Source t, (L'.ERel 1, loc)), loc)]), loc)), loc)), loc), fm) @@ -1189,7 +1189,7 @@ (L'.EFfiApp ("Basis", "set_client_source", [(L'.ERel 2, loc), (L'.EJavaScript (L'.Source t, - (L'.ERel 1, loc), NONE), loc)]), + (L'.ERel 1, loc)), loc)]), loc)), loc)), loc)), loc), fm) end @@ -2410,7 +2410,7 @@ (L'.EStrcat ( (L'.EPrim (Prim.String s'), loc), (L'.EStrcat ( - (L'.EJavaScript (L'.Attribute, e, NONE), loc), + (L'.EJavaScript (L'.Attribute, e), loc), (L'.EPrim (Prim.String "'"), loc)), loc)), loc)), loc), fm) @@ -2500,11 +2500,11 @@ (fn ("Source", _, _) => NONE | ("Onchange", e, _) => SOME (strcat [str "addOnChange(d,", - (L'.EJavaScript (L'.Script, e, NONE), loc), + (L'.EJavaScript (L'.Script, e), loc), str ")"]) | (x, e, _) => SOME (strcat [str ("d." ^ lowercaseFirst x ^ "="), - (L'.EJavaScript (L'.Script, e, NONE), loc), + (L'.EJavaScript (L'.Script, e), loc), str ";"])) attrs in @@ -2524,7 +2524,7 @@ let val e = (L'.EApp (e, (L'.ERecord [], loc)), loc) in - (L'.EJavaScript (L'.Attribute, e, NONE), loc) + (L'.EJavaScript (L'.Attribute, e), loc) end in normal ("body", @@ -2543,7 +2543,7 @@ |*) [("Signal", e, _)] => ((L'.EStrcat ((L'.EPrim (Prim.String "<span><script type=\"text/javascript\">dyn("), loc), - (L'.EStrcat ((L'.EJavaScript (L'.Script, e, NONE), loc), + (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc), (L'.EPrim (Prim.String ")</script></span>"), loc)), loc)), loc), fm) | _ => raise Fail "Monoize: Bad dyn attributes") @@ -2566,7 +2566,7 @@ end | SOME (_, src, _) => (strcat [str "<span><script type=\"text/javascript\">inp(\"input\",", - (L'.EJavaScript (L'.Script, src, NONE), loc), + (L'.EJavaScript (L'.Script, src), loc), str ",\"\")</script></span>"], fm)) | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); @@ -2638,7 +2638,7 @@ | SOME (_, src, _) => let val sc = strcat [str "inp(\"input\",", - (L'.EJavaScript (L'.Script, src, NONE), loc), + (L'.EJavaScript (L'.Script, src), loc), str ",\"\")"] val sc = setAttrs sc in @@ -2663,9 +2663,9 @@ val (xml, fm) = monoExp (env, st, fm) xml val sc = strcat [str "inp(\"select\",", - (L'.EJavaScript (L'.Script, src, NONE), loc), + (L'.EJavaScript (L'.Script, src), loc), str ",", - (L'.EJavaScript (L'.Script, xml, NONE), loc), + (L'.EJavaScript (L'.Script, xml), loc), str ")"] val sc = setAttrs sc in