Mercurial > urweb
changeset 695:500e93aa436f
sleep and better Scriptcheck
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sat, 04 Apr 2009 15:56:47 -0400 |
| parents | 7ea0df9e56b6 |
| children | 79a49c509007 |
| files | include/urweb.h lib/ur/basis.urs src/c/urweb.c src/cjrize.sml src/jscomp.sml src/mono.sml src/mono_print.sml src/mono_reduce.sml src/mono_util.sml src/monoize.sml src/scriptcheck.sml src/urweb.grm tests/sleep.ur tests/sleep.urp |
| diffstat | 14 files changed, 105 insertions(+), 24 deletions(-) [+] |
line wrap: on
line diff
--- a/include/urweb.h Sat Apr 04 14:55:36 2009 -0400 +++ b/include/urweb.h Sat Apr 04 15:56:47 2009 -0400 @@ -52,6 +52,8 @@ const char *uw_Basis_get_settings(uw_context, uw_unit); const char *uw_Basis_get_script(uw_context, uw_unit); +uw_Basis_string uw_Basis_maybe_onload(uw_context, uw_Basis_string); + void uw_set_needs_push(uw_context, int); char *uw_Basis_htmlifyInt(uw_context, uw_Basis_int);
--- a/lib/ur/basis.urs Sat Apr 04 14:55:36 2009 -0400 +++ b/lib/ur/basis.urs Sat Apr 04 15:56:47 2009 -0400 @@ -106,6 +106,7 @@ val alert : string -> transaction unit val spawn : transaction unit -> transaction unit +val sleep : int -> transaction unit (** Channels *)
--- a/src/c/urweb.c Sat Apr 04 14:55:36 2009 -0400 +++ b/src/c/urweb.c Sat Apr 04 15:56:47 2009 -0400 @@ -693,14 +693,24 @@ if (ctx->script_header[0] == 0) return ""; else { - char *r = uw_malloc(ctx, strlen(ctx->script_header) + 18 + buf_used(&ctx->script)); - sprintf(r, "%s<script>%s</script>", + char *r = uw_malloc(ctx, strlen(ctx->script_header) + 42 + buf_used(&ctx->script)); + sprintf(r, "%s<script type=\"text/javascript\">%s</script>", ctx->script_header, ctx->script.start); return r; } } +uw_Basis_string uw_Basis_maybe_onload(uw_context ctx, uw_Basis_string s) { + if (s[0] == 0) + return ""; + else { + char *r = uw_malloc(ctx, 11 + strlen(s)); + sprintf(r, " onload='%s'", s); + return r; + } +} + const char *uw_Basis_get_settings(uw_context ctx, uw_unit u) { if (ctx->client == NULL) return "";
--- a/src/cjrize.sml Sat Apr 04 14:55:36 2009 -0400 +++ b/src/cjrize.sml Sat Apr 04 15:56:47 2009 -0400 @@ -431,6 +431,7 @@ | L.EServerCall _ => raise Fail "Cjrize EServerCall" | L.ERecv _ => raise Fail "Cjrize ERecv" + | L.ESleep _ => raise Fail "Cjrize ESleep" fun cifyDecl ((d, loc), sm) = case d of
--- a/src/jscomp.sml Sat Apr 04 14:55:36 2009 -0400 +++ b/src/jscomp.sml Sat Apr 04 15:56:47 2009 -0400 @@ -110,6 +110,7 @@ | ESignalSource e => varDepth e | EServerCall (e, ek, _) => Int.max (varDepth e, varDepth ek) | ERecv (e, ek, _) => Int.max (varDepth e, varDepth ek) + | ESleep (e, ek) => Int.max (varDepth e, varDepth ek) fun closedUpto d = let @@ -152,6 +153,7 @@ | ESignalSource e => cu inner e | EServerCall (e, ek, _) => cu inner e andalso cu inner ek | ERecv (e, ek, _) => cu inner e andalso cu inner ek + | ESleep (e, ek) => cu inner e andalso cu inner ek in cu 0 end @@ -973,6 +975,19 @@ str ")"], st) end + + | ESleep (e, ek) => + let + val (e, st) = jsE inner (e, st) + val (ek, st) = jsE inner (ek, st) + in + (strcat [str "window.setTimeout(", + ek, + str ", ", + e, + str ")"], + st) + end end in jsE
--- a/src/mono.sml Sat Apr 04 14:55:36 2009 -0400 +++ b/src/mono.sml Sat Apr 04 15:56:47 2009 -0400 @@ -111,6 +111,7 @@ | EServerCall of exp * exp * typ | ERecv of exp * exp * typ + | ESleep of exp * exp withtype exp = exp' located
--- a/src/mono_print.sml Sat Apr 04 14:55:36 2009 -0400 +++ b/src/mono_print.sml Sat Apr 04 15:56:47 2009 -0400 @@ -318,6 +318,11 @@ string ")[", p_exp env e, string "]"] + | ESleep (n, e) => box [string "Sleep(", + p_exp env n, + string ")[", + p_exp env e, + string "]"] and p_exp env = p_exp' false env
--- a/src/mono_reduce.sml Sat Apr 04 14:55:36 2009 -0400 +++ b/src/mono_reduce.sml Sat Apr 04 15:56:47 2009 -0400 @@ -88,6 +88,7 @@ | ESignalSource e => impure e | EServerCall _ => true | ERecv _ => true + | ESleep _ => true val liftExpInExp = Monoize.liftExpInExp @@ -361,6 +362,7 @@ | EServerCall (e, ek, _) => summarize d e @ summarize d ek @ [Unsure] | ERecv (e, ek, _) => summarize d e @ summarize d ek @ [Unsure] + | ESleep (e, ek) => summarize d e @ summarize d ek @ [Unsure] in (*Print.prefaces "Summarize" [("e", MonoPrint.p_exp MonoEnv.empty (e, ErrorMsg.dummySpan)),
--- a/src/mono_util.sml Sat Apr 04 14:55:36 2009 -0400 +++ b/src/mono_util.sml Sat Apr 04 15:56:47 2009 -0400 @@ -360,12 +360,18 @@ (EServerCall (s', ek', t'), loc)))) | ERecv (s, ek, t) => S.bind2 (mfe ctx s, - fn s' => - S.bind2 (mfe ctx ek, - fn ek' => - S.map2 (mft t, - fn t' => - (ERecv (s', ek', t'), loc)))) + fn s' => + S.bind2 (mfe ctx ek, + fn ek' => + S.map2 (mft t, + fn t' => + (ERecv (s', ek', t'), loc)))) + | ESleep (s, ek) => + S.bind2 (mfe ctx s, + fn s' => + S.map2 (mfe ctx ek, + fn ek' => + (ESleep (s', ek'), loc))) in mfe end
--- a/src/monoize.sml Sat Apr 04 14:55:36 2009 -0400 +++ b/src/monoize.sml Sat Apr 04 15:56:47 2009 -0400 @@ -1002,6 +1002,23 @@ t1), loc)), loc)), loc), fm) end + | L.EApp ((L.EApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "bind"), _), _), _), _), _), t2), _), + (L.EFfi ("Basis", "transaction_monad"), _)), _), + (L.EAbs (_, _, _, + (L.EFfiApp ("Basis", "sleep", [n]), _)), loc)) => + let + val t2 = monoType env t2 + val un = (L'.TRecord [], loc) + val mt2 = (L'.TFun (un, t2), loc) + val (n, fm) = monoExp (env, st, fm) n + in + ((L'.EAbs ("m2", (L'.TFun (un, mt2), loc), (L'.TFun (un, un), loc), + (L'.EAbs ("_", un, un, + (L'.ESleep (n, (L'.EApp ((L'.ERel 1, loc), + (L'.ERecord [], loc)), loc)), + loc)), loc)), loc), + fm) + end | L.ECApp ((L.EFfi ("Basis", "source"), _), t) => let @@ -1952,12 +1969,13 @@ NONE => tagStart | SOME extra => (L'.EStrcat (tagStart, extra), loc) + val xml = case extraInner of + NONE => xml + | SOME ei => (L.EFfiApp ("Basis", "strcat", [ei, xml]), loc) + fun normal () = let val (xml, fm) = monoExp (env, st, fm) xml - val xml = case extraInner of - NONE => xml - | SOME ei => (L'.EStrcat (ei, xml), loc) in ((L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc), (L'.EStrcat (xml, @@ -2012,13 +2030,12 @@ end in normal ("body", - SOME (L'.EStrcat ((L'.EPrim (Prim.String " onload='"), loc), - (L'.EStrcat ((L'.EFfiApp ("Basis", "get_settings", - [(L'.ERecord [], loc)]), loc), - (L'.EStrcat (onload, - (L'.EPrim (Prim.String "'"), - loc)), loc)), loc)), loc), - SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc)) + SOME (L'.EFfiApp ("Basis", "maybe_onload", + [(L'.EStrcat ((L'.EFfiApp ("Basis", "get_settings", + [(L'.ERecord [], loc)]), loc), + onload), loc)]), + loc), + SOME (L.EFfiApp ("Basis", "get_script", [(L.ERecord [], loc)]), loc)) end | "dyn" =>
--- a/src/scriptcheck.sml Sat Apr 04 14:55:36 2009 -0400 +++ b/src/scriptcheck.sml Sat Apr 04 15:56:47 2009 -0400 @@ -45,8 +45,7 @@ "self"]) val scriptWords = ["<script", - " onclick=", - " onload="] + " onclick='"] val pushWords = ["rv("] @@ -59,8 +58,15 @@ not (Substring.isEmpty suffix) end - fun hasClient {basis, words} csids = + fun hasClient {basis, words, onload} csids = let + fun realOnload ss = + case ss of + [] => false + | (EFfiApp ("Basis", "get_settings", _), _) :: ss => realOnload ss + | (EPrim (Prim.String s), _) :: ss => not (String.isPrefix "'" s) + | _ => true + fun hasClient e = case #1 e of EPrim (Prim.String s) => List.exists (fn n => inString {needle = n, haystack = s}) words @@ -73,6 +79,11 @@ | ESome (_, e) => hasClient e | EFfi ("Basis", x) => SS.member (basis, x) | EFfi _ => false + | EFfiApp ("Basis", "strcat", all as ((EPrim (Prim.String s1), _) :: ss)) => + if onload andalso String.isSuffix " onload='" s1 then + realOnload ss orelse List.exists hasClient all + else + List.exists hasClient all | EFfiApp ("Basis", x, es) => SS.member (basis, x) orelse List.exists hasClient es | EFfiApp (_, _, es) => List.exists hasClient es @@ -97,8 +108,8 @@ fun decl ((d, _), (pull_ids, push_ids)) = let - val hasClientPull = hasClient {basis = pullBasis, words = scriptWords} pull_ids - val hasClientPush = hasClient {basis = pushBasis, words = pushWords} push_ids + val hasClientPull = hasClient {basis = pullBasis, words = scriptWords, onload = true} pull_ids + val hasClientPush = hasClient {basis = pushBasis, words = pushWords, onload = false} push_ids in case d of DVal (_, n, _, e) => (if hasClientPull e then
--- a/src/urweb.grm Sat Apr 04 14:55:36 2009 -0400 +++ b/src/urweb.grm Sat Apr 04 15:56:47 2009 -0400 @@ -1,4 +1,4 @@ -(* Copyright (c) 2008, Adam Chlipala +(* Copyright (c) 2008-2009, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without