Mercurial > urweb
changeset 579:0094e0242100
Propagated a source change into a dynamic document element
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Tue, 30 Dec 2008 15:53:04 -0500 |
| parents | 1e589a60b86f |
| children | bb8463c3b712 |
| files | jslib/urweb.js src/jscomp.sml src/mono_reduce.sml tests/reactive3.ur tests/reactive3.urp |
| diffstat | 5 files changed, 121 insertions(+), 88 deletions(-) [+] |
line wrap: on
line diff
--- a/jslib/urweb.js Tue Dec 30 11:33:31 2008 -0500 +++ b/jslib/urweb.js Tue Dec 30 15:53:04 2008 -0500 @@ -1,11 +1,18 @@ -function sc(v) { return {v : v} } +function callAll(ls) { + for (; ls; ls = ls.next) + ls.v(); +} -function ss(s) { return {v : s.v} } -function sr(v) { return {v : v} } -function sb(x,y) { return {v : y(x.v).v} } +function sc(v) { return {v : v, h : null} } +function sv(s, v) { s.v = v; callAll(s.h); } + +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 } }; }
--- a/src/jscomp.sml Tue Dec 30 11:33:31 2008 -0500 +++ b/src/jscomp.sml Tue Dec 30 15:53:04 2008 -0500 @@ -35,7 +35,8 @@ 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 @@ | [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 @@ 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 @@ 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 @@ 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 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),
--- a/src/mono_reduce.sml Tue Dec 30 11:33:31 2008 -0500 +++ b/src/mono_reduce.sml Tue Dec 30 15:53:04 2008 -0500 @@ -56,6 +56,7 @@ | 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 @@ 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 + 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 _ => [] + | 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 + | 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 + | 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 + | 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] + | 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 + | 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) + | 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]] + | 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 + | 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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/reactive3.ur Tue Dec 30 15:53:04 2008 -0500 @@ -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>