aboutsummaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/cjrize.sml2
-rw-r--r--src/jscomp.sml15
-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.sml10
-rw-r--r--src/monoize.sml16
8 files changed, 41 insertions, 23 deletions
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 6d0ece61..1a5d10c0 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -422,7 +422,9 @@ 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"
| L.ESignalBind _ => raise Fail "Cjrize: ESignalBind remains"
| L.ESignalSource _ => raise Fail "Cjrize: ESignalSource remains"
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 8b874289..a4e3dd35 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -190,6 +190,12 @@ fun jsExp mode outer =
end
| EFfiApp (m, x, args) =>
let
+ val args =
+ case (m, x, args) of
+ ("Basis", "new_client_source", [(EJavaScript (_, e, _), _)]) => [e]
+ | ("Basis", "set_client_source", [e1, (EJavaScript (_, e2, _), _)]) => [e1, e2]
+ | _ => args
+
val name = case ffi (m, x) of
NONE => (EM.errorAt loc ("Unsupported FFI function " ^ x ^ " in JavaScript");
"ERROR")
@@ -200,7 +206,6 @@ fun jsExp mode outer =
| [e] =>
let
val (e, st) = jsE inner (e, st)
-
in
(strcat [str (name ^ "("),
e,
@@ -398,7 +403,7 @@ val decl : state -> decl -> decl * state =
U.Decl.foldMapB {typ = fn x => x,
exp = fn (env, e, st) =>
let
- fun doCode m env e =
+ fun doCode m env orig e =
let
val len = length env
fun str s = (EPrim (Prim.String s), #2 e)
@@ -408,12 +413,12 @@ val decl : state -> decl -> decl * state =
fn i => str ("var uwr" ^ Int.toString (len + i) ^ ";"))
val (e, st) = jsExp m env 0 (e, st)
in
- (#1 (strcat (#2 e) (locals @ [e])), st)
+ (EJavaScript (m, orig, SOME (strcat (#2 e) (locals @ [e]))), st)
end
in
case e of
- EJavaScript (m, (EAbs (_, t, _, e), _)) => doCode m (t :: env) e
- | EJavaScript (m, e) => doCode m env e
+ EJavaScript (m, orig as (EAbs (_, t, _, e), _), _) => doCode m (t :: env) orig e
+ | EJavaScript (m, e, _) => doCode m env e e
| _ => (e, st)
end,
decl = fn (_, e, st) => (e, st),
diff --git a/src/mono.sml b/src/mono.sml
index 41457071..b58396fa 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -103,7 +103,7 @@ datatype exp' =
| EUnurlify of exp * typ
- | EJavaScript of javascript_mode * exp
+ | EJavaScript of javascript_mode * exp * exp option
| ESignalReturn of exp
| ESignalBind of exp * exp
diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index 550a055c..7f23d8b1 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -363,6 +363,8 @@ fun exp e =
| ESignalBind ((ESignalReturn e1, loc), e2) =>
optExp (EApp (e2, e1), loc)
+ | EJavaScript (_, _, SOME (e, _)) => e
+
| _ => e
and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e)
diff --git a/src/mono_print.sml b/src/mono_print.sml
index a876cfac..f8a23d1d 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -216,10 +216,12 @@ fun p_exp' par env (e, _) =
p_exp env e,
string ")"]
- | ESeq (e1, e2) => box [p_exp env e1,
+ | ESeq (e1, e2) => box [string "(",
+ p_exp env e1,
string ";",
space,
- p_exp env e2]
+ p_exp env e2,
+ string ")"]
| ELet (x, t, e1, e2) => box [string "(let",
space,
string x,
@@ -279,9 +281,10 @@ fun p_exp' par env (e, _) =
| EUnurlify (e, _) => box [string "unurlify(",
p_exp env e,
string ")"]
- | EJavaScript (_, e) => box [string "JavaScript(",
- p_exp env e,
- string ")"]
+ | EJavaScript (_, e, NONE) => box [string "JavaScript(",
+ p_exp env e,
+ string ")"]
+ | EJavaScript (_, _, SOME e) => p_exp env e
| ESignalReturn e => box [string "Return(",
p_exp env e,
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 072c548e..c96f97cf 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -76,7 +76,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
@@ -335,7 +335,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 3f9183d0..9ce3293b 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -324,10 +324,16 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
S.map2 (mft t,
fn t' =>
(EUnurlify (e', t'), loc)))
- | EJavaScript (m, e) =>
+ | EJavaScript (m, e, NONE) =>
S.map2 (mfe ctx e,
fn e' =>
- (EJavaScript (m, e'), loc))
+ (EJavaScript (m, e', NONE), loc))
+ | EJavaScript (m, e, SOME e2) =>
+ S.bind2 (mfe ctx e,
+ fn e' =>
+ S.map2 (mfe ctx e2,
+ fn e2' =>
+ (EJavaScript (m, e', SOME e2'), loc)))
| ESignalReturn e =>
S.map2 (mfe ctx e,
diff --git a/src/monoize.sml b/src/monoize.sml
index f40d49d0..f62848c5 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -976,7 +976,8 @@ 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'.File, (L'.ERel 1, loc)), loc)]), loc)), loc)),
+ [(L'.EJavaScript (L'.File, (L'.ERel 1, loc), NONE), loc)]),
+ loc)), loc)),
loc),
fm)
end
@@ -990,7 +991,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
(L'.EFfiApp ("Basis", "set_client_source",
[(L'.ERel 2, loc),
- (L'.EJavaScript (L'.File, (L'.ERel 1, loc)), loc)]),
+ (L'.EJavaScript (L'.File, (L'.ERel 1, loc), NONE), loc)]),
loc)), loc)), loc)), loc),
fm)
end
@@ -1801,7 +1802,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), loc),
+ (L'.EJavaScript (L'.Attribute, e, NONE), loc),
(L'.EPrim (Prim.String "'"), loc)), loc)),
loc)), loc),
fm)
@@ -1887,13 +1888,12 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
| "dyn" =>
(case #1 attrs of
- (*L'.ERecord [("Signal", (L'.EApp ((L'.EAbs (_, _, _, (L'.ESignalReturn (L'.ERel 0, _), _)), _),
- e), _), _)] => (e, fm) *)
-
- L'.ERecord [("Signal", e, _)] =>
+ L'.ERecord [("Signal", (L'.EApp ((L'.EAbs (_, _, _, (L'.ESignalReturn (L'.ERel 0, _), _)), _),
+ e), _), _)] => (e, fm)
+ | L'.ERecord [("Signal", e, _)] =>
((L'.EStrcat
((L'.EPrim (Prim.String "<script type=\"text/javascript\">dyn("), loc),
- (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc),
+ (L'.EStrcat ((L'.EJavaScript (L'.Script, e, NONE), loc),
(L'.EPrim (Prim.String ")</script>"), loc)), loc)), loc),
fm)
| _ => raise Fail "Monoize: Bad dyn attributes")
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-26 08:54:36 +0000