# HG changeset patch
# User Adam Chlipala <adamc@hcoop.net>
# Date 1238875007 14400
# Node ID 500e93aa436f0dca48b7f9dab12ed20bec807309
# Parent  7ea0df9e56b6b342449a5f3022a044fad89aa7fc
sleep and better Scriptcheck

diff -r 7ea0df9e56b6 -r 500e93aa436f include/urweb.h
--- 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);
diff -r 7ea0df9e56b6 -r 500e93aa436f lib/ur/basis.urs
--- 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 *)
diff -r 7ea0df9e56b6 -r 500e93aa436f src/c/urweb.c
--- 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 "";
diff -r 7ea0df9e56b6 -r 500e93aa436f src/cjrize.sml
--- 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
diff -r 7ea0df9e56b6 -r 500e93aa436f src/jscomp.sml
--- 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
diff -r 7ea0df9e56b6 -r 500e93aa436f src/mono.sml
--- 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
 
diff -r 7ea0df9e56b6 -r 500e93aa436f src/mono_print.sml
--- 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
 
diff -r 7ea0df9e56b6 -r 500e93aa436f src/mono_reduce.sml
--- 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)),
diff -r 7ea0df9e56b6 -r 500e93aa436f src/mono_util.sml
--- 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
diff -r 7ea0df9e56b6 -r 500e93aa436f src/monoize.sml
--- 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" =>
diff -r 7ea0df9e56b6 -r 500e93aa436f src/scriptcheck.sml
--- 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
diff -r 7ea0df9e56b6 -r 500e93aa436f src/urweb.grm
--- 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
diff -r 7ea0df9e56b6 -r 500e93aa436f tests/sleep.ur
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/sleep.ur	Sat Apr 04 15:56:47 2009 -0400
@@ -0,0 +1,7 @@
+fun annoyer () =
+    alert "Hi!";
+    sleep 5000;
+    annoyer ()
+
+fun main () : transaction page = return <xml><body onload={annoyer ()}/></xml>
+
diff -r 7ea0df9e56b6 -r 500e93aa436f tests/sleep.urp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/sleep.urp	Sat Apr 04 15:56:47 2009 -0400
@@ -0,0 +1,3 @@
+debug
+
+sleep