# HG changeset patch
# User Adam Chlipala <adamc@hcoop.net>
# Date 1229705238 18000
# Node ID 74800be655919fc10562211fefa537e6eaf56eec
# Parent  803b2f3bb86b15a8c133fe7a5c2953a705064ff9
Creation of sources in server code

diff -r 803b2f3bb86b -r 74800be65591 include/urweb.h
--- a/include/urweb.h	Fri Dec 19 10:27:58 2008 -0500
+++ b/include/urweb.h	Fri Dec 19 11:47:18 2008 -0500
@@ -36,7 +36,8 @@
 
 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 -r 803b2f3bb86b -r 74800be65591 lib/basis.urs
--- a/lib/basis.urs	Fri Dec 19 10:27:58 2008 -0500
+++ b/lib/basis.urs	Fri Dec 19 11:47:18 2008 -0500
@@ -80,11 +80,15 @@
            -> 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 -r 803b2f3bb86b -r 74800be65591 src/c/urweb.c
--- a/src/c/urweb.c	Fri Dec 19 10:27:58 2008 -0500
+++ b/src/c/urweb.c	Fri Dec 19 11:47:18 2008 -0500
@@ -32,7 +32,7 @@
   char **inputs;
 
   char *script, *script_front, *script_back;
-  int reactive_count;
+  int source_count;
 
   void *db;
 
@@ -75,7 +75,7 @@
 
   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 @@
   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 @@
   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 -r 803b2f3bb86b -r 74800be65591 src/mono_reduce.sml
--- a/src/mono_reduce.sml	Fri Dec 19 10:27:58 2008 -0500
+++ b/src/mono_reduce.sml	Fri Dec 19 11:47:18 2008 -0500
@@ -54,6 +54,7 @@
       | 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 @@
               | 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 -r 803b2f3bb86b -r 74800be65591 src/monoize.sml
--- a/src/monoize.sml	Fri Dec 19 10:27:58 2008 -0500
+++ b/src/monoize.sml	Fri Dec 19 11:47:18 2008 -0500
@@ -133,6 +133,8 @@
 
                   | 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 @@
                  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 @@
                       | _ => (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 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 @@
                     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 @@
                          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 @@
                        | _ => (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 -r 803b2f3bb86b -r 74800be65591 tests/reactive.ur
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/reactive.ur	Fri Dec 19 11:47:18 2008 -0500
@@ -0,0 +1,4 @@
+fun main () : transaction page =
+  x <- source ();
+  y <- source ();
+  return <xml><body>Hi!</body></xml>
diff -r 803b2f3bb86b -r 74800be65591 tests/reactive.urp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/reactive.urp	Fri Dec 19 11:47:18 2008 -0500
@@ -0,0 +1,3 @@
+debug
+
+reactive