summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-05-17 18:41:43 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-05-17 18:41:43 -0400
commiteaecb983d749637eaa651f641caf2136e889dfb0 (patch)
tree815d7b44e23dc823893aabf1f75ef087c0037be1
parent7bbee7c3f41f0386072d0d73cd3477d0a4734ca9 (diff)
Redo Jscomp
-rw-r--r--src/cjrize.sml2
-rw-r--r--src/jscomp.sml374
-rw-r--r--src/mono.sml2
-rw-r--r--src/mono_opt.sml2
-rw-r--r--src/mono_print.sml13
-rw-r--r--src/mono_reduce.sml4
-rw-r--r--src/mono_util.sml12
-rw-r--r--src/monoize.sml22
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