summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--include/urweb.h2
-rw-r--r--lib/ur/basis.urs1
-rw-r--r--src/c/urweb.c14
-rw-r--r--src/cjrize.sml1
-rw-r--r--src/jscomp.sml15
-rw-r--r--src/mono.sml1
-rw-r--r--src/mono_print.sml5
-rw-r--r--src/mono_reduce.sml2
-rw-r--r--src/mono_util.sml18
-rw-r--r--src/monoize.sml37
-rw-r--r--src/scriptcheck.sml21
-rw-r--r--src/urweb.grm2
-rw-r--r--tests/sleep.ur7
-rw-r--r--tests/sleep.urp3
14 files changed, 105 insertions, 24 deletions
diff --git a/include/urweb.h b/include/urweb.h
index 4e0992fd..759fc5ac 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -52,6 +52,8 @@ void uw_set_script_header(uw_context, const char*);
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);
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 19a7a9f1..0d5d3d71 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -106,6 +106,7 @@ val setCookie : t ::: Type -> http_cookie t -> t -> transaction unit
val alert : string -> transaction unit
val spawn : transaction unit -> transaction unit
+val sleep : int -> transaction unit
(** Channels *)
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
diff --git a/tests/sleep.ur b/tests/sleep.ur
new file mode 100644
index 00000000..132479e5
--- /dev/null
+++ b/tests/sleep.ur
@@ -0,0 +1,7 @@
+fun annoyer () =
+ alert "Hi!";
+ sleep 5000;
+ annoyer ()
+
+fun main () : transaction page = return <xml><body onload={annoyer ()}/></xml>
+
diff --git a/tests/sleep.urp b/tests/sleep.urp
new file mode 100644
index 00000000..f6eaf9fe
--- /dev/null
+++ b/tests/sleep.urp
@@ -0,0 +1,3 @@
+debug
+
+sleep
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-09 13:33:35 +0000