Subforms type-checks; lists urlified and unurlified

4 files changed, 180 insertions, 10 deletions

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