Subforms

12 files changed, 303 insertions, 77 deletions

diff --git a/CHANGELOG b/CHANGELOG
index 3a7d1de8..ebd60637 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -11,6 +11,7 @@ Next
 - Blobs and HTTP file upload
 - SQL outer joins
 - SQL views
+- Subforms
 
 ========
 20090405
diff --git a/demo/form.urp b/demo/form.urp
index 73356d49..f28331fc 100644
--- a/demo/form.urp
+++ b/demo/form.urp
@@ -1,2 +1,3 @@
+debug
 
 form
diff --git a/include/types.h b/include/types.h
index 71a5ee0f..ddf17552 100644
--- a/include/types.h
+++ b/include/types.h
@@ -35,6 +35,7 @@ typedef struct uw_Basis_file {
 
 typedef enum { SUCCESS, FATAL, BOUNDED_RETRY, UNLIMITED_RETRY, RETURN_BLOB } failure_kind;
 
+typedef struct input *uw_input;
 
 #define INTS_MAX 50
 #define FLOATS_MAX 100
diff --git a/include/urweb.h b/include/urweb.h
index 51ab9149..c5381fa8 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -41,11 +41,13 @@ void uw_memstats(uw_context);
 int uw_send(uw_context, int sock);
 
 void uw_set_input(uw_context, const char *name, char *value);
+void uw_set_file_input(uw_context, char *name, uw_Basis_file);
+
 char *uw_get_input(uw_context, int name);
 char *uw_get_optional_input(uw_context, int name);
-
-void uw_set_file_input(uw_context, char *name, uw_Basis_file);
 uw_Basis_file uw_get_file_input(uw_context, int name);
+void uw_enter_subform(uw_context, int name);
+void uw_leave_subform(uw_context);
 
 void uw_write(uw_context, const char*);
 
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index ec31e57f..1881bec3 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -555,9 +555,16 @@ val a : bodyTag [Link = transaction page, Href = url, Onclick = transaction unit
 val img : bodyTag [Src = url]
 
 val form : ctx ::: {Unit} -> bind ::: {Type}
-            -> [[Body] ~ ctx] =>
-                  xml form [] bind
-                  -> xml ([Body] ++ ctx) [] []
+           -> [[Body] ~ ctx] =>
+    xml form [] bind
+    -> xml ([Body] ++ ctx) [] []
+       
+val subform : ctx ::: {Unit} -> use ::: {Type} -> bind ::: {Type}
+              -> [[Form] ~ ctx] =>
+    nm :: Name -> [[nm] ~ use] =>
+    xml form [] bind
+    -> xml ([Form] ++ ctx) use [nm = $bind]
+       
 con formTag = fn (ty :: Type) (inner :: {Unit}) (attrs :: {Type}) =>
                   ctx ::: {Unit}
                   -> [[Form] ~ ctx] =>
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 1d6b804f..fc8b82c9 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -284,14 +284,17 @@ typedef struct {
 } delta;
 
 typedef enum {
-  UNSET, NORMAL, FIL
+  UNSET, NORMAL, FIL, SUBFORM
 } input_kind;
 
-typedef struct {
+typedef struct input {
   input_kind kind;
   union {
     char *normal;
     uw_Basis_file file;
+    struct {
+      struct input *fields, *prev;
+    } subform;
   } data;
 } input;
 
@@ -299,7 +302,8 @@ struct uw_context {
   char *headers, *headers_end;
 
   buf outHeaders, page, heap, script;
-  input *inputs;
+  input *inputs, *subinputs, *cur_inputs;
+  size_t n_subinputs, used_subinputs;
 
   int source_count;
 
@@ -339,6 +343,9 @@ uw_context uw_init() {
   ctx->script.start[0] = 0;
 
   ctx->inputs = calloc(uw_inputs_len, sizeof(input));
+  ctx->cur_inputs = NULL;
+  ctx->subinputs = malloc(0);
+  ctx->n_subinputs = ctx->used_subinputs = 0;
 
   ctx->db = NULL;
 
@@ -383,6 +390,7 @@ void uw_free(uw_context ctx) {
   buf_free(&ctx->page);
   buf_free(&ctx->heap);
   free(ctx->inputs);
+  free(ctx->subinputs);
   free(ctx->cleanup);
 
   for (i = 0; i < ctx->n_deltas; ++i)
@@ -392,6 +400,8 @@ void uw_free(uw_context ctx) {
 }
 
 void uw_reset_keep_error_message(uw_context ctx) {
+  size_t i;
+
   buf_reset(&ctx->outHeaders);
   buf_reset(&ctx->script);
   ctx->script.start[0] = 0;
@@ -412,6 +422,9 @@ void uw_reset_keep_request(uw_context ctx) {
 void uw_reset(uw_context ctx) {
   uw_reset_keep_request(ctx);
   memset(ctx->inputs, 0, uw_inputs_len * sizeof(input));
+  memset(ctx->subinputs, 0, ctx->n_subinputs * sizeof(input));
+  ctx->cur_inputs = NULL;
+  ctx->used_subinputs = 0;
 }
 
 void uw_db_init(uw_context);
@@ -564,17 +577,72 @@ char *uw_error_message(uw_context ctx) {
 
 extern int uw_input_num(const char*);
 
+#define INP(ctx) (ctx->cur_inputs ? ctx->cur_inputs : ctx->inputs)
+
 void uw_set_input(uw_context ctx, const char *name, char *value) {
-  int n = uw_input_num(name);
+  if (!strcasecmp(name, ".b")) {
+    size_t i;
+    int n = uw_input_num(value);
+    input *inps;
 
-  if (n < 0)
-    uw_error(ctx, FATAL, "Bad input name %s", name);
+    if (n < 0)
+      uw_error(ctx, FATAL, "Bad subform name %s", value);
 
-  if (n >= uw_inputs_len)
-    uw_error(ctx, FATAL, "For input name %s, index %d is out of range", name, n);
+    if (n >= uw_inputs_len)
+      uw_error(ctx, FATAL, "For subform name %s, index %d is out of range", value, n);
+
+    if (ctx->used_subinputs + uw_inputs_len >= ctx->n_subinputs) {
+      input *new_subinputs = realloc(ctx->subinputs, sizeof(input) * (ctx->used_subinputs + uw_inputs_len));
+      size_t offset = new_subinputs - ctx->subinputs;
+
+      for (i = 0; i < ctx->used_subinputs; ++i)
+        if (new_subinputs[i].kind == SUBFORM) {
+          new_subinputs[i].data.subform.fields += offset;
+          if (new_subinputs[i].data.subform.prev != NULL)
+            new_subinputs[i].data.subform.prev += offset;
+        }
+
+      for (i = 0; i < uw_inputs_len; ++i)
+        if (ctx->inputs[i].kind == SUBFORM) {
+          ctx->inputs[i].data.subform.fields += offset;
+          if (ctx->inputs[i].data.subform.prev != NULL)
+            ctx->inputs[i].data.subform.prev += offset;
+        }
+
+      if (ctx->cur_inputs != NULL)
+        ctx->cur_inputs += offset;
+
+      ctx->n_subinputs = ctx->used_subinputs + uw_inputs_len;
+      ctx->subinputs = new_subinputs;
+    }
+
+    ctx->inputs[n].kind = SUBFORM;
+    ctx->inputs[n].data.subform.prev = ctx->cur_inputs;
+    ctx->cur_inputs = ctx->inputs[n].data.subform.fields = &ctx->subinputs[ctx->used_subinputs];
+
+    for (i = 0; i < uw_inputs_len; ++i)
+      ctx->subinputs[ctx->used_subinputs++].kind = UNUSED;
+  } else if (!strcasecmp(name, ".e")) {
+    input *tmp;
+
+    if (ctx->cur_inputs == NULL)
+      uw_error(ctx, FATAL, "Unmatched subform closer");
+
+    tmp = ctx->cur_inputs;
+    ctx->cur_inputs = tmp->data.subform.prev;
+    tmp->data.subform.prev = NULL;
+  } else {
+    int n = uw_input_num(name);
 
-  ctx->inputs[n].kind = NORMAL;
-  ctx->inputs[n].data.normal = value;
+    if (n < 0)
+      uw_error(ctx, FATAL, "Bad input name %s", name);
+
+    if (n >= uw_inputs_len)
+      uw_error(ctx, FATAL, "For input name %s, index %d is out of range", name, n);
+
+    INP(ctx)[n].kind = NORMAL;
+    INP(ctx)[n].data.normal = value;
+  }
 }
 
 char *uw_get_input(uw_context ctx, int n) {
@@ -583,13 +651,15 @@ char *uw_get_input(uw_context ctx, int n) {
   if (n >= uw_inputs_len)
     uw_error(ctx, FATAL, "Out-of-bounds input index %d", n);
 
-  switch (ctx->inputs[n].kind) {
+  switch (INP(ctx)[n].kind) {
   case UNSET:
     return NULL;
   case FIL:
     uw_error(ctx, FATAL, "Tried to read a file form input as normal");
+  case SUBFORM:
+    uw_error(ctx, FATAL, "Tried to read a subform form input as normal");
   case NORMAL:
-    return ctx->inputs[n].data.normal;
+    return INP(ctx)[n].data.normal;
   default:
     uw_error(ctx, FATAL, "Impossible input kind");
   }
@@ -601,13 +671,15 @@ char *uw_get_optional_input(uw_context ctx, int n) {
   if (n >= uw_inputs_len)
     uw_error(ctx, FATAL, "Out-of-bounds input index %d", n);
 
-  switch (ctx->inputs[n].kind) {
+  switch (INP(ctx)[n].kind) {
   case UNSET:
     return "";
   case FIL:
     uw_error(ctx, FATAL, "Tried to read a file form input as normal");
+  case SUBFORM:
+    uw_error(ctx, FATAL, "Tried to read a subform form input as normal");
   case NORMAL:
-    return ctx->inputs[n].data.normal;
+    return INP(ctx)[n].data.normal;
   default:
     uw_error(ctx, FATAL, "Impossible input kind");
   }
@@ -634,7 +706,7 @@ uw_Basis_file uw_get_file_input(uw_context ctx, int n) {
   if (n >= uw_inputs_len)
     uw_error(ctx, FATAL, "Out-of-bounds file input index %d", n);
 
-  switch (ctx->inputs[n].kind) {
+  switch (INP(ctx)[n].kind) {
   case UNSET:
     {
       char *data = uw_malloc(ctx, 0);
@@ -642,14 +714,49 @@ uw_Basis_file uw_get_file_input(uw_context ctx, int n) {
       return f;
     }
   case FIL:
-    return ctx->inputs[n].data.file;
+    return INP(ctx)[n].data.file;
   case NORMAL:
     uw_error(ctx, FATAL, "Tried to read a normal form input as files");
+  case SUBFORM:
+    uw_error(ctx, FATAL, "Tried to read a subform form input as files");
+  default:
+    uw_error(ctx, FATAL, "Impossible input kind");
+  }
+}
+
+void uw_enter_subform(uw_context ctx, int n) {
+  if (n < 0)
+    uw_error(ctx, FATAL, "Negative subform index %d", n);
+  if (n >= uw_inputs_len)
+    uw_error(ctx, FATAL, "Out-of-bounds subform index %d", n);
+
+  switch (INP(ctx)[n].kind) {
+  case UNSET:
+    uw_error(ctx, FATAL, "Missing subform");
+  case FIL:
+    uw_error(ctx, FATAL, "Tried to read a file form input as subform");
+  case NORMAL:
+    uw_error(ctx, FATAL, "Tried to read a normal form input as subform");
+  case SUBFORM:
+    INP(ctx)[n].data.subform.prev = ctx->cur_inputs;
+    ctx->cur_inputs = INP(ctx)[n].data.subform.fields;
+    return;
   default:
     uw_error(ctx, FATAL, "Impossible input kind");
   }
 }
 
+void uw_leave_subform(uw_context ctx) {
+  input *tmp;
+
+  if (ctx->cur_inputs == NULL)
+    uw_error(ctx, FATAL, "Unmatched uw_leave_subform");
+
+  tmp = ctx->cur_inputs;
+  ctx->cur_inputs = tmp->data.subform.prev;
+  tmp->data.subform.prev = NULL;
+}
+
 void uw_set_script_header(uw_context ctx, const char *s) {
   ctx->script_header = s;
 }
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index a09dd7f6..7928ec5e 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -2340,31 +2340,50 @@ fun p_file env (ds, ps) =
                                                 E.declBinds env d))
                              env ds
 
+        fun flatFields (t : typ) =
+            case #1 t of
+                TRecord i =>
+                let
+                    val xts = E.lookupStruct env i
+                in
+                    SOME (map #1 xts :: List.concat (List.mapPartial (flatFields o #2) xts))
+                end
+              | _ => NONE
+
         val fields = foldl (fn ((ek, _, _, ts, _, _), fields) =>
                                case ek of
                                    Link => fields
                                  | Rpc _ => fields
                                  | Action eff =>
                                    case List.nth (ts, length ts - 2) of
-                                       (TRecord i, _) =>
+                                       (TRecord i, loc) =>
                                        let
                                            val xts = E.lookupStruct env i
                                            val xts = case eff of
                                                          ReadCookieWrite =>
                                                          (sigName xts, (TRecord 0, ErrorMsg.dummySpan)) :: xts
                                                        | _ => xts
-                                           val xtsSet = SS.addList (SS.empty, map #1 xts)
                                        in
-                                           foldl (fn ((x, _), fields) =>
-                                                     let
-                                                         val xtsSet' = Option.getOpt (SM.find (fields, x), SS.empty)
-                                                     in
-                                                         SM.insert (fields, x, SS.union (SS.delete (xtsSet, x),
-                                                                                         xtsSet'))
-                                                     end) fields xts
+                                           case flatFields (TRecord i, loc) of
+                                               NONE => raise Fail "CjrPrint: flatFields impossible"
+                                             | SOME fields' => List.revAppend (fields', fields)
                                        end
                                      | _ => raise Fail "CjrPrint: Last argument of action isn't record")
-                     SM.empty ps
+                           [] ps
+
+        val fields = foldl (fn (xts, fields) =>
+                               let
+                                   val xtsSet = SS.addList (SS.empty, xts)
+                               in
+                                   foldl (fn (x, fields) =>
+                                             let
+                                                 val xtsSet' = Option.getOpt (SM.find (fields, x), SS.empty)
+                                             in
+                                                 SM.insert (fields, x, SS.union (SS.delete (xtsSet, x),
+                                                                                 xtsSet'))
+                                             end) fields xts
+                               end)
+                           SM.empty fields
 
         val fnums = SM.foldli (fn (x, xs, fnums) =>
                                   let
@@ -2467,6 +2486,97 @@ fun p_file env (ds, ps) =
                              string "}"]
                 end
 
+        fun getInput (x, t) =
+            let
+                val n = case SM.find (fnums, x) of
+                            NONE => raise Fail "CjrPrint: Can't find in fnums"
+                          | SOME n => n
+
+                val f = case t of
+                            (TFfi ("Basis", "bool"), _) => "optional_"
+                          | _ => ""
+            in
+                if isFile t then
+                    box [string "uw_input_",
+                         p_ident x,
+                         space,
+                         string "=",
+                         space,
+                         string "uw_get_file_input(ctx, ",
+                         string (Int.toString n),
+                         string ");",
+                         newline]
+                else case #1 t of
+                         TRecord i =>
+                         let
+                             val xts = E.lookupStruct env i
+                         in
+                             box [string "uw_enter_subform(ctx, ",
+                                  string (Int.toString n),
+                                  string ");",
+                                  newline,
+                                  string "uw_input_",
+                                  p_ident x,
+                                  space,
+                                  string "=",
+                                  space,
+                                  string "({",
+                                  box [p_typ env t,
+                                       space,
+                                       string "result;",
+                                       newline,
+                                       p_list_sep (box [])
+                                                  (fn (x, t) =>
+                                                      box [p_typ env t,
+                                                           space,
+                                                           string "uw_input_",
+                                                           string x,
+                                                           string ";",
+                                                           newline])
+                                                  xts,
+                                       newline,
+                                       p_list_sep (box []) (fn (x, t) =>
+                                                               box [getInput (x, t),
+                                                                    string "result.__uwf_",
+                                                                    string x,
+                                                                    space,
+                                                                    string "=",
+                                                                    space,
+                                                                    string "uw_input_",
+                                                                    string x,
+                                                                    string ";",
+                                                                    newline])
+                                                  xts,
+                                       newline,
+                                       string "result;",
+                                       newline],
+                                  string "});",
+                                  newline,
+                                  string "uw_leave_subform(ctx);"]
+                         end
+                       | _ =>
+                         box [string "request = uw_get_",
+                              string f,
+                              string "input(ctx, ",
+                              string (Int.toString n),
+                              string ");",
+                              newline,
+                              string "if (request == NULL)",
+                              newline,
+                              box [string "uw_error(ctx, FATAL, \"Missing input ",
+                                   string x,
+                                   string "\");"],
+                              newline,
+                              string "uw_input_",
+                              p_ident x,
+                              space,
+                              string "=",
+                              space,
+                              unurlify env t,
+                              string ";",
+                              newline]
+            end
+
         fun p_page (ek, s, n, ts, ran, side) =
             let
                 val (ts, defInputs, inputsVar, fields) =
@@ -2487,48 +2597,7 @@ fun p_file env (ds, ps) =
                                                                   string ";",
                                                                   newline]) xts),
                                       newline,
-                                      box (map (fn (x, t) =>
-                                                   let
-                                                       val n = case SM.find (fnums, x) of
-                                                                   NONE => raise Fail "CjrPrint: Can't find in fnums"
-                                                                 | SOME n => n
-
-                                                       val f = case t of
-                                                                   (TFfi ("Basis", "bool"), _) => "optional_"
-                                                                 | _ => ""
-                                                   in
-                                                       if isFile t then
-                                                           box [string "uw_input_",
-                                                                p_ident x,
-                                                                space,
-                                                                string "=",
-                                                                space,
-                                                                string "uw_get_file_input(ctx, ",
-                                                                string (Int.toString n),
-                                                                string ");",
-                                                                newline]
-                                                       else
-                                                           box [string "request = uw_get_",
-                                                                string f,
-                                                                string "input(ctx, ",
-                                                                string (Int.toString n),
-                                                                string ");",
-                                                                newline,
-                                                                string "if (request == NULL)",
-                                                                newline,
-                                                                box [string "uw_error(ctx, FATAL, \"Missing input ",
-                                                                     string x,
-                                                                     string "\");"],
-                                                                newline,
-                                                                string "uw_input_",
-                                                                p_ident x,
-                                                                space,
-                                                                string "=",
-                                                                space,
-                                                                unurlify env t,
-                                                                string ";",
-                                                                newline]
-                                                   end) xts),
+                                      box (map getInput xts),
                                       string "struct __uws_",
                                       string (Int.toString i),
                                       space,
diff --git a/src/monoize.sml b/src/monoize.sml
index a2048a7d..ea191802 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -2686,6 +2686,21 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                  fm)
             end
 
+          | L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp (
+                                          (L.EFfi ("Basis", "subform"), _), _), _), _),
+                                _), _), _), (L.CName nm, loc)) =>
+            let
+                val s = (L'.TFfi ("Basis", "string"), loc)
+            in
+                ((L'.EAbs ("xml", s, s,
+                           strcat [(L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".b\" value=\""
+                                                           ^ nm ^ "\">")), loc),
+                                   (L'.ERel 0, loc),
+                                   (L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".e\" value=\"1\">")), loc)]),
+                  loc),
+                 fm)
+            end
+
           | L.EApp ((L.ECApp (
                      (L.ECApp (
                       (L.ECApp (
diff --git a/src/urweb.grm b/src/urweb.grm
index da817ab3..55a38c57 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -280,7 +280,7 @@ datatype attr = Class of exp | Normal of con * exp
  | rexp of (con * exp) list
  | xml of exp
  | xmlOne of exp
- | tag of string * exp
+ | tag of (string * exp) * exp
  | tagHead of string * exp
  | bind of string * con option * exp
  | edecl of edecl
@@ -1240,7 +1240,7 @@ xmlOne : NOTAGS                         (EApp ((EVar (["Basis"], "cdata", Infer)
                                              val pos = s (tagleft, GTright)
 
                                              val cdata =
-                                                 if #1 tag = "submit" orelse #1 tag = "dyn" then
+                                                 if #1 (#1 tag) = "submit" orelse #1 (#1 tag) = "dyn" then
                                                      let
                                                          val e = (EVar (["Basis"], "cdata", DontInfer), pos)
                                                          val e = (ECApp (e, (CWild (KWild, pos), pos)), pos)
@@ -1261,10 +1261,13 @@ xmlOne : NOTAGS                         (EApp ((EVar (["Basis"], "cdata", Infer)
                                              val pos = s (tagleft, GTright)
                                              val et = tagIn END_TAG
                                          in
-                                             if #1 tag = et then
+                                             if #1 (#1 tag) = et then
                                                  if et = "form" then
                                                      (EApp ((EVar (["Basis"], "form", Infer), pos),
                                                             xml), pos)
+                                                 else if et = "subform" then
+                                                     (EApp ((EDisjointApp (#2 (#1 tag)), pos),
+                                                            xml), pos)
                                                  else
                                                      (EApp (#2 tag, xml), pos)
                                              else
@@ -1295,7 +1298,7 @@ tag    : tagHead attrs                  (let
                                              val e = (EApp (e, (EApp (#2 tagHead,
                                                                       (ERecord [], pos)), pos)), pos)
                                          in
-                                             (#1 tagHead, e)
+                                             (tagHead, e)
                                          end)
 
 tagHead: BEGIN_TAG                      (let
diff --git a/tests/subform.ur b/tests/subform.ur
new file mode 100644
index 00000000..2ab1f1a3
--- /dev/null
+++ b/tests/subform.ur
@@ -0,0 +1,16 @@
+fun handler r = return <xml><body>
+  {[r.A]}, {[r.Sub.A]}, {[r.Sub.B]}, {[r.Sub.Sub]}, {[r.C]}
+</body></xml>
+
+fun main () = return <xml><body>
+  <form>
+    <textbox{#A}/><br/>
+    <subform{#Sub}>
+      <textbox{#A}/><br/>
+      <textbox{#B}/><br/>
+      <textbox{#Sub}/><br/>
+    </subform>
+    <textbox{#C}/><br/>
+    <submit action={handler}/>
+  </form>
+</body></xml>
diff --git a/tests/subform.urp b/tests/subform.urp
new file mode 100644
index 00000000..52f6a752
--- /dev/null
+++ b/tests/subform.urp
@@ -0,0 +1,3 @@
+debug
+
+subform
diff --git a/tests/subform.urs b/tests/subform.urs
new file mode 100644
index 00000000..6ac44e0b
--- /dev/null
+++ b/tests/subform.urs
@@ -0,0 +1 @@
+val main : unit -> transaction page