Mercurial > urweb
changeset 693:655bcc9b77e0
_Really_ implement embedded closure GC; extend Scriptcheck to figure out when client IDs must be assigned
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sat, 04 Apr 2009 14:03:39 -0400 |
| parents | 09df0c85f306 |
| children | 7ea0df9e56b6 |
| files | include/urweb.h lib/js/urweb.js src/c/urweb.c src/cjr.sml src/cjr_print.sml src/cjrize.sml src/jscomp.sml src/scriptcheck.sml |
| diffstat | 8 files changed, 100 insertions(+), 53 deletions(-) [+] |
line wrap: on
line diff
--- a/include/urweb.h Sat Apr 04 12:54:39 2009 -0400 +++ b/include/urweb.h Sat Apr 04 14:03:39 2009 -0400 @@ -52,6 +52,8 @@ const char *uw_Basis_get_settings(uw_context, uw_Basis_string); const char *uw_Basis_get_script(uw_context, uw_unit); +void uw_set_needs_push(uw_context, int); + char *uw_Basis_htmlifyInt(uw_context, uw_Basis_int); char *uw_Basis_htmlifyFloat(uw_context, uw_Basis_float); char *uw_Basis_htmlifyString(uw_context, uw_Basis_string);
--- a/lib/js/urweb.js Sat Apr 04 12:54:39 2009 -0400 +++ b/lib/js/urweb.js Sat Apr 04 14:03:39 2009 -0400 @@ -22,11 +22,19 @@ // Embedding closures in XML strings +function cs(f) { + return {closure: f}; +} + +function isWeird(v) { + return v.closure != null || v.cat1 != null; +} + function cat(s1, s2) { - if (s1.length && s2.length) + if (isWeird(s1) || isWeird(s2)) + return {cat1: s1, cat2: s2}; + else return s1 + s2; - else - return {_1: s1, _2: s2}; } var closures = []; @@ -42,12 +50,12 @@ } function flatten(tr) { - if (tr.length) + if (tr.cat1 != null) + return flatten(tr.cat1) + flatten(tr.cat2); + else if (tr.closure != null) + return "cr(" + newClosure(tr.closure) + ")"; + else return tr; - else if (tr._1) - return cs(tr._1) + cs(tr._2); - else - return "cr(" + newClosure(tr) + ")"; } function clearClosures() { @@ -157,7 +165,7 @@ ls.data.dyns = remove(span, ls.data.dyns); } - x.innerHTML = v; + x.innerHTML = flatten(v); runScripts(x); if (--dynDepth == 0) @@ -412,3 +420,7 @@ k(parse(msg))(null); } } + + +// App-specific code +
--- a/src/c/urweb.c Sat Apr 04 12:54:39 2009 -0400 +++ b/src/c/urweb.c Sat Apr 04 14:03:39 2009 -0400 @@ -300,6 +300,8 @@ const char *script_header, *url_prefix; + int needs_push; + size_t n_deltas, used_deltas; delta *deltas; @@ -333,6 +335,7 @@ ctx->script_header = ""; ctx->url_prefix = "/"; + ctx->needs_push = 0; ctx->error_message[0] = 0; @@ -476,7 +479,7 @@ } void uw_login(uw_context ctx) { - if (ctx->script_header[0]) { + if (ctx->needs_push) { char *id_s, *pass_s; if ((id_s = uw_Basis_requestHeader(ctx, "UrWeb-Client")) @@ -578,6 +581,10 @@ ctx->url_prefix = s; } +void uw_set_needs_push(uw_context ctx, int n) { + ctx->needs_push = n; +} + static void buf_check_ctx(uw_context ctx, buf *b, size_t extra, const char *desc) { if (b->back - b->front < extra) {
--- a/src/cjr.sml Sat Apr 04 12:54:39 2009 -0400 +++ b/src/cjr.sml Sat Apr 04 14:03:39 2009 -0400 @@ -115,7 +115,8 @@ datatype sidedness = ServerOnly - | ServerAndClient + | ServerAndPull + | ServerAndPullAndPush type file = decl list * (Core.export_kind * string * int * typ list * typ * sidedness) list
--- a/src/cjr_print.sml Sat Apr 04 12:54:39 2009 -0400 +++ b/src/cjr_print.sml Sat Apr 04 14:03:39 2009 -0400 @@ -2391,12 +2391,19 @@ newline, string "uw_set_script_header(ctx, \"", string (case side of - ServerAndClient => "<script src=\\\"" - ^ OS.Path.joinDirFile {dir = !Monoize.urlPrefix, - file = "app.js"} - ^ "\\\"></script>\\n" - | ServerOnly => ""), + ServerOnly => "" + | _ => "<script src=\\\"" + ^ OS.Path.joinDirFile {dir = !Monoize.urlPrefix, + file = "app.js"} + ^ "\\\"></script>\\n"), string "\");", + newline, + string "uw_set_needs_push(ctx, ", + string (case side of + ServerAndPullAndPush => "1" + | _ => "0"), + string ");", + newline, string "uw_set_url_prefix(ctx, \"", string (!Monoize.urlPrefix), string "\");",
--- a/src/cjrize.sml Sat Apr 04 12:54:39 2009 -0400 +++ b/src/cjrize.sml Sat Apr 04 14:03:39 2009 -0400 @@ -520,7 +520,7 @@ val (ts, sm) = ListUtil.foldlMap cifyTyp sm ts val (t, sm) = cifyTyp (t, sm) in - (NONE, SOME (ek, "/" ^ s, n, ts, t, L'.ServerAndClient), sm) + (NONE, SOME (ek, "/" ^ s, n, ts, t, L'.ServerAndPullAndPush), sm) end | L.DTable (s, xts) =>
--- a/src/jscomp.sml Sat Apr 04 12:54:39 2009 -0400 +++ b/src/jscomp.sml Sat Apr 04 14:03:39 2009 -0400 @@ -850,7 +850,7 @@ val (e1, st) = jsE inner (e1, st) val (e2, st) = jsE inner (e2, st) in - (strcat [str "(", e1, str "+", e2, str ")"], st) + (strcat [str "cat(", e1, str ",", e2, str ")"], st) end | EError (e, _) => @@ -891,9 +891,9 @@ | EJavaScript (Source _, _, SOME _) => (e, st) | EJavaScript (_, _, SOME e) => - (strcat [str "function(){return ", + (strcat [str "cs(function(){return ", e, - str "}"], + str "})"], st) | EClosure _ => unsupported "EClosure" @@ -905,9 +905,9 @@ let val (e, st) = jsE inner (e, st) in - (strcat [str "function(){return ", + (strcat [str "cs(function(){return ", e, - str "}"], + str "})"], st) end
--- a/src/scriptcheck.sml Sat Apr 04 12:54:39 2009 -0400 +++ b/src/scriptcheck.sml Sat Apr 04 14:03:39 2009 -0400 @@ -35,19 +35,21 @@ end) structure IS = IntBinarySet -val csBasis = SS.addList (SS.empty, - ["new_client_source", - "get_client_source", - "set_client_source", - "new_channel", - "subscribe", - "send", - "recv"]) +val pullBasis = SS.addList (SS.empty, + ["new_client_source", + "get_client_source", + "set_client_source"]) +val pushBasis = SS.addList (SS.empty, + ["new_channel", + "self"]) + val scriptWords = ["<script", " onclick=", " onload="] +val pushWords = ["rv("] + fun classify (ds, ps) = let fun inString {needle, haystack} = @@ -57,11 +59,11 @@ not (Substring.isEmpty suffix) end - fun hasClient csids = + fun hasClient {basis, words} csids = let fun hasClient e = case #1 e of - EPrim (Prim.String s) => List.exists (fn n => inString {needle = n, haystack = s}) scriptWords + EPrim (Prim.String s) => List.exists (fn n => inString {needle = n, haystack = s}) words | EPrim _ => false | ERel _ => false | ENamed n => IS.member (csids, n) @@ -69,9 +71,9 @@ | ECon (_, _, SOME e) => hasClient e | ENone _ => false | ESome (_, e) => hasClient e - | EFfi ("Basis", x) => SS.member (csBasis, x) + | EFfi ("Basis", x) => SS.member (basis, x) | EFfi _ => false - | EFfiApp ("Basis", x, es) => SS.member (csBasis, x) + | EFfiApp ("Basis", x, es) => SS.member (basis, x) orelse List.exists hasClient es | EFfiApp (_, _, es) => List.exists hasClient es | EApp (e, es) => hasClient e orelse List.exists hasClient es @@ -93,33 +95,49 @@ hasClient end - fun decl ((d, _), csids) = + fun decl ((d, _), (pull_ids, push_ids)) = let - val hasClient = hasClient csids + val hasClientPull = hasClient {basis = pullBasis, words = scriptWords} pull_ids + val hasClientPush = hasClient {basis = pushBasis, words = pushWords} push_ids in case d of - DVal (_, n, _, e) => if hasClient e then - IS.add (csids, n) - else - csids - | DFun (_, n, _, _, e) => if hasClient e then - IS.add (csids, n) - else - csids - | DFunRec xes => if List.exists (fn (_, _, _, _, e) => hasClient e) xes then - foldl (fn ((_, n, _, _, _), csids) => IS.add (csids, n)) - csids xes - else - csids - | _ => csids + DVal (_, n, _, e) => (if hasClientPull e then + IS.add (pull_ids, n) + else + pull_ids, + if hasClientPush e then + IS.add (push_ids, n) + else + push_ids) + | DFun (_, n, _, _, e) => (if hasClientPull e then + IS.add (pull_ids, n) + else + pull_ids, + if hasClientPush e then + IS.add (push_ids, n) + else + push_ids) + | DFunRec xes => (if List.exists (fn (_, _, _, _, e) => hasClientPull e) xes then + foldl (fn ((_, n, _, _, _), pull_ids) => IS.add (pull_ids, n)) + pull_ids xes + else + pull_ids, + if List.exists (fn (_, _, _, _, e) => hasClientPush e) xes then + foldl (fn ((_, n, _, _, _), push_ids) => IS.add (push_ids, n)) + push_ids xes + else + push_ids) + | _ => (pull_ids, push_ids) end - val csids = foldl decl IS.empty ds + val (pull_ids, push_ids) = foldl decl (IS.empty, IS.empty) ds val ps = map (fn (ek, x, n, ts, t, _) => (ek, x, n, ts, t, - if IS.member (csids, n) then - ServerAndClient + if IS.member (push_ids, n) then + ServerAndPullAndPush + else if IS.member (pull_ids, n) then + ServerAndPull else ServerOnly)) ps in