diff options
author | 2008-12-30 15:53:04 -0500 | |
---|---|---|
committer | 2008-12-30 15:53:04 -0500 | |
commit | be73a31fb83c7da398322f6e92e94a7297212b7c (patch) | |
tree | 78c801a52c645b6780e00ffc222f2d96e027f2b0 | |
parent | 8d3edc5aaa4617dd06623447cf9357067eadc072 (diff) |
Propagated a source change into a dynamic document element
-rw-r--r-- | jslib/urweb.js | 15 | ||||
-rw-r--r-- | src/jscomp.sml | 18 | ||||
-rw-r--r-- | src/mono_reduce.sml | 184 | ||||
-rw-r--r-- | tests/reactive3.ur | 7 | ||||
-rw-r--r-- | tests/reactive3.urp | 3 |
5 files changed, 130 insertions, 97 deletions
diff --git a/jslib/urweb.js b/jslib/urweb.js index eab67626..86c3808c 100644 --- a/jslib/urweb.js +++ b/jslib/urweb.js @@ -1,11 +1,18 @@ -function sc(v) { return {v : v} } +function callAll(ls) { + for (; ls; ls = ls.next) + ls.v(); +} + +function sc(v) { return {v : v, h : null} } +function sv(s, v) { s.v = v; callAll(s.h); } -function ss(s) { return {v : s.v} } -function sr(v) { return {v : v} } -function sb(x,y) { return {v : y(x.v).v} } +function ss(s) { return s } +function sr(v) { return {v : v, h : null} } +function sb(x,y) { return {v : y(x.v).v, h : null} } function dyn(s) { var x = document.createElement("span"); x.innerHTML = s.v; document.body.appendChild(x); + s.h = { n : s.h, v : function() { x.innerHTML = s.v } }; } diff --git a/src/jscomp.sml b/src/jscomp.sml index a4e3dd35..bc407db8 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -35,7 +35,8 @@ structure U = MonoUtil val funcs = [(("Basis", "alert"), "alert"), (("Basis", "htmlifyString"), "escape"), - (("Basis", "new_client_source"), "sc")] + (("Basis", "new_client_source"), "sc"), + (("Basis", "set_client_source"), "sv")] structure FM = BinaryMapFn(struct type ord_key = string * string @@ -94,7 +95,7 @@ fun strcat loc es = | [x] => x | x :: es' => (EStrcat (x, strcat loc es'), loc) -fun jsExp mode outer = +fun jsExp mode skip outer = let val len = length outer @@ -126,7 +127,10 @@ fun jsExp mode outer = 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") in case #1 e of @@ -154,7 +158,7 @@ fun jsExp mode outer = let val n = n - inner in - (quoteExp (List.nth (outer, n)) (ERel n, loc), st) + (quoteExp (List.nth (outer, n)) (ERel (n - skip), loc), st) end | ENamed _ => raise Fail "Named" | ECon (_, pc, NONE) => (patCon pc, st) @@ -403,7 +407,7 @@ val decl : state -> decl -> decl * state = U.Decl.foldMapB {typ = fn x => x, exp = fn (env, e, st) => let - fun doCode m env orig e = + fun doCode m skip env orig e = let val len = length env fun str s = (EPrim (Prim.String s), #2 e) @@ -411,14 +415,14 @@ val decl : state -> decl -> decl * state = val locals = List.tabulate (varDepth e, fn i => str ("var uwr" ^ Int.toString (len + i) ^ ";")) - val (e, st) = jsExp m env 0 (e, st) + val (e, st) = jsExp m skip env 0 (e, st) in (EJavaScript (m, orig, SOME (strcat (#2 e) (locals @ [e]))), st) end in case e of - EJavaScript (m, orig as (EAbs (_, t, _, e), _), _) => doCode m (t :: env) orig e - | EJavaScript (m, e, _) => doCode m env e e + EJavaScript (m, orig as (EAbs (_, t, _, e), _), _) => doCode m 1 (t :: env) orig e + | EJavaScript (m, e, _) => doCode m 0 env e e | _ => (e, st) end, decl = fn (_, e, st) => (e, st), diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index c96f97cf..0117623f 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -56,6 +56,7 @@ fun impure (e, _) = | EFfiApp ("Basis", "set_cookie", _) => true | EFfiApp ("Basis", "new_client_source", _) => true | EFfiApp ("Basis", "set_client_source", _) => true + | EFfiApp ("Basis", "alert", _) => true | EFfiApp _ => false | EApp ((EFfi _, _), _) => false | EApp _ => true @@ -253,92 +254,103 @@ fun reduce file = IM.empty file fun summarize d (e, _) = - case e of - EPrim _ => [] - | ERel n => if n = d then [UseRel] else [] - | ENamed _ => [] - | ECon (_, _, NONE) => [] - | ECon (_, _, SOME e) => summarize d e - | ENone _ => [] - | ESome (_, e) => summarize d e - | EFfi _ => [] - | EFfiApp ("Basis", "set_cookie", _) => [Unsure] - | EFfiApp ("Basis", "new_client_source", _) => [Unsure] - | EFfiApp ("Basis", "set_client_source", _) => [Unsure] - | EFfiApp (_, _, es) => List.concat (map (summarize d) es) - | EApp ((EFfi _, _), e) => summarize d e - | EApp _ => - let - fun unravel (e, ls) = - case e of - ENamed n => - let - val ls = rev ls - in - case IM.find (absCounts, n) of - NONE => [Unsure] - | SOME len => - if length ls < len then - ls - else - [Unsure] - end - | ERel n => List.revAppend (ls, - if n = d then - [UseRel, Unsure] - else - [Unsure]) - | EApp (f, x) => - unravel (#1 f, summarize d x @ ls) - | _ => [Unsure] - in - unravel (e, []) - end - - | EAbs _ => [] - - | EUnop (_, e) => summarize d e - | EBinop (_, e1, e2) => summarize d e1 @ summarize d e2 - - | ERecord xets => List.concat (map (summarize d o #2) xets) - | EField (e, _) => summarize d e - - | ECase (e, pes, _) => - let - val lss = map (fn (p, e) => summarize (d + patBinds p) e) pes - in - case lss of - [] => raise Fail "Empty pattern match" - | ls :: lss => - if List.all (fn ls' => ls' = ls) lss then - summarize d e @ ls - else - [Unsure] - end - | EStrcat (e1, e2) => summarize d e1 @ summarize d e2 - - | EError (e, _) => summarize d e @ [Unsure] - - | EWrite e => summarize d e @ [WritePage] - - | ESeq (e1, e2) => summarize d e1 @ summarize d e2 - | ELet (_, _, e1, e2) => summarize d e1 @ summarize (d + 1) e2 - - | EClosure (_, es) => List.concat (map (summarize d) es) - - | EQuery {query, body, initial, ...} => - List.concat [summarize d query, - summarize (d + 2) body, - summarize d initial, - [ReadDb]] - - | EDml e => summarize d e @ [WriteDb] - | ENextval e => summarize d e @ [WriteDb] - | EUnurlify (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 + let + val s = + case e of + EPrim _ => [] + | ERel n => if n = d then [UseRel] else [] + | ENamed _ => [] + | ECon (_, _, NONE) => [] + | ECon (_, _, SOME e) => summarize d e + | ENone _ => [] + | ESome (_, e) => summarize d e + | EFfi _ => [] + | EFfiApp ("Basis", "set_cookie", es) => List.concat (map (summarize d) es) @ [Unsure] + | EFfiApp ("Basis", "new_client_source", es) => List.concat (map (summarize d) es) @ [Unsure] + | EFfiApp ("Basis", "set_client_source", es) => List.concat (map (summarize d) es) @ [Unsure] + | EFfiApp ("Basis", "alert", es) => List.concat (map (summarize d) es) @ [Unsure] + | EFfiApp (_, _, es) => List.concat (map (summarize d) es) + | EApp ((EFfi _, _), e) => summarize d e + | EApp _ => + let + fun unravel (e, ls) = + case e of + ENamed n => + let + val ls = rev ls + in + case IM.find (absCounts, n) of + NONE => [Unsure] + | SOME len => + if length ls < len then + ls + else + [Unsure] + end + | ERel n => List.revAppend (ls, + if n = d then + [UseRel, Unsure] + else + [Unsure]) + | EApp (f, x) => + unravel (#1 f, summarize d x @ ls) + | _ => [Unsure] + in + unravel (e, []) + end + + | EAbs (_, _, _, e) => List.filter (fn UseRel => true + | _ => false) (summarize (d + 1) e) + + | EUnop (_, e) => summarize d e + | EBinop (_, e1, e2) => summarize d e1 @ summarize d e2 + + | ERecord xets => List.concat (map (summarize d o #2) xets) + | EField (e, _) => summarize d e + + | ECase (e, pes, _) => + let + val lss = map (fn (p, e) => summarize (d + patBinds p) e) pes + in + case lss of + [] => raise Fail "Empty pattern match" + | ls :: lss => + if List.all (fn ls' => ls' = ls) lss then + summarize d e @ ls + else + [Unsure] + end + | EStrcat (e1, e2) => summarize d e1 @ summarize d e2 + + | EError (e, _) => summarize d e @ [Unsure] + + | EWrite e => summarize d e @ [WritePage] + + | ESeq (e1, e2) => summarize d e1 @ summarize d e2 + | ELet (_, _, e1, e2) => summarize d e1 @ summarize (d + 1) e2 + + | EClosure (_, es) => List.concat (map (summarize d) es) + + | EQuery {query, body, initial, ...} => + List.concat [summarize d query, + summarize (d + 2) body, + summarize d initial, + [ReadDb]] + + | EDml e => summarize d e @ [WriteDb] + | ENextval e => summarize d e @ [WriteDb] + | EUnurlify (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 + in + (*Print.prefaces "Summarize" + [("e", MonoPrint.p_exp MonoEnv.empty (e, ErrorMsg.dummySpan)), + ("d", Print.PD.string (Int.toString d)), + ("s", p_events s)];*) + s + end fun exp env e = let diff --git a/tests/reactive3.ur b/tests/reactive3.ur new file mode 100644 index 00000000..c12455c5 --- /dev/null +++ b/tests/reactive3.ur @@ -0,0 +1,7 @@ +fun main () : transaction page = + x <- source <xml>TEST</xml>; + return <xml><body> + <dyn signal={signal x}/> + <br/> + <a onclick={alert "Changing...."; set x <xml>CHANGEUP</xml>}>Oh My</a> + </body></xml> diff --git a/tests/reactive3.urp b/tests/reactive3.urp new file mode 100644 index 00000000..8a95bc84 --- /dev/null +++ b/tests/reactive3.urp @@ -0,0 +1,3 @@ +debug + +reactive3 |