Trivial use of a source

8 files changed, 109 insertions, 43 deletions

diff --git a/src/c/urweb.c b/src/c/urweb.c
index 64cdb81e..11b99f4c 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -387,12 +387,84 @@ char *uw_Basis_get_script(uw_context ctx, uw_unit u) {
   }
 }
 
-int uw_Basis_new_client_source(uw_context ctx, uw_unit u) {
+uw_Basis_string uw_Basis_jsifyString(uw_context ctx, uw_Basis_string s) {
+  char *r, *s2;
+
+  uw_check_heap(ctx, strlen(s) * 4 + 2);
+
+  r = s2 = ctx->heap_front;
+  *s2++ = '"';
+
+  for (; *s; s++) {
+    char c = *s;
+
+    switch (c) {
+    case '"':
+      strcpy(s2, "\\\"");
+      s2 += 2;
+      break;
+    case '\\':
+      strcpy(s2, "\\\\");
+      s2 += 2;
+      break;
+    default:
+      if (isprint(c))
+        *s2++ = c;
+      else {
+        sprintf(s2, "\\%3o", c);
+        s2 += 4;
+      }
+    }
+  }
+
+  strcpy(s2, "\"");
+  ctx->heap_front = s2 + 1;
+  return r;
+}
+
+uw_Basis_string uw_Basis_jsifyString_ws(uw_context ctx, uw_Basis_string s) {
+  char *r, *s2;
+
+  uw_check_script(ctx, strlen(s) * 4 + 2);
+
+  r = s2 = ctx->script_front;
+  *s2++ = '"';
+
+  for (; *s; s++) {
+    char c = *s;
+
+    switch (c) {
+    case '"':
+      strcpy(s2, "\\\"");
+      s2 += 2;
+      break;
+    case '\\':
+      strcpy(s2, "\\\\");
+      s2 += 2;
+      break;
+    default:
+      if (isprint(c))
+        *s2++ = c;
+      else {
+        sprintf(s2, "\\%3o", c);
+        s2 += 4;
+      }
+    }
+  }
+
+  strcpy(s2, "\"");
+  ctx->script_front = s2 + 1;
+  return r;
+}
+
+int uw_Basis_new_client_source(uw_context ctx, uw_Basis_string s) {
   size_t len;
 
   uw_check_script(ctx, 8 + INTS_MAX);
-  sprintf(ctx->script_front, "var e%d=0\n%n", ctx->source_count, &len);
+  sprintf(ctx->script_front, "var s%d=sc(%n", ctx->source_count, &len);
   ctx->script_front += len;
+  uw_Basis_jsifyString_ws(ctx, s);
+  uw_write_script(ctx, ");");
 
   return ctx->source_count++;
 }
@@ -1056,41 +1128,6 @@ char *uw_Basis_ensqlBool(uw_Basis_bool b) {
     return (char *)&true;
 }
 
-uw_Basis_string uw_Basis_jsifyString(uw_context ctx, uw_Basis_string s) {
-  char *r, *s2;
-
-  uw_check_heap(ctx, strlen(s) * 4 + 2);
-
-  r = s2 = ctx->heap_front;
-  *s2++ = '"';
-
-  for (; *s; s++) {
-    char c = *s;
-
-    switch (c) {
-    case '"':
-      strcpy(s2, "\\\"");
-      s2 += 2;
-      break;
-    case '\\':
-      strcpy(s2, "\\\\");
-      s2 += 2;
-      break;
-    default:
-      if (isprint(c))
-        *s2++ = c;
-      else {
-        sprintf(s2, "\\%3o", c);
-        s2 += 4;
-      }
-    }
-  }
-
-  strcpy(s2, "\"");
-  ctx->heap_front = s2 + 1;
-  return r;
-}
-
 uw_Basis_string uw_Basis_intToString(uw_context ctx, uw_Basis_int n) {
   int len;
   char *r;
diff --git a/src/cjrize.sml b/src/cjrize.sml
index a46c725e..a9c51826 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -424,6 +424,7 @@ fun cifyExp (eAll as (e, loc), sm) =
       | L.EJavaScript _ => raise Fail "Cjrize: EJavaScript remains"
       | L.ESignalReturn _ => raise Fail "Cjrize: ESignalReturn remains"
       | L.ESignalBind _ => raise Fail "Cjrize: ESignalBind remains"
+      | L.ESignalSource _ => raise Fail "Cjrize: ESignalSource remains"
 
 fun cifyDecl ((d, loc), sm) =
     case d of
diff --git a/src/jscomp.sml b/src/jscomp.sml
index c38056e8..f7ef6927 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -34,7 +34,8 @@ structure E = MonoEnv
 structure U = MonoUtil
 
 val funcs = [(("Basis", "alert"), "alert"),
-             (("Basis", "htmlifyString"), "escape")]
+             (("Basis", "htmlifyString"), "escape"),
+             (("Basis", "new_client_source"), "sc")]
 
 structure FM = BinaryMapFn(struct
                            type ord_key = string * string
@@ -85,6 +86,7 @@ fun varDepth (e, _) =
       | EJavaScript _ => 0
       | ESignalReturn e => varDepth e
       | ESignalBind (e1, e2) => Int.max (varDepth e1, varDepth e2)
+      | ESignalSource e => varDepth e
 
 fun strcat loc es =
     case es of
@@ -168,7 +170,7 @@ fun jsExp mode outer =
                   | EFfi k =>
                     let
                         val name = case ffi k of
-                                       NONE => (EM.errorAt loc "Unsupported FFI identifier in JavaScript";
+                                       NONE => (EM.errorAt loc ("Unsupported FFI identifier " ^ #2 k ^ " in JavaScript");
                                                 "ERROR")
                                      | SOME s => s
                     in
@@ -177,7 +179,7 @@ fun jsExp mode outer =
                   | EFfiApp (m, x, args) =>
                     let
                         val name = case ffi (m, x) of
-                                       NONE => (EM.errorAt loc "Unsupported FFI function in JavaScript";
+                                       NONE => (EM.errorAt loc ("Unsupported FFI function " ^ x ^ " in JavaScript");
                                                 "ERROR")
                                      | SOME s => s
                     in
@@ -366,6 +368,15 @@ fun jsExp mode outer =
                                  str ")"],
                          st)
                     end
+                  | ESignalSource e =>
+                    let
+                        val (e, st) = jsE inner (e, st)
+                    in
+                        (strcat [str "ss(",
+                                 e,
+                                 str ")"],
+                         st)
+                    end
             end
     in
         jsE
diff --git a/src/mono.sml b/src/mono.sml
index 54b77550..ae9a06c7 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -106,6 +106,7 @@ datatype exp' =
 
        | ESignalReturn of exp
        | ESignalBind of exp * exp
+       | ESignalSource of exp
 
 withtype exp = exp' located
 
diff --git a/src/mono_print.sml b/src/mono_print.sml
index 608fe269..b3c0a568 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -285,12 +285,15 @@ fun p_exp' par env (e, _) =
       | ESignalReturn e => box [string "Return(",
                                 p_exp env e,
                                 string ")"]
-      | ESignalBind (e1, e2) => box [string "Return(",
+      | ESignalBind (e1, e2) => box [string "Bind(",
                                      p_exp env e1,
                                      string ",",
                                      space,
                                      p_exp env e2,
                                      string ")"]
+      | ESignalSource e => box [string "Source(",
+                                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 841e034e..a6777db5 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -78,6 +78,7 @@ fun impure (e, _) =
       | EJavaScript (_, e) => impure e
       | ESignalReturn e => impure e
       | ESignalBind (e1, e2) => impure e1 orelse impure e2
+      | ESignalSource e => impure e
 
 
 val liftExpInExp = Monoize.liftExpInExp
@@ -335,7 +336,7 @@ fun reduce file =
               | EJavaScript (_, e) => summarize d e
               | ESignalReturn e => summarize d e
               | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2
-
+              | ESignalSource e => summarize d e
 
         fun exp env e =
             let
diff --git a/src/mono_util.sml b/src/mono_util.sml
index a85443d7..b14e3ac9 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -334,6 +334,10 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
                          S.map2 (mfe ctx e2,
                               fn e2' =>
                                  (ESignalBind (e1', e2'), loc)))
+              | ESignalSource e =>
+                S.map2 (mfe ctx e,
+                     fn e' =>
+                        (ESignalSource e', loc))
     in
         mfe
     end
diff --git a/src/monoize.sml b/src/monoize.sml
index 30bd5daa..d3d20e7c 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -975,7 +975,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
             in
                 ((L'.EAbs ("x", t, (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "int"), loc)), loc),
                            (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "int"), loc),
-                                     (L'.EFfiApp ("Basis", "new_client_source", [(L'.ERecord [], loc)]), loc)), loc)),
+                                     (L'.EFfiApp ("Basis", "new_client_source", [(L'.ERel 1, loc)]), loc)), loc)),
                   loc),
                  fm)
             end
@@ -1003,6 +1003,14 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                      (L'.ESignalBind ((L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
                  fm)
             end
+          | L.ECApp ((L.EFfi ("Basis", "signal"), _), t) =>
+            let
+                val t = monoType env t
+            in
+                ((L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc), (L'.TSignal t, loc),
+                           (L'.ESignalSource (L'.ERel 0, loc), loc)), loc),
+                 fm)
+            end
 
           | L.ECApp ((L.EFfi ("Basis", "getCookie"), _), t) =>
             let