summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-05-17 13:25:57 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-05-17 13:25:57 -0400
commitcb6e88183a8c126118de373bfd98f3bef5e714a2 (patch)
treea3bf9deae6a78fff3abf976b31a5b8b427695edb /src
parent48105ce953be28a0858abdb28cff5c2fe443e376 (diff)
Corify FFI datatypes properly; eliminate nested JavaScript markers
Diffstat (limited to 'src')
-rw-r--r--src/corify.sml9
-rw-r--r--src/jscomp.sml75
-rw-r--r--src/monoize.sml6
3 files changed, 62 insertions, 28 deletions
diff --git a/src/corify.sml b/src/corify.sml
index 6793cd32..a4979790 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -824,6 +824,9 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) =
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 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) =
((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,
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 =
diff --git a/src/monoize.sml b/src/monoize.sml
index 50bd04e8..8ced53bb 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -2538,9 +2538,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
| "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 @@ datatype expungable = Client | Channel
fun monoize env file =
let
-
-
(* Calculate which exported functions need cookie signature protection *)
val rcook = foldl (fn ((d, _), rcook) =>
case d of