Mercurial > urweb
changeset 590:57f476c934da
Injecting an int
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Thu, 01 Jan 2009 15:11:17 -0500 |
| parents | 102e81d975e3 |
| children | 8f8771f32909 |
| files | src/jscomp.sml src/mono.sml src/monoize.sml tests/jsinj.ur tests/jsinj.urp |
| diffstat | 5 files changed, 70 insertions(+), 21 deletions(-) [+] |
line wrap: on
line diff
--- a/src/jscomp.sml Thu Jan 01 11:58:00 2009 -0500 +++ b/src/jscomp.sml Thu Jan 01 15:11:17 2009 -0500 @@ -102,6 +102,8 @@ | [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 @@ | (_, 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 @@ | 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 @@ 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 @@ 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 @@ 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),
--- a/src/mono.sml Thu Jan 01 11:58:00 2009 -0500 +++ b/src/mono.sml Thu Jan 01 15:11:17 2009 -0500 @@ -60,7 +60,7 @@ datatype javascript_mode = Attribute | Script - | File + | Source of typ datatype exp' = EPrim of Prim.t
--- a/src/monoize.sml Thu Jan 01 11:58:00 2009 -0500 +++ b/src/monoize.sml Thu Jan 01 15:11:17 2009 -0500 @@ -976,7 +976,7 @@ ((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 @@ (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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/jsinj.ur Thu Jan 01 15:11:17 2009 -0500 @@ -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>