summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/jscomp.sml67
-rw-r--r--src/mono.sml2
-rw-r--r--src/monoize.sml5
-rw-r--r--tests/jsinj.ur14
-rw-r--r--tests/jsinj.urp3
5 files changed, 70 insertions, 21 deletions
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 67d8d9c1..b27a860b 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -102,6 +102,8 @@ fun strcat loc es =
| [x] => x
| x :: es' => (EStrcat (x, strcat loc es'), loc)
+exception Unsupported of string * EM.span
+
fun process file =
let
val nameds = foldl (fn ((DVal (_, n, t, e, _), _), nameds) => IM.insert (nameds, n, e)
@@ -111,13 +113,28 @@ fun process file =
| (_, nameds) => nameds)
IM.empty file
+ fun str loc s = (EPrim (Prim.String s), loc)
+
+ fun quoteExp loc (t : typ) e =
+ case #1 t of
+ TSource => strcat loc [str loc "s",
+ (EFfiApp ("Basis", "htmlifyInt", [e]), loc)]
+ | TRecord [] => str loc "null"
+
+ | TFfi ("Basis", "string") => e
+ | TFfi ("Basis", "int") => (EFfiApp ("Basis", "htmlifyInt", [e]), loc)
+
+ | _ => (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")
+
fun jsExp mode skip outer =
let
val len = length outer
fun jsE inner (e as (_, loc), st) =
let
- fun str s = (EPrim (Prim.String s), loc)
+ val str = str loc
fun var n = Int.toString (len + inner - n - 1)
@@ -134,22 +151,10 @@ fun process file =
| TRecord [] => true
| _ => false
- fun unsupported s =
- (EM.errorAt loc (s ^ " in code to be compiled to JavaScript");
- (str "ERROR", st))
+ fun unsupported s = raise Unsupported (s, loc)
val strcat = strcat loc
- fun quoteExp (t : typ) e =
- case #1 t of
- TSource => strcat [str "s",
- (EFfiApp ("Basis", "htmlifyInt", [e]), loc)]
- | TRecord [] => str "null"
- | TFfi ("Basis", "string") => e
- | _ => (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 "ERROR")
-
fun jsPrim p =
case p of
Prim.String s =>
@@ -241,7 +246,11 @@ fun process file =
EPrim (Prim.String s) => s
| EStrcat (e1, e2) => deStrcat e1 ^ deStrcat e2
| _ => raise Fail "Jscomp: deStrcat"
+
+ val quoteExp = quoteExp loc
in
+ (*Print.prefaces "jsE" [("e", MonoPrint.p_exp MonoEnv.empty e)];*)
+
case #1 e of
EPrim p => (jsPrim p, st)
| ERel n =>
@@ -513,12 +522,15 @@ fun process file =
str ")"], st)
end
+ | EJavaScript (_, _, SOME e) => (e, st)
+
| EClosure _ => unsupported "EClosure"
| EQuery _ => unsupported "Query"
| EDml _ => unsupported "DML"
| ENextval _ => unsupported "Nextval"
| EUnurlify _ => unsupported "EUnurlify"
- | EJavaScript _ => unsupported "Nested JavaScript"
+ | EJavaScript (_, e, _) => unsupported "Nested JavaScript"
+
| ESignalReturn e =>
let
val (e, st) = jsE inner (e, st)
@@ -572,9 +584,28 @@ fun process file =
end
in
case e of
- EJavaScript (m, orig as (EAbs (_, t, _, e), _), _) =>
- doCode m 1 (t :: env) orig e
- | EJavaScript (m, e, _) => doCode m 0 env e e
+ EJavaScript (m as Source t, orig, _) =>
+ (doCode m 0 env orig orig
+ handle Unsupported (s, loc) =>
+ let
+ val e = ELet ("js", t, orig, quoteExp (#2 orig) t
+ (ERel 0, #2 orig))
+ in
+ (EJavaScript (m, orig, SOME (e, #2 orig)), st)
+ end)
+
+ | EJavaScript (m, orig as (EAbs (_, t, _, e), _), _) =>
+ (doCode m 1 (t :: env) orig e
+ handle Unsupported (s, loc) =>
+ (EM.errorAt loc (s ^ " in code to be compiled to JavaScript");
+ (EPrim (Prim.String "ERROR"), st)))
+
+ | EJavaScript (m, orig, _) =>
+ (doCode m 0 env orig orig
+ handle Unsupported (s, loc) =>
+ (EM.errorAt loc (s ^ " in code to be compiled to JavaScript");
+ (EPrim (Prim.String "ERROR"), st)))
+
| _ => (e, st)
end,
decl = fn (_, e, st) => (e, st),
diff --git a/src/mono.sml b/src/mono.sml
index b58396fa..8999704c 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -60,7 +60,7 @@ withtype pat = pat' located
datatype javascript_mode =
Attribute
| Script
- | File
+ | Source of typ
datatype exp' =
EPrim of Prim.t
diff --git a/src/monoize.sml b/src/monoize.sml
index f62848c5..6c4534ac 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -976,7 +976,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'.File, (L'.ERel 1, loc), NONE), loc)]),
+ [(L'.EJavaScript (L'.Source t, (L'.ERel 1, loc), NONE), loc)]),
loc)), loc)),
loc),
fm)
@@ -991,7 +991,8 @@ 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), NONE), loc)]),
+ (L'.EJavaScript (L'.Source t,
+ (L'.ERel 1, loc), NONE), loc)]),
loc)), loc)), loc)), loc),
fm)
end
diff --git a/tests/jsinj.ur b/tests/jsinj.ur
new file mode 100644
index 00000000..194d26be
--- /dev/null
+++ b/tests/jsinj.ur
@@ -0,0 +1,14 @@
+cookie int : int
+
+fun getOpt (t ::: Type) (o : option t) (v : t) : t =
+ case o of
+ None => v
+ | Some x => x
+
+fun main () : transaction page =
+ n <- getCookie int;
+ sn <- source (getOpt n 7);
+ return <xml><body>
+ <dyn signal={n <- signal sn; return <xml>{[n]}</xml>}/>
+ <a onclick={set sn 6}>CHANGE</a>
+ </body></xml>
diff --git a/tests/jsinj.urp b/tests/jsinj.urp
new file mode 100644
index 00000000..dc929b9d
--- /dev/null
+++ b/tests/jsinj.urp
@@ -0,0 +1,3 @@
+debug
+
+jsinj
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-19 02:45:27 +0000