diff options
author | Adam Chlipala <adamc@hcoop.net> | 2009-05-17 18:41:43 -0400 |
---|---|---|
committer | Adam Chlipala <adamc@hcoop.net> | 2009-05-17 18:41:43 -0400 |
commit | eaecb983d749637eaa651f641caf2136e889dfb0 (patch) | |
tree | 815d7b44e23dc823893aabf1f75ef087c0037be1 | |
parent | 7bbee7c3f41f0386072d0d73cd3477d0a4734ca9 (diff) |
Redo Jscomp
-rw-r--r-- | src/cjrize.sml | 2 | ||||
-rw-r--r-- | src/jscomp.sml | 374 | ||||
-rw-r--r-- | src/mono.sml | 2 | ||||
-rw-r--r-- | src/mono_opt.sml | 2 | ||||
-rw-r--r-- | src/mono_print.sml | 13 | ||||
-rw-r--r-- | src/mono_reduce.sml | 4 | ||||
-rw-r--r-- | src/mono_util.sml | 12 | ||||
-rw-r--r-- | src/monoize.sml | 22 |
8 files changed, 305 insertions, 126 deletions
diff --git a/src/cjrize.sml b/src/cjrize.sml index c4d916eb..5f3ea5a8 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -235,7 +235,6 @@ fun cifyPat ((p, loc), sm) = ((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 @@ fun cifyExp (eAll as (e, loc), sm) = ((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" diff --git a/src/jscomp.sml b/src/jscomp.sml index 65a81ea8..4352693f 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -126,7 +126,7 @@ fun closedUpto d = | 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 @@ val compact = 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 @@ fun process file = ((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 @@ fun process file = 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,33 +965,27 @@ fun process file = 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)) - - | EClosure _ => unsupported "EClosure" - | EQuery _ => unsupported "Query" - | EDml _ => unsupported "DML" - | ENextval _ => unsupported "Nextval" - | EUnurlify _ => unsupported "EUnurlify" - | EReturnBlob _ => unsupported "EUnurlify" - | EJavaScript (_, e, _) => + jsE inner (e, st)) + | EJavaScript (_, e) => let val (e, st) = jsE inner (e, st) in foundJavaScript := true; (strcat [str "cs(function(){return ", - e, + compact inner e, str "})"], st) end + | EClosure _ => unsupported "EClosure" + | EQuery _ => unsupported "Query" + | EDml _ => unsupported "DML" + | ENextval _ => unsupported "Nextval" + | EUnurlify _ => unsupported "EUnurlify" + | EReturnBlob _ => unsupported "EUnurlify" + | ESignalReturn e => let val (e, st) = jsE inner (e, st) @@ -1094,56 +1068,274 @@ fun process file = 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 @@ fun process file = 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 = diff --git a/src/mono.sml b/src/mono.sml index 52d24998..64ed448c 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -108,7 +108,7 @@ datatype exp' = | EUnurlify of exp * typ - | EJavaScript of javascript_mode * exp * exp option + | EJavaScript of javascript_mode * exp | ESignalReturn of exp | ESignalBind of exp * exp diff --git a/src/mono_opt.sml b/src/mono_opt.sml index fefe24e1..97ad1916 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -376,8 +376,6 @@ fun exp e = | 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 () diff --git a/src/mono_print.sml b/src/mono_print.sml index 0395a063..ae11d3b8 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -310,13 +310,12 @@ fun p_exp' par env (e, _) = | 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, diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 77672acc..770aaa2e 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -74,7 +74,7 @@ fun impure (e, _) = | 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 @@ fun reduce file = | 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 diff --git a/src/mono_util.sml b/src/mono_util.sml index 83621c99..e2bed8eb 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -340,20 +340,12 @@ fun mapfoldB {typ = fc, exp = fe, bind} = 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, diff --git a/src/monoize.sml b/src/monoize.sml index 8ced53bb..6c41de21 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1173,7 +1173,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((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 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (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 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (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 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (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 @@ fun monoExp (env, st, fm) (all as (e, loc)) = 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 @@ fun monoExp (env, st, fm) (all as (e, loc)) = |*) [("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 @@ fun monoExp (env, st, fm) (all as (e, loc)) = 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 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | 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 @@ fun monoExp (env, st, fm) (all as (e, loc)) = 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 |