diff options
author | Adam Chlipala <adamc@hcoop.net> | 2009-04-04 15:56:47 -0400 |
---|---|---|
committer | Adam Chlipala <adamc@hcoop.net> | 2009-04-04 15:56:47 -0400 |
commit | b05b60f5cdaa0da92af54640f8a2db6e18a283ba (patch) | |
tree | 3464b0dbe1197e509f51d5f6181dda2804344e26 /src | |
parent | 221615de9d28d6fa768ef3ce28483ed90d2aab6c (diff) |
sleep and better Scriptcheck
Diffstat (limited to 'src')
-rw-r--r-- | src/c/urweb.c | 14 | ||||
-rw-r--r-- | src/cjrize.sml | 1 | ||||
-rw-r--r-- | src/jscomp.sml | 15 | ||||
-rw-r--r-- | src/mono.sml | 1 | ||||
-rw-r--r-- | src/mono_print.sml | 5 | ||||
-rw-r--r-- | src/mono_reduce.sml | 2 | ||||
-rw-r--r-- | src/mono_util.sml | 18 | ||||
-rw-r--r-- | src/monoize.sml | 37 | ||||
-rw-r--r-- | src/scriptcheck.sml | 21 | ||||
-rw-r--r-- | src/urweb.grm | 2 |
10 files changed, 92 insertions, 24 deletions
diff --git a/src/c/urweb.c b/src/c/urweb.c index 6f6f1fc8..476fb09b 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -693,14 +693,24 @@ const char *uw_Basis_get_script(uw_context ctx, uw_unit u) { 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 ""; diff --git a/src/cjrize.sml b/src/cjrize.sml index 998ae38e..5e4b647a 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -431,6 +431,7 @@ fun cifyExp (eAll as (e, loc), sm) = | 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 diff --git a/src/jscomp.sml b/src/jscomp.sml index c7577d0c..9cefc60f 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -110,6 +110,7 @@ fun varDepth (e, _) = | 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 @@ fun closedUpto d = | 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 @@ fun process file = 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 diff --git a/src/mono.sml b/src/mono.sml index f4bbc868..02afb2c0 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -111,6 +111,7 @@ datatype exp' = | EServerCall of exp * exp * typ | ERecv of exp * exp * typ + | ESleep of exp * exp withtype exp = exp' located diff --git a/src/mono_print.sml b/src/mono_print.sml index b30fa4e8..a8ece085 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -318,6 +318,11 @@ fun p_exp' par env (e, _) = 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 diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 08d5ad6d..2f60b26e 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -88,6 +88,7 @@ fun impure (e, _) = | ESignalSource e => impure e | EServerCall _ => true | ERecv _ => true + | ESleep _ => true val liftExpInExp = Monoize.liftExpInExp @@ -361,6 +362,7 @@ fun reduce file = | 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)), diff --git a/src/mono_util.sml b/src/mono_util.sml index bbc9c7e7..9455435c 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -360,12 +360,18 @@ fun mapfoldB {typ = fc, exp = fe, bind} = (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 diff --git a/src/monoize.sml b/src/monoize.sml index ea2ce751..d974e373 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1002,6 +1002,23 @@ fun monoExp (env, st, fm) (all as (e, loc)) = 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 @@ fun monoExp (env, st, fm) (all as (e, loc)) = 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 @@ fun monoExp (env, st, fm) (all as (e, loc)) = 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" => diff --git a/src/scriptcheck.sml b/src/scriptcheck.sml index 34bf2337..a3928921 100644 --- a/src/scriptcheck.sml +++ b/src/scriptcheck.sml @@ -45,8 +45,7 @@ val pushBasis = SS.addList (SS.empty, "self"]) val scriptWords = ["<script", - " onclick=", - " onload="] + " onclick='"] val pushWords = ["rv("] @@ -59,8 +58,15 @@ fun classify (ds, ps) = 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 @@ fun classify (ds, ps) = | 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 classify (ds, ps) = 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 diff --git a/src/urweb.grm b/src/urweb.grm index e6f0ddeb..98ba295a 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -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 |