Mercurial > urweb
changeset 813:7b380e2b9e68
Corify FFI datatypes properly; eliminate nested JavaScript markers
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sun, 17 May 2009 13:25:57 -0400 |
| parents | 2fbd1ac2f04b |
| children | 3f3b211f9bca |
| files | src/corify.sml src/jscomp.sml src/monoize.sml |
| diffstat | 3 files changed, 62 insertions(+), 28 deletions(-) [+] |
line wrap: on
line diff
--- a/src/corify.sml Sat May 16 18:09:14 2009 -0400 +++ b/src/corify.sml Sun May 17 13:25:57 2009 -0400 @@ -824,6 +824,9 @@ ListUtil.foldlMap (fn ((x, n, xs, xnts), (ds', st, cmap, conmap)) => let + val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) + k xs + val dk = ElabUtil.classifyDatatype xnts val (st, n') = St.bindCon st x n val (xnts, (ds', st, cmap, conmap)) = @@ -885,12 +888,14 @@ ((x', n, to), (d :: ds', st, cmap, conmap)) end) (ds', st, cmap, conmap) xnts + + val d = (L'.DCon (x, n', k', (L'.CFfi (m, x), loc)), loc) in - ((x, n', xs, xnts), (ds', st, cmap, conmap)) + ((x, n', xs, xnts), (d :: ds', st, cmap, conmap)) end) ([], st, cmap, conmap) dts in - (ds' @ (L'.DDatatype dts, loc) :: ds, + (List.revAppend (ds', ds), cmap, conmap, st,
--- a/src/jscomp.sml Sat May 16 18:09:14 2009 -0400 +++ b/src/jscomp.sml Sun May 17 13:25:57 2009 -0400 @@ -168,6 +168,21 @@ case b of 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} fun process file = let @@ -251,16 +266,19 @@ let val (e', st) = quoteExp loc t ((ERel 0, loc), st) in - ((ECase (e, - [((PNone t, loc), - str loc "null"), - ((PSome (t, (PVar ("x", t), loc)), loc), - if isNullable t then - strcat loc [str loc "{v:", e', str loc "}"] - else - e')], - {disc = (TOption t, loc), - result = (TFfi ("Basis", "string"), loc)}), loc), + (case #1 e' of + EPrim (Prim.String "ERROR") => raise Fail "UHOH" + | _ => + (ECase (e, + [((PNone t, loc), + str loc "null"), + ((PSome (t, (PVar ("x", t), loc)), loc), + if isNullable t then + strcat loc [str loc "{v:", e', str loc "}"] + else + e')], + {disc = (TOption t, loc), + result = (TFfi ("Basis", "string"), loc)}), loc), st) end @@ -578,7 +596,8 @@ ^ (if isNullable t then ".v," else - "")), + "") + ^ ","), jsPat (depth+1) inner p succ fail, str "):", fail, @@ -657,13 +676,9 @@ (str ("_" ^ var n), st) else let - (*val () = Print.prefaces "ERel" - [("n", Print.PD.string (Int.toString n)), - ("inner", Print.PD.string (Int.toString inner)), - ("eq", MonoPrint.p_exp MonoEnv.empty - (#1 (quoteExp (List.nth (outer, n - inner)) - ((ERel (n - inner), loc), st))))]*) val n = n - inner + (*val () = Print.prefaces "quote" [("t", MonoPrint.p_typ MonoEnv.empty + (List.nth (outer, n)))]*) in quoteExp (List.nth (outer, n)) ((ERel n, loc), st) end @@ -1083,7 +1098,7 @@ U.Decl.foldMapB {typ = fn x => x, exp = fn (env, e, st) => let - fun doCode m env orig e = + fun doCode m env e = let val len = length env fun str s = (EPrim (Prim.String s), #2 e) @@ -1093,16 +1108,32 @@ 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, orig, SOME (strcat (#2 e) (locals @ [e]))), st) + (EJavaScript (m, old, SOME e), st) end in case e of - EJavaScript (m, orig, NONE) => + (*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 orig) + doCode m env orig) | _ => (e, st) end, decl = fn (_, e, st) => (e, st), @@ -1132,7 +1163,7 @@ listInjectors = TM.empty, decoders = IM.empty, maxName = U.File.maxName file + 1} - file + (desourceify file) val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Config.libJs, file = "urweb.js"}) fun lines acc =
--- a/src/monoize.sml Sat May 16 18:09:14 2009 -0400 +++ b/src/monoize.sml Sun May 17 13:25:57 2009 -0400 @@ -2538,9 +2538,9 @@ | "dyn" => (case attrs of - [("Signal", (L'.EApp ((L'.EAbs (_, _, _, (L'.ESignalReturn (L'.ERel 0, _), _)), _), + (*[("Signal", (L'.EApp ((L'.EAbs (_, _, _, (L'.ESignalReturn (L'.ERel 0, _), _)), _), e), _), _)] => (e, fm) - | [("Signal", e, _)] => + |*) [("Signal", e, _)] => ((L'.EStrcat ((L'.EPrim (Prim.String "<span><script type=\"text/javascript\">dyn("), loc), (L'.EStrcat ((L'.EJavaScript (L'.Script, e, NONE), loc), @@ -3188,8 +3188,6 @@ fun monoize env file = let - - (* Calculate which exported functions need cookie signature protection *) val rcook = foldl (fn ((d, _), rcook) => case d of