diff options
| -rw-r--r-- | src/jscomp.sml | 67 | ||||
| -rw-r--r-- | src/mono.sml | 2 | ||||
| -rw-r--r-- | src/monoize.sml | 5 | ||||
| -rw-r--r-- | tests/jsinj.ur | 14 | ||||
| -rw-r--r-- | tests/jsinj.urp | 3 |
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 |