Mercurial > urweb
changeset 568:55fc747a67dc
Initial <dyn> support
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sat, 20 Dec 2008 15:46:48 -0500 |
| parents | 1901db85acb4 |
| children | 162d5308e34f |
| files | lib/basis.urs src/cjrize.sml src/jscomp.sml src/mono.sml src/mono_print.sml src/mono_reduce.sml src/mono_util.sml src/monoize.sml tests/sreturn.ur tests/sreturn.urp |
| diffstat | 10 files changed, 133 insertions(+), 28 deletions(-) [+] |
line wrap: on
line diff
--- a/lib/basis.urs Sat Dec 20 14:19:21 2008 -0500 +++ b/lib/basis.urs Sat Dec 20 15:46:48 2008 -0500 @@ -376,6 +376,9 @@ con tabl = [Body, Table] con tr = [Body, Tr] +val dyn : ctx ::: {Unit} -> use ::: {Type} -> bind ::: {Type} -> unit + -> tag [Signal = signal (xml ctx use bind)] ctx [] use bind + val head : unit -> tag [] html head [] [] val title : unit -> tag [] head [] [] [] @@ -433,7 +436,7 @@ val select : formTag string select [] val option : unit -> tag [Value = string, Selected = bool] select [] [] [] -val submit : ctx ::: {Unit} -> use ::: {Type} +val submit : ctx ::: {Unit} -> use ::: {Type} -> fn [[Form] ~ ctx] => unit -> tag [Value = string, Action = $use -> transaction page]
--- a/src/cjrize.sml Sat Dec 20 14:19:21 2008 -0500 +++ b/src/cjrize.sml Sat Dec 20 15:46:48 2008 -0500 @@ -120,6 +120,7 @@ in ((L'.TOption t, loc), sm) end + | L.TSignal _ => raise Fail "Cjrize: TSignal remains" in cify IM.empty x end @@ -420,7 +421,8 @@ ((L'.EUnurlify (e, t), loc), sm) end - | L.EJavaScript _ => raise Fail "EJavaScript remains" + | L.EJavaScript _ => raise Fail "Cjrize: EJavaScript remains" + | L.ESignalReturn _ => raise Fail "Cjrize: ESignalReturn remains" fun cifyDecl ((d, loc), sm) = case d of
--- a/src/jscomp.sml Sat Dec 20 14:19:21 2008 -0500 +++ b/src/jscomp.sml Sat Dec 20 15:46:48 2008 -0500 @@ -69,8 +69,15 @@ | ENextval _ => 0 | EUnurlify _ => 0 | EJavaScript _ => 0 + | ESignalReturn e => varDepth e -fun jsExp inAttr outer = +fun strcat loc es = + case es of + [] => (EPrim (Prim.String ""), loc) + | [x] => x + | x :: es' => (EStrcat (x, strcat loc es'), loc) + +fun jsExp mode outer = let val len = length outer @@ -85,11 +92,7 @@ PConVar n => str (Int.toString n) | PConFfi {con, ...} => str ("\"_" ^ con ^ "\"") - fun strcat es = - case es of - [] => (EPrim (Prim.String ""), loc) - | [x] => x - | x :: es' => (EStrcat (x, strcat es'), loc) + fun isNullable (t, _) = case t of @@ -99,17 +102,19 @@ fun unsupported s = (EM.errorAt loc (s ^ " in code to be compiled to JavaScript"); (str "ERROR", st)) + + val strcat = strcat loc in case #1 e of EPrim (Prim.String s) => (str ("\"" ^ String.translate (fn #"'" => - if inAttr then + if mode = Attribute then "\\047" else "'" | #"<" => - if inAttr then + if mode = Script then "<" else "\\074" @@ -274,7 +279,14 @@ st) end - | EWrite _ => unsupported "EWrite" + | EWrite e => + let + val (e, st) = jsE inner (e, st) + in + (strcat [str "document.write(", + e, + str ")"], st) + end | ESeq (e1, e2) => let @@ -301,6 +313,15 @@ | ENextval _ => unsupported "Nextval" | EUnurlify _ => unsupported "EUnurlify" | EJavaScript _ => unsupported "Nested JavaScript" + | ESignalReturn e => + let + val (e, st) = jsE inner (e, st) + in + (strcat [(*str "sreturn(",*) + e(*, + str ")"*)], + st) + end end in jsE @@ -309,14 +330,25 @@ val decl : state -> decl -> decl * state = U.Decl.foldMapB {typ = fn x => x, exp = fn (env, e, st) => - case e of - EJavaScript (EAbs (_, t, _, e), _) => - let - val (e, st) = jsExp true (t :: env) 0 (e, st) - in - (#1 e, st) - end - | _ => (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 uwr" ^ Int.toString (len + i) ^ ";")) + val (e, st) = jsExp m env 0 (e, st) + in + (#1 (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 + | _ => (e, st) + end, decl = fn (_, e, st) => (e, st), bind = fn (env, U.Decl.RelE (_, t)) => t :: env | (env, _) => env}
--- a/src/mono.sml Sat Dec 20 14:19:21 2008 -0500 +++ b/src/mono.sml Sat Dec 20 15:46:48 2008 -0500 @@ -37,6 +37,7 @@ | TDatatype of int * (datatype_kind * (string * int * typ option) list) ref | TFfi of string * string | TOption of typ + | TSignal of typ withtype typ = typ' located @@ -55,6 +56,11 @@ withtype pat = pat' located +datatype javascript_mode = + Attribute + | Script + | File + datatype exp' = EPrim of Prim.t | ERel of int @@ -96,8 +102,9 @@ | EUnurlify of exp * typ - | EJavaScript of exp + | EJavaScript of javascript_mode * exp + | ESignalReturn of exp withtype exp = exp' located
--- a/src/mono_print.sml Sat Dec 20 14:19:21 2008 -0500 +++ b/src/mono_print.sml Sat Dec 20 15:46:48 2008 -0500 @@ -65,6 +65,9 @@ | TOption t => box [string "option(", p_typ env t, string ")"] + | TSignal t => box [string "signal(", + p_typ env t, + string ")"] and p_typ env = p_typ' false env @@ -275,9 +278,13 @@ | EUnurlify (e, _) => box [string "unurlify(", p_exp env e, string ")"] - | EJavaScript e => box [string "JavaScript(", - p_exp env e, - string ")"] + | EJavaScript (_, e) => box [string "JavaScript(", + p_exp env e, + string ")"] + + | ESignalReturn e => box [string "Return(", + p_exp env e, + string ")"] and p_exp env = p_exp' false env
--- a/src/mono_reduce.sml Sat Dec 20 14:19:21 2008 -0500 +++ b/src/mono_reduce.sml Sat Dec 20 15:46:48 2008 -0500 @@ -75,7 +75,8 @@ | 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 val liftExpInExp = Monoize.liftExpInExp @@ -330,7 +331,8 @@ | 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 fun exp env e = @@ -421,6 +423,7 @@ fun trySub () = case t of (TFfi ("Basis", "string"), _) => doSub () + | (TSignal _, _) => e | _ => case e' of (ECase _, _) => e
--- a/src/mono_util.sml Sat Dec 20 14:19:21 2008 -0500 +++ b/src/mono_util.sml Sat Dec 20 15:46:48 2008 -0500 @@ -51,6 +51,7 @@ | (TDatatype (n1, _), TDatatype (n2, _)) => Int.compare (n1, n2) | (TFfi (m1, x1), TFfi (m2, x2)) => join (String.compare (m1, m2), fn () => String.compare (x1, x2)) | (TOption t1, TOption t2) => compare (t1, t2) + | (TSignal t1, TSignal t2) => compare (t1, t2) | (TFun _, _) => LESS | (_, TFun _) => GREATER @@ -64,6 +65,9 @@ | (TFfi _, _) => LESS | (_, TFfi _) => GREATER + | (TOption _, _) => LESS + | (_, TOption _) => GREATER + and compareFields ((x1, t1), (x2, t2)) = join (String.compare (x1, x2), fn () => compare (t1, t2)) @@ -96,6 +100,10 @@ S.map2 (mft t, fn t' => (TOption t, loc)) + | TSignal t => + S.map2 (mft t, + fn t' => + (TSignal t, loc)) in mft end @@ -311,10 +319,14 @@ S.map2 (mft t, fn t' => (EUnurlify (e', t'), loc))) - | EJavaScript e => + | EJavaScript (m, e) => S.map2 (mfe ctx e, fn e' => - (EJavaScript e', loc)) + (EJavaScript (m, e'), loc)) + | ESignalReturn e => + S.map2 (mfe ctx e, + fn e' => + (ESignalReturn e', loc)) in mfe end
--- a/src/monoize.sml Sat Dec 20 14:19:21 2008 -0500 +++ b/src/monoize.sml Sat Dec 20 15:46:48 2008 -0500 @@ -135,6 +135,8 @@ (L'.TFun ((L'.TRecord [], loc), mt env dtmap t), loc) | L.CApp ((L.CFfi ("Basis", "source"), _), t) => (L'.TFfi ("Basis", "int"), loc) + | L.CApp ((L.CFfi ("Basis", "signal"), _), t) => + (L'.TSignal (mt env dtmap t), loc) | L.CApp ((L.CFfi ("Basis", "http_cookie"), _), _) => (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CFfi ("Basis", "sql_table"), _), _) => @@ -978,6 +980,16 @@ fm) end + | L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "return"), _), _), _), t), _), + (L.EFfi ("Basis", "signal_monad"), _)) => + let + val t = monoType env t + in + ((L'.EAbs ("x", t, (L'.TSignal t, loc), + (L'.ESignalReturn (L'.ERel 0, loc), loc)), loc), + fm) + end + | L.ECApp ((L.EFfi ("Basis", "getCookie"), _), t) => let val s = (L'.TFfi ("Basis", "string"), loc) @@ -1752,7 +1764,7 @@ (L'.EStrcat ( (L'.EPrim (Prim.String s'), loc), (L'.EStrcat ( - (L'.EJavaScript e, loc), + (L'.EJavaScript (L'.Attribute, e), loc), (L'.EPrim (Prim.String "'"), loc)), loc)), loc)), loc), fm) @@ -1833,6 +1845,25 @@ case tag of "body" => normal ("body", NONE, SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc)) + + | "dyn" => + (case #1 attrs of + (*L'.ERecord [("Signal", (L'.ESignalReturn e, _), _)] => (e, fm) + | 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\">"), loc), + (L'.EStrcat ((L'.EJavaScript (L'.Script, + (L'.ELet ("signal", (L'.TSignal + (L'.TFfi ("Basis", "string"), loc), + loc), + e, + (L'.EWrite (L'.ERel 0, loc), loc)), loc)), loc), + (L'.EPrim (Prim.String "</script>"), loc)), loc)), loc), + fm) + | _ => raise Fail "Monoize: Bad dyn attributes") | "submit" => normal ("input type=\"submit\"", NONE, NONE)