Creation of sources in server code

7 files changed, 62 insertions, 15 deletions

diff --git a/include/urweb.h b/include/urweb.h
index c021c3dd..3d7b967c 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -36,7 +36,8 @@ char *uw_get_optional_input(uw_context, int name);
 
 void uw_write(uw_context, const char*);
 
-int uw_Basis_new_client_reactive(uw_context);
+int uw_Basis_new_client_source(uw_context, uw_unit);
+char *uw_Basis_get_script(uw_context, uw_unit);
 
 char *uw_Basis_htmlifyInt(uw_context, uw_Basis_int);
 char *uw_Basis_htmlifyFloat(uw_context, uw_Basis_float);
diff --git a/lib/basis.urs b/lib/basis.urs
index 25923870..ffba2b37 100644
--- a/lib/basis.urs
+++ b/lib/basis.urs
@@ -80,11 +80,15 @@ val bind : m ::: (Type -> Type) -> t1 ::: Type -> t2 ::: Type
            -> m t1 -> (t1 -> m t2)
            -> m t2
 
-(** ** Transactions *)
-
 con transaction :: Type -> Type
 val transaction_monad : monad transaction
 
+con source :: Type -> Type
+val source : t ::: Type -> t -> transaction (source t)
+
+con signal :: Type -> Type
+val signal_monad : monad signal
+val signal : t ::: Type -> source t -> signal t
 
 
 (** HTTP operations *)
diff --git a/src/c/urweb.c b/src/c/urweb.c
index f9b623a4..7a9b3e79 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -32,7 +32,7 @@ struct uw_context {
   char **inputs;
 
   char *script, *script_front, *script_back;
-  int reactive_count;
+  int source_count;
 
   void *db;
 
@@ -75,7 +75,7 @@ uw_context uw_init(size_t outHeaders_len, size_t script_len, size_t page_len, si
 
   ctx->script_front = ctx->script = malloc(script_len);
   ctx->script_back = ctx->script_front + script_len;
-  ctx->reactive_count = 0;
+  ctx->source_count = 0;
 
   return ctx;
 }
@@ -105,7 +105,7 @@ void uw_reset_keep_error_message(uw_context ctx) {
   ctx->heap_front = ctx->heap;
   ctx->regions = NULL;
   ctx->cleanup_front = ctx->cleanup;
-  ctx->reactive_count = 0;
+  ctx->source_count = 0;
 }
 
 void uw_reset_keep_request(uw_context ctx) {
@@ -374,14 +374,27 @@ void uw_write_script(uw_context ctx, uw_Basis_string s) {
   ctx->script_front += len;
 }
 
-int uw_Basis_new_client_reactive(uw_context ctx) {
+char *uw_Basis_get_script(uw_context ctx, uw_unit u) {
+  if (ctx->script_front == ctx->script) {
+    char *r = uw_malloc(ctx, 1);
+    r[0] = 0;
+    return r;
+  } else {
+    char *r = uw_malloc(ctx, 41 + (ctx->script_front - ctx->script));
+
+    sprintf(r, "<script type=\"text/javascript\">%s</script>", ctx->script);
+    return r;
+  }
+}
+
+int uw_Basis_new_client_source(uw_context ctx, uw_unit u) {
   size_t len;
 
   uw_check_script(ctx, 8 + INTS_MAX);
-  sprintf(ctx->script_front, "var e%d=0\n%n", ctx->reactive_count, &len);
+  sprintf(ctx->script_front, "var e%d=0\n%n", ctx->source_count, &len);
   ctx->script_front += len;
 
-  return ctx->reactive_count++;
+  return ctx->source_count++;
 }
 
 static void uw_check(uw_context ctx, size_t extra) {
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 24e686da..9cf6d8e8 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -54,6 +54,7 @@ fun impure (e, _) =
       | ESome (_, e) => impure e
       | EFfi _ => false
       | EFfiApp ("Basis", "set_cookie", _) => true
+      | EFfiApp ("Basis", "new_client_source", _) => true
       | EFfiApp _ => false
       | EApp ((EFfi _, _), _) => false
       | EApp _ => true
@@ -257,6 +258,7 @@ fun reduce file =
               | ESome (_, e) => summarize d e
               | EFfi _ => []
               | EFfiApp ("Basis", "set_cookie", _) => [Unsure]
+              | EFfiApp ("Basis", "new_client_source", _) => [Unsure]
               | EFfiApp (_, _, es) => List.concat (map (summarize d) es)
               | EApp ((EFfi _, _), e) => summarize d e
               | EApp _ =>
diff --git a/src/monoize.sml b/src/monoize.sml
index 1c4aa81b..e23d4f80 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -133,6 +133,8 @@ 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.CApp ((L.CFfi ("Basis", "http_cookie"), _), _) =>
                     (L'.TFfi ("Basis", "string"), loc)
                   | L.CApp ((L.CFfi ("Basis", "sql_table"), _), _) =>
@@ -965,6 +967,17 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                  fm)
             end
 
+          | L.ECApp ((L.EFfi ("Basis", "source"), _), t) =>
+            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'.ERecord [], loc)]), loc)), loc)),
+                  loc),
+                 fm)
+            end
+
           | L.ECApp ((L.EFfi ("Basis", "getCookie"), _), t) =>
             let
                 val s = (L'.TFfi ("Basis", "string"), loc)
@@ -1769,7 +1782,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                       | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
                               raise Fail "No name passed to input tag")
 
-                fun normal (tag, extra) =
+                fun normal (tag, extra, extraInner) =
                     let
                         val (tagStart, fm) = tagStart tag
                         val tagStart = case extra of
@@ -1779,6 +1792,9 @@ fun monoExp (env, st, fm) (all as (e, 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,
@@ -1802,7 +1818,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                     end
             in
                 case tag of
-                    "submit" => normal ("input type=\"submit\"", NONE)
+                    "body" => normal ("body", NONE,
+                                      SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc))
+                    
+                  | "submit" => normal ("input type=\"submit\"", NONE, NONE)
 
                   | "textbox" =>
                     (case targs of
@@ -1847,7 +1866,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                          NONE => raise Fail "No name for radioGroup"
                        | SOME name =>
                          normal ("input",
-                                 SOME (L'.EPrim (Prim.String (" type=\"radio\" name=\"" ^ name ^ "\"")), loc)))
+                                 SOME (L'.EPrim (Prim.String (" type=\"radio\" name=\"" ^ name ^ "\"")), loc),
+                                 NONE))
 
                   | "select" =>
                     (case targs of
@@ -1867,10 +1887,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                        | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
                                raise Fail "No name passed to lselect tag"))
 
-                  | "option" => normal ("option", NONE)
+                  | "option" => normal ("option", NONE, NONE)
 
-                  | "tabl" => normal ("table", NONE)
-                  | _ => normal (tag, NONE)
+                  | "tabl" => normal ("table", NONE, NONE)
+                  | _ => normal (tag, NONE, NONE)
             end
 
           | L.EApp ((L.ECApp (
diff --git a/tests/reactive.ur b/tests/reactive.ur
new file mode 100644
index 00000000..cb49541f
--- /dev/null
+++ b/tests/reactive.ur
@@ -0,0 +1,4 @@
+fun main () : transaction page =
+  x <- source ();
+  y <- source ();
+  return <xml><body>Hi!</body></xml>
diff --git a/tests/reactive.urp b/tests/reactive.urp
new file mode 100644
index 00000000..88dd4cbc
--- /dev/null
+++ b/tests/reactive.urp
@@ -0,0 +1,3 @@
+debug
+
+reactive