Subforms type-checks; lists urlified and unurlified

9 files changed, 224 insertions, 11 deletions

diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index ea6f6f4a..117f944c 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -566,7 +566,18 @@ val subform : ctx ::: {Unit} -> use ::: {Type} -> bind ::: {Type}
     nm :: Name -> [[nm] ~ use] =>
     xml form [] bind
     -> xml ([Form] ++ ctx) use [nm = $bind]
-       
+
+val subforms : ctx ::: {Unit} -> use ::: {Type} -> bind ::: {Type}
+              -> [[Form] ~ ctx] =>
+    nm :: Name -> [[nm] ~ use] =>
+    xml [Body, Subform] [Entry = $bind] []
+    -> xml ([Form] ++ ctx) use [nm = list ($bind)]
+
+val entry : ctx ::: {Unit} -> bind ::: {Type}
+              -> [[Subform] ~ ctx] =>
+    xml form [] bind
+    -> xml ([Subform] ++ ctx) [Entry = $bind] []
+
 con formTag = fn (ty :: Type) (inner :: {Unit}) (attrs :: {Type}) =>
                   ctx ::: {Unit}
                   -> [[Form] ~ ctx] =>
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index ee2307b6..babd0315 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -333,10 +333,6 @@ fun p_pat (env, exit, depth) (p, loc) =
                 in
                     (box [string "{",
                           newline,
-                          string "/* ",
-                          string (ErrorMsg.spanToString loc),
-                          string "*/",
-                          newline,
                           p_typ env t,
                           space,
                           string "disc",
@@ -864,6 +860,77 @@ fun unurlify env (t, loc) =
                              string "})"]
                     end
 
+              | TList (t', i) =>
+                if IS.member (rf, i) then
+                    box [string "unurlify_list_",
+                         string (Int.toString i),
+                         string "()"]
+                else
+                    let
+                        val rf = IS.add (rf, i)
+                    in
+                        box [string "({",
+                             space,
+                             p_typ env (t, loc),
+                             space,
+                             string "unurlify_list_",
+                             string (Int.toString i),
+                             string "(void) {",
+                             newline,
+                             box [string "return (request[0] == '/' ? ++request : request,",
+                                  newline,
+                                  string "((!strncmp(request, \"Nil\", 3) && (request[3] == 0 ",
+                                  string "|| request[3] == '/')) ? (request",
+                                  space,
+                                  string "+=",
+                                  space,
+                                  string "3, NULL) : ((!strncmp(request, \"Cons\", 4) && (request[4] == 0 ",
+                                  string "|| request[4] == '/')) ? (request",
+                                  space,
+                                  string "+=",
+                                  space,
+                                  string "4, (request[0] == '/' ? ++request : NULL), ",
+                                  newline,
+                                  
+                                  string "({",
+                                  newline,
+                                  p_typ env (t, loc),
+                                  space,
+                                  string "tmp",
+                                  space,
+                                  string "=",
+                                  space,
+                                  string "uw_malloc(ctx, sizeof(struct __uws_",
+                                  string (Int.toString i),
+                                  string "));",
+                                  newline,
+                                  string "*tmp",
+                                  space,
+                                  string "=",
+                                  space,
+                                  unurlify' rf (TRecord i),
+                                  string ";",
+                                  newline,
+                                  string "tmp;",
+                                  newline,
+                                  string "})",
+                                  string ")",
+                                  newline,
+                                  string ":",
+                                  space,
+                                  string ("(uw_error(ctx, FATAL, \"Error unurlifying list\"), NULL))));"),
+                                  newline],
+                             string "}",
+                             newline,
+                             newline,
+
+                             string "unurlify_list_",
+                             string (Int.toString i),
+                             string "();",
+                             newline,
+                             string "})"]
+                    end
+
               | TOption t =>
                 box [string "(request[0] == '/' ? ++request : request, ",
                      string "((!strncmp(request, \"None\", 4) ",
diff --git a/src/marshalcheck.sml b/src/marshalcheck.sml
index e39bf7c5..7dea28f3 100644
--- a/src/marshalcheck.sml
+++ b/src/marshalcheck.sml
@@ -60,6 +60,7 @@ val clientToServer = [("Basis", "int"),
                       ("Basis", "file"),
                       ("Basis", "unit"),
                       ("Basis", "option"),
+                      ("Basis", "list"),
                       ("Basis", "bool")]
 
 val clientToServer = PS.addList (PS.empty, clientToServer)
diff --git a/src/monoize.sml b/src/monoize.sml
index 1ecf7a20..e754452d 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -274,6 +274,7 @@ structure Fm :> sig
     val empty : int -> t
 
     val lookup : t -> foo_kind -> int -> (int -> t -> L'.decl * t) -> t * int
+    val lookupList : t -> foo_kind -> L'.typ -> (int -> t -> L'.decl * t) -> t * int
     val enter : t -> t
     val decls : t -> L'.decl list
 
@@ -291,23 +292,30 @@ structure M = BinaryMapFn(struct
                                 | (Url, Url) => EQUAL
                           end)
 
+structure TM = BinaryMapFn(struct
+                           type ord_key = L'.typ
+                           val compare = MonoUtil.Typ.compare
+                           end)
+
 type t = {
      count : int,
      map : int IM.map M.map,
+     listMap : int TM.map M.map,
      decls : L'.decl list
 }
 
 fun empty count = {
     count = count,
     map = M.empty,
+    listMap = M.empty,
     decls = []
 }
 
-fun enter ({count, map, ...} : t) = {count = count, map = map, decls = []}
-fun freshName {count, map, decls} = (count, {count = count + 1, map = map, decls = decls})
+fun enter ({count, map, listMap, ...} : t) = {count = count, map = map, listMap = listMap, decls = []}
+fun freshName {count, map, listMap, decls} = (count, {count = count + 1, map = map, listMap = listMap, decls = decls})
 fun decls ({decls, ...} : t) = decls
 
-fun lookup (t as {count, map, decls}) k n thunk =
+fun lookup (t as {count, map, listMap, decls}) k n thunk =
     let
         val im = Option.getOpt (M.find (map, k), IM.empty)
     in
@@ -315,12 +323,37 @@ fun lookup (t as {count, map, decls}) k n thunk =
             NONE =>
             let
                 val n' = count
-                val (d, {count, map, decls}) = thunk count {count = count + 1,
-                                                            map = M.insert (map, k, IM.insert (im, n, n')),
-                                                            decls = decls}
+                val (d, {count, map, listMap, decls}) =
+                    thunk count {count = count + 1,
+                                 map = M.insert (map, k, IM.insert (im, n, n')),
+                                 listMap = listMap,
+                                 decls = decls}
+            in
+                ({count = count,
+                  map = map,
+                  listMap = listMap,
+                  decls = d :: decls}, n')
+            end
+          | SOME n' => (t, n')
+    end
+
+fun lookupList (t as {count, map, listMap, decls}) k tp thunk =
+    let
+        val tm = Option.getOpt (M.find (listMap, k), TM.empty)
+    in
+        case TM.find (tm, tp) of
+            NONE =>
+            let
+                val n' = count
+                val (d, {count, map, listMap, decls}) =
+                    thunk count {count = count + 1,
+                                 map = map,
+                                 listMap = M.insert (listMap, k, TM.insert (tm, tp, n')),
+                                 decls = decls}
             in
                 ({count = count,
                   map = map,
+                  listMap = listMap,
                   decls = d :: decls}, n')
             end
           | SOME n' => (t, n')
@@ -452,6 +485,41 @@ fun fooifyExp fk env =
                          fm)
                     end
 
+                  | L'.TList t =>
+                    let
+                        fun makeDecl n fm =
+                            let
+                                val rt = (L'.TRecord [("1", t), ("2", (L'.TList t, loc))], loc)
+                                val (arg, fm) = fooify fm ((L'.ERel 0, loc), rt)
+
+                                val branches = [((L'.PNone rt, loc),
+                                                 (L'.EPrim (Prim.String "Nil"), loc)),
+                                                ((L'.PSome (rt, (L'.PVar ("a", rt), loc)), loc),
+                                                 (L'.EStrcat ((L'.EPrim (Prim.String "Cons/"), loc),
+                                                              arg), loc))]
+
+                                val dom = tAll
+                                val ran = (L'.TFfi ("Basis", "string"), loc)
+                            in
+                                ((L'.DValRec [(fk2s fk ^ "ify_list",
+                                               n,
+                                               (L'.TFun (dom, ran), loc),
+                                               (L'.EAbs ("x",
+                                                         dom,
+                                                         ran,
+                                                         (L'.ECase ((L'.ERel 0, loc),
+                                                                    branches,
+                                                                    {disc = dom,
+                                                                     result = ran}), loc)), loc),
+                                               "")], loc),
+                                 fm)
+                            end
+
+                        val (fm, n) = Fm.lookupList fm fk t makeDecl
+                    in
+                        ((L'.EApp ((L'.ENamed n, loc), e), loc), fm)
+                    end
+
                   | _ => (E.errorAt loc "Don't know how to encode attribute/URL type";
                           Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)];
                           (dummyExp, fm))
