From 8d4ec5e3186b939a3c4d4a04e0e834836dd2c779 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 17 May 2009 13:25:57 -0400 Subject: Corify FFI datatypes properly; eliminate nested JavaScript markers --- src/jscomp.sml | 75 +++++++++++++++++++++++++++++++++++++++++----------------- 1 file changed, 53 insertions(+), 22 deletions(-) (limited to 'src/jscomp.sml') diff --git a/src/jscomp.sml b/src/jscomp.sml index 2f55d2da..65a81ea8 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -168,6 +168,21 @@ val compact = 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 @@ fun process file = 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 @@ fun process file = ^ (if isNullable t then ".v," else - "")), + "") + ^ ","), jsPat (depth+1) inner p succ fail, str "):", fail, @@ -657,13 +676,9 @@ fun process file = (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 @@ fun process file = 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 @@ fun process file = 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 @@ fun process file = 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 = -- cgit v1.2.3