Setting a source server-side

11 files changed, 68 insertions, 14 deletions

diff --git a/include/urweb.h b/include/urweb.h
index 647f153a..a5bb8dc0 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -36,7 +36,9 @@ char *uw_get_optional_input(uw_context, int name);
 
 void uw_write(uw_context, const char*);
 
-int uw_Basis_new_client_source(uw_context, uw_unit);
+uw_Basis_int uw_Basis_new_client_source(uw_context, uw_Basis_string);
+uw_unit uw_Basis_set_client_source(uw_context, uw_Basis_int, uw_Basis_string);
+
 char *uw_Basis_get_script(uw_context, uw_unit);
 
 char *uw_Basis_htmlifyInt(uw_context, uw_Basis_int);
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 11b99f4c..2c6d493a 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -363,6 +363,7 @@ static void uw_check_script(uw_context ctx, size_t extra) {
     ctx->script_front = new_script + (ctx->script_front - ctx->script);
     ctx->script_back = new_script + next;
     ctx->script = new_script;
+    printf("new_script = %p\n", new_script);
   }
 }
 
@@ -434,7 +435,7 @@ uw_Basis_string uw_Basis_jsifyString_ws(uw_context ctx, uw_Basis_string s) {
     char c = *s;
 
     switch (c) {
-    case '"':
+    case '\'':
       strcpy(s2, "\\\"");
       s2 += 2;
       break;
@@ -457,18 +458,36 @@ uw_Basis_string uw_Basis_jsifyString_ws(uw_context ctx, uw_Basis_string s) {
   return r;
 }
 
-int uw_Basis_new_client_source(uw_context ctx, uw_Basis_string s) {
-  size_t len;
+uw_Basis_int uw_Basis_new_client_source(uw_context ctx, uw_Basis_string s) {
+  int len;
+  size_t s_len = strlen(s);
 
-  uw_check_script(ctx, 8 + INTS_MAX);
+  uw_check_script(ctx, 12 + INTS_MAX + s_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, ");");
+  strcpy(ctx->script_front, s);
+  ctx->script_front += s_len;
+  strcpy(ctx->script_front, ");");
+  ctx->script_front += 2;
 
   return ctx->source_count++;
 }
 
+uw_unit uw_Basis_set_client_source(uw_context ctx, uw_Basis_int n, uw_Basis_string s) {
+  int len;
+  size_t s_len = strlen(s);
+
+  uw_check_script(ctx, 6 + INTS_MAX + s_len);
+  sprintf(ctx->script_front, "s%d.v=%n", (int)n, &len);
+  ctx->script_front += len;
+  strcpy(ctx->script_front, s);
+  ctx->script_front += s_len;
+  strcpy(ctx->script_front, ";");
+  ctx->script_front++;
+
+  return uw_unit_v;
+}
+
 static void uw_check(uw_context ctx, size_t extra) {
   size_t desired = ctx->page_front - ctx->page + extra, next;
   char *new_page;
diff --git a/src/cjrize.sml b/src/cjrize.sml
index a9c51826..6d0ece61 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -120,6 +120,7 @@ fun cifyTyp x =
                 in
                     ((L'.TOption t, loc), sm)
                 end
+              | L.TSource => ((L'.TFfi ("Basis", "int"), loc), sm)
               | L.TSignal _ => raise Fail "Cjrize: TSignal remains"
     in
         cify IM.empty x
diff --git a/src/jscomp.sml b/src/jscomp.sml
index f7ef6927..8b874289 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -121,6 +121,13 @@ fun jsExp mode outer =
                    (str "ERROR", st))
 
                 val strcat = strcat loc
+
+                fun quoteExp (t : typ) e =
+                    case #1 t of
+                        TSource => strcat [str "s",
+                                           (EFfiApp ("Basis", "htmlifyInt", [e]), loc)]
+                      | _ => (EM.errorAt loc "Don't know how to embed type in JavaScript";
+                              str "ERROR")
             in
                 case #1 e of
                     EPrim (Prim.String s) =>
@@ -130,6 +137,7 @@ fun jsExp mode outer =
                                                      "\\047"
                                                  else
                                                      "'"
+                                               | #"\"" => "\\\""
                                                | #"<" =>
                                                  if mode = Script then
                                                      "<"
@@ -143,7 +151,11 @@ fun jsExp mode outer =
                     if n < inner then
                         (str ("uwr" ^ var n), st)
                     else
-                        (str ("uwo" ^ var n), st)
+                        let
+                            val n = n - inner
+                        in
+                            (quoteExp (List.nth (outer, n)) (ERel n, loc), st)
+                        end
                   | ENamed _ => raise Fail "Named"
                   | ECon (_, pc, NONE) => (patCon pc, st)
                   | ECon (_, pc, SOME e) =>
diff --git a/src/mono.sml b/src/mono.sml
index ae9a06c7..41457071 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -37,6 +37,7 @@ datatype typ' =
        | TDatatype of int * (datatype_kind * (string * int * typ option) list) ref
        | TFfi of string * string
        | TOption of typ
+       | TSource
        | TSignal of typ
 
 withtype typ = typ' located
diff --git a/src/mono_print.sml b/src/mono_print.sml
index b3c0a568..a876cfac 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -65,6 +65,7 @@ fun p_typ' par env (t, _) =
       | TOption t => box [string "option(",
                           p_typ env t,
                           string ")"]
+      | TSource => string "source"
       | TSignal t => box [string "signal(",
                           p_typ env t,
                           string ")"]
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index a6777db5..072c548e 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -55,6 +55,7 @@ fun impure (e, _) =
       | EFfi _ => false
       | EFfiApp ("Basis", "set_cookie", _) => true
       | EFfiApp ("Basis", "new_client_source", _) => true
+      | EFfiApp ("Basis", "set_client_source", _) => true
       | EFfiApp _ => false
       | EApp ((EFfi _, _), _) => false
       | EApp _ => true
@@ -263,6 +264,7 @@ fun reduce file =
               | EFfi _ => []
               | EFfiApp ("Basis", "set_cookie", _) => [Unsure]
               | EFfiApp ("Basis", "new_client_source", _) => [Unsure]
+              | EFfiApp ("Basis", "set_client_source", _) => [Unsure]
               | EFfiApp (_, _, es) => List.concat (map (summarize d) es)
               | EApp ((EFfi _, _), e) => summarize d e
               | EApp _ =>
diff --git a/src/mono_util.sml b/src/mono_util.sml
index b14e3ac9..3f9183d0 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -51,6 +51,7 @@ fun compare ((t1, _), (t2, _)) =
       | (TDatatype (n1, _), TDatatype (n2, _)) => Int.compare (n1, n2)
       | (TFfi (m1, x1), TFfi (m2, x2)) => join (String.compare (m1, m2), fn () => String.compare (x1, x2))
       | (TOption t1, TOption t2) => compare (t1, t2)
+      | (TSource, TSource) => EQUAL
       | (TSignal t1, TSignal t2) => compare (t1, t2)
 
       | (TFun _, _) => LESS
@@ -68,6 +69,9 @@ fun compare ((t1, _), (t2, _)) =
       | (TOption _, _) => LESS
       | (_, TOption _) => GREATER
 
+      | (TSource, _) => LESS
+      | (_, TSource) => GREATER
+
 and compareFields ((x1, t1), (x2, t2)) =
     join (String.compare (x1, x2),
           fn () => compare (t1, t2))
@@ -100,6 +104,7 @@ fun mapfold fc =
                 S.map2 (mft t,
                         fn t' =>
                            (TOption t, loc))
+              | TSource => S.return2 cAll
               | TSignal t =>
                 S.map2 (mft t,
                         fn t' =>
diff --git a/src/monoize.sml b/src/monoize.sml
index e34ef162..f40d49d0 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -134,7 +134,7 @@ fun monoType env =
                   | L.CApp ((L.CFfi ("Basis", "transaction"), _), t) =>
                     (L'.TFun ((L'.TRecord [], loc), mt env dtmap t), loc)
                   | L.CApp ((L.CFfi ("Basis", "source"), _), t) =>
-                    (L'.TFfi ("Basis", "int"), loc)
+                    (L'.TSource, loc)
                   | L.CApp ((L.CFfi ("Basis", "signal"), _), t) =>
                     (L'.TSignal (mt env dtmap t), loc)
                   | L.CApp ((L.CFfi ("Basis", "http_cookie"), _), _) =>
@@ -973,9 +973,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
             let
                 val t = monoType env t
             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'.ERel 1, loc)]), loc)), loc)),
+                ((L'.EAbs ("x", t, (L'.TFun ((L'.TRecord [], loc), (L'.TSource, loc)), loc),
+                           (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TSource, loc),
+                                     (L'.EFfiApp ("Basis", "new_client_source",
+                                                  [(L'.EJavaScript (L'.File, (L'.ERel 1, loc)), loc)]), loc)), loc)),
                   loc),
                  fm)
             end
@@ -983,12 +984,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
             let
                 val t = monoType env t
             in
-                ((L'.EAbs ("src", (L'.TFfi ("Basis", "int"), loc),
+                ((L'.EAbs ("src", (L'.TSource, loc),
                            (L'.TFun (t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc)), loc),
                            (L'.EAbs ("v", t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc),
                                      (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
                                                (L'.EFfiApp ("Basis", "set_client_source",
-                                                            [(L'.ERel 2, loc), (L'.ERel 1, loc)]),
+                                                            [(L'.ERel 2, loc),
+                                                             (L'.EJavaScript (L'.File, (L'.ERel 1, loc)), loc)]),
                                                 loc)), loc)), loc)), loc),
                  fm)
             end
diff --git a/tests/reactive2.ur b/tests/reactive2.ur
new file mode 100644
index 00000000..7164468e
--- /dev/null
+++ b/tests/reactive2.ur
@@ -0,0 +1,6 @@
+fun main () : transaction page =
+  x <- source <xml>TEST</xml>;
+  set x <xml>HI</xml>;
+  return <xml><body>
+    <dyn signal={signal x}/>
+  </body></xml>
diff --git a/tests/reactive2.urp b/tests/reactive2.urp
new file mode 100644
index 00000000..bdc0d1be
--- /dev/null
+++ b/tests/reactive2.urp
@@ -0,0 +1,3 @@
+debug
+
+reactive2