@@ -2718,6 +2786,34 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                  fm)
             end
 
+          | L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp (
+                                          (L.EFfi ("Basis", "subforms"), _), _), _), _),
+                                _), _), _), (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=\".s\" value=\""
+                                                           ^ nm ^ "\">")), loc),
+                                   (L'.ERel 0, loc),
+                                   (L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".e\" value=\"1\">")), loc)]),
+                  loc),
+                 fm)
+            end
+
+          | L.ECApp ((L.ECApp (
+                      (L.EFfi ("Basis", "entry"), _), _), _), _) =>
+            let
+                val s = (L'.TFfi ("Basis", "string"), loc)
+            in
+                ((L'.EAbs ("xml", s, s,
+                           strcat [(L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".i\" value=\"1\">")), 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 55a38c57..a74a48c8 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -1268,6 +1268,12 @@ xmlOne : NOTAGS                         (EApp ((EVar (["Basis"], "cdata", Infer)
                                                  else if et = "subform" then
                                                      (EApp ((EDisjointApp (#2 (#1 tag)), pos),
                                                             xml), pos)
+                                                 else if et = "subforms" then
+                                                     (EApp ((EDisjointApp (#2 (#1 tag)), pos),
+                                                            xml), pos)
+                                                 else if et = "entry" then
+                                                     (EApp ((EVar (["Basis"], "entry", Infer), pos),
+                                                            xml), pos)
                                                  else
                                                      (EApp (#2 tag, xml), pos)
                                              else
diff --git a/tests/list.ur b/tests/list.ur
index 815c0075..480bdd3e 100644
--- a/tests/list.ur
+++ b/tests/list.ur
@@ -8,10 +8,15 @@ fun delist (ls : list string) : xbody =
             Nil => <xml>Nil</xml>
           | Cons (h, t) => <xml>{[h]} :: {delist t}</xml>
 
+fun callback ls = return <xml><body>
+  {delist ls}
+</body></xml>
+
 fun main () = return <xml><body>
   {[isNil (Nil : list bool)]},
   {[isNil (Cons (1, Nil))]},
   {[isNil (Cons ("A", Cons ("B", Nil)))]}
 
   <p>{delist (Cons ("X", Cons ("Y", Cons ("Z", Nil))))}</p>
+  <a link={callback (Cons ("A", Cons ("B", Nil)))}>Go!</a>
 </body></xml>
diff --git a/tests/subforms.ur b/tests/subforms.ur
new file mode 100644
index 00000000..3db55a43
--- /dev/null
+++ b/tests/subforms.ur
@@ -0,0 +1,23 @@
+fun handler' ls =
+    case ls of
+        Nil => <xml/>
+      | Cons (r, ls) => <xml><li>{[r.A]}, {[r.B]}, {[r.Sub]}</li>{handler' ls}</xml>
+
+fun handler r = return <xml><body>
+  {[r.A]}, {handler' r.Sub}, {[r.C]}
+</body></xml>
+
+fun main () = return <xml><body>
+  <form>
+    <textbox{#A}/><br/>
+    <subforms{#Sub}>
+      <entry>
+        <textbox{#A}/><br/>
+        <textbox{#B}/><br/>
+        <textbox{#Sub}/><br/>
+      </entry>
+    </subforms>
+    <textbox{#C}/><br/>
+    <submit action={handler}/>
+  </form>
+</body></xml>
diff --git a/tests/subforms.urp b/tests/subforms.urp
new file mode 100644
index 00000000..f0d5c239
--- /dev/null
+++ b/tests/subforms.urp
@@ -0,0 +1,3 @@
+debug
+
+subforms
diff --git a/tests/subforms.urs b/tests/subforms.urs
new file mode 100644
index 00000000..6ac44e0b
--- /dev/null
+++ b/tests/subforms.urs
@@ -0,0 +1 @@
+val main : unit -> transaction page