Almost ready to have a form work

3 files changed, 221 insertions, 80 deletions

diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 4cf3300d..218fcdee 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -208,13 +208,48 @@ fun p_decl env (dAll as (d, _) : decl) =
                  newline]
         end
 
-fun unurlify (t, loc) =
+fun unurlify env (t, loc) =
     case t of
         TFfi ("Basis", "int") => string "lw_unurlifyInt(&request)"
       | TFfi ("Basis", "float") => string "lw_unurlifyFloat(&request)"
       | TFfi ("Basis", "string") => string "lw_unurlifyString(ctx, &request)"
 
       | TRecord 0 => string "lw_unit_v"
+      | TRecord i =>
+        let
+            val xts = E.lookupStruct env i
+        in
+            box [string "({",
+                 newline,
+                 box (map (fn (x, t) =>
+                              box [p_typ env t,
+                                   space,
+                                   string x,
+                                   space,
+                                   string "=",
+                                   space,
+                                   unurlify env t,
+                                   string ";",
+                                   newline]) xts),
+                 string "struct",
+                 space,
+                 string "__lws_",
+                 string (Int.toString i),
+                 space,
+                 string "__lw_tmp",
+                 space,
+                 string "=",
+                 space,
+                 string "{",
+                 space,
+                 p_list_sep (box [string ",", space]) (fn (x, _) => string x) xts,
+                 space,
+                 string "};",
+                 newline,
+                 string "__lw_tmp;",
+                 newline,
+                 string "})"]
+        end
 
       | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function";
               space)
@@ -241,7 +276,7 @@ fun p_page env (s, n, ts) =
                                                     space,
                                                     string "=",
                                                     space,
-                                                    unurlify t,
+                                                    unurlify env t,
                                                     string ";",
                                                     newline]) ts),
               p_enamed env n,
diff --git a/src/monoize.sml b/src/monoize.sml
index ad177a64..dbe69c6a 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -61,7 +61,8 @@ fun monoType env (all as (c, loc)) =
             (L'.TRecord (map (fn (x, t) => (monoName env x, monoType env t)) xcs), loc)
           | L.TRecord _ => poly ()
 
-          | L.CApp ((L.CFfi ("Basis", "xml"), _), _) => (L'.TFfi ("Basis", "string"), loc)
+          | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "xml"), _), _), _), _), _), _) =>
+            (L'.TFfi ("Basis", "string"), loc)
 
           | L.CRel _ => poly ()
           | L.CNamed n => (L'.TNamed n, loc)
@@ -124,6 +125,11 @@ fun fooifyExp name env =
 val attrifyExp = fooifyExp "attr"
 val urlifyExp = fooifyExp "url"
 
+datatype 'a failable_search =
+         Found of 'a
+       | NotFound
+       | Error
+
 fun monoExp env (all as (e, loc)) =
     let
         fun poly () =
@@ -176,30 +182,35 @@ fun monoExp env (all as (e, loc)) =
             let
                 fun getTag' (e, _) =
                     case e of
-                        L.EFfi ("Basis", tag) => tag
-                      | L.ECApp (e, _) => getTag' e
+                        L.EFfi ("Basis", tag) => (tag, [])
+                      | L.ECApp (e, t) => let
+                            val (tag, ts) = getTag' e
+                        in
+                            (tag, ts @ [t])
+                        end
                       | _ => (E.errorAt loc "Non-constant XML tag";
                               Print.eprefaces' [("Expression", CorePrint.p_exp env tag)];
-                              "")
+                              ("", []))
 
                 fun getTag (e, _) =
                     case e of
-                        L.EFfiApp ("Basis", tag, [(L.ERecord [], _)]) => tag
+                        L.EFfiApp ("Basis", tag, [(L.ERecord [], _)]) => (tag, [])
                       | L.EApp (e, (L.ERecord [], _)) => getTag' e
                       | _ => (E.errorAt loc "Non-constant XML tag";
                               Print.eprefaces' [("Expression", CorePrint.p_exp env tag)];
-                              "")
+                              ("", []))
 
-                val tag = getTag tag
+                val (tag, targs) = getTag tag
 
                 val attrs = monoExp env attrs
 
-                val tagStart =
+                fun tagStart tag =
                     case #1 attrs of
                         L'.ERecord xes =>
                         let
                             fun lowercaseFirst "" = ""
-                              | lowercaseFirst s = str (Char.toLower (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
+                              | lowercaseFirst s = str (Char.toLower (String.sub (s, 0)))
+                                                   ^ String.extract (s, 1, NONE)
 
                             val s = (L'.EPrim (Prim.String (String.concat ["<", tag])), loc)
                         in
@@ -210,47 +221,135 @@ fun monoExp env (all as (e, loc)) =
                                           val fooify =
                                               case x of
                                                   "Link" => urlifyExp
+                                                | "Action" => urlifyExp
                                                 | _ => attrifyExp
                                       in
                                           (L'.EStrcat (s,
                                                        (L'.EStrcat ((L'.EPrim (Prim.String xp), loc),
                                                                     (L'.EStrcat (fooify env (e, t),
-                                                                                 (L'.EPrim (Prim.String "\""), loc)),
+                                                                                 (L'.EPrim (Prim.String "\""),
+                                                                                  loc)),
                                                                      loc)),
                                                         loc)), loc)
                                       end)
-                            s xes
+                                  s xes
                         end
-                      | _ => raise Fail "Attributes!"
-
-                fun normal () =
-                    (L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc),
-                                 (L'.EStrcat (monoExp env xml,
-                                              (L'.EPrim (Prim.String (String.concat ["</", tag, ">"])), loc)), loc)),
-                     loc)
-
-
+                      | _ => raise Fail "Non-record attributes!"
+
+                fun input typ =
+                    case targs of
+                        [(L.CName name, _)] =>
+                        (L'.EStrcat (tagStart "input",
+                                     (L'.EPrim (Prim.String (" type=\"" ^ typ ^ "\" name=\"" ^ name ^ "\"/>")),
+                                      loc)), loc)
+                      | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
+                              raise Fail "No named passed to input tag")
             in
-                case xml of
-                    (L.EApp ((L.ECApp (
-                              (L.ECApp ((L.EFfi ("Basis", "cdata"), _),
-                                        _), _),
-                              _), _),
-                             (L.EPrim (Prim.String s), _)), _) =>
-                    if CharVector.all Char.isSpace s then
-                        (L'.EStrcat (tagStart, (L'.EPrim (Prim.String "/>"), loc)), loc)
-                    else
-                        normal ()
-                  | _ => normal ()
+                case tag of
+                    "submit" => (L'.EPrim (Prim.String "<input type=\"submit\"/>"), loc)
+
+                  | "textbox" =>
+                    (case targs of
+                         [_, (L.CName name, _)] =>
+                         (L'.EStrcat (tagStart "input",
+                                      (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\"/>")),
+                                       loc)), loc)
+                       | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
+                               raise Fail "No named passed to input tag"))
+
+                  | _ =>
+                    let
+                        val tagStart = tagStart tag
+                                       
+                        fun normal () =
+                            (L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc),
+                                         (L'.EStrcat (monoExp env xml,
+                                                      (L'.EPrim (Prim.String (String.concat ["</", tag, ">"])),
+                                                       loc)), loc)),
+                             loc)
+                    in
+                        case xml of
+                            (L.EApp ((L.ECApp (
+                                      (L.ECApp ((L.EFfi ("Basis", "cdata"), _),
+                                                _), _),
+                                      _), _),
+                                     (L.EPrim (Prim.String s), _)), _) =>
+                            if CharVector.all Char.isSpace s then
+                                (L'.EStrcat (tagStart, (L'.EPrim (Prim.String "/>"), loc)), loc)
+                            else
+                                normal ()
+                          | _ => normal ()
+                    end
             end
 
           | L.EApp ((L.ECApp (
                      (L.ECApp ((L.EFfi ("Basis", "lform"), _), _), _),
                      _), _),
                     xml) =>
-            (L'.EStrcat ((L'.EPrim (Prim.String "<form>"), loc),
-                         (L'.EStrcat (monoExp env xml,
-                                      (L'.EPrim (Prim.String "</form>"), loc)), loc)), loc)
+            let
+                fun findSubmit (e, _) =
+                    case e of
+                        L.EApp (
+                        (L.EApp (
+                         (L.ECApp (
+                          (L.ECApp (
+                           (L.ECApp (
+                            (L.ECApp (
+                             (L.EFfi ("Basis", "join"),
+                              _), _), _),
+                            _), _),
+                           _), _),
+                          _), _),
+                         xml1), _),
+                        xml2) => (case findSubmit xml1 of
+                                      Error => Error
+                                    | NotFound => findSubmit xml2
+                                    | Found e =>
+                                      case findSubmit xml2 of
+                                          NotFound => Found e
+                                        | _ => Error)
+                      | L.EApp (
+                        (L.EApp (
+                         (L.EApp (
+                          (L.ECApp (
+                           (L.ECApp (
+                            (L.ECApp (
+                             (L.ECApp (
+                              (L.ECApp (
+                               (L.ECApp (
+                                (L.ECApp (
+                                 (L.ECApp (
+                                  (L.EFfi ("Basis", "tag"),
+                                   _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
+                          attrs), _),
+                         _), _),
+                        xml) =>
+                        (case #1 attrs of
+                             L.ERecord xes =>
+                             (case ListUtil.search (fn ((L.CName "Action", _), e, t) => SOME (e, t)
+                                                     | _ => NONE) xes of
+                                  NONE => findSubmit xml
+                                | SOME et =>
+                                  case findSubmit xml of
+                                      NotFound => Found et
+                                    | _ => Error)
+                           | _ => findSubmit xml)
+                      | _ => NotFound
+
+                val (action, actionT) = case findSubmit xml of
+                    NotFound => raise Fail "No submit found"
+                  | Error => raise Fail "Not ready for multi-submit lforms yet"
+                  | Found et => et
+
+                val actionT = monoType env actionT
+                val action = monoExp env action
+            in
+                (L'.EStrcat ((L'.EStrcat ((L'.EPrim (Prim.String "<form action=\""), loc),
+                                          (L'.EStrcat (urlifyExp env (action, actionT),
+                                                       (L'.EPrim (Prim.String "\">"), loc)), loc)), loc),
+                             (L'.EStrcat (monoExp env xml,
+                                          (L'.EPrim (Prim.String "</form>"), loc)), loc)), loc)
+            end
 
           | L.EApp (e1, e2) => (L'.EApp (monoExp env e1, monoExp env e2), loc)
           | L.EAbs (x, dom, ran, e) =>
diff --git a/src/tag.sml b/src/tag.sml
index 53966bf9..3bd9f3f1 100644
--- a/src/tag.sml
+++ b/src/tag.sml
@@ -65,50 +65,57 @@ fun exp env (e, s) =
              let
                  val (xets, s) =
                      ListUtil.foldlMap (fn ((x, e, t), (count, tags, byTag, newTags)) =>
-                                           case x of
-                                               (CName "Link", _) =>
-                                               let
-                                                   fun unravel (e, _) =
-                                                       case e of
-                                                           ENamed n => (n, [])
-                                                         | EApp (e1, e2) =>
-                                                           let
-                                                               val (n, es) = unravel e1
-                                                           in
-                                                               (n, es @ [e2])
-                                                           end
-                                                         | _ => (ErrorMsg.errorAt loc "Invalid link expression";
-                                                                 (0, []))
-
-                                                   val (f, args) = unravel e
-
-                                                   val (cn, count, tags, newTags) =
-                                                       case IM.find (tags, f) of
-                                                           NONE =>
-                                                           (count, count + 1, IM.insert (tags, f, count),
-                                                            (f, count) :: newTags)
-                                                         | SOME cn => (cn, count, tags, newTags)
-
-                                                   val (_, _, _, s) = E.lookupENamed env f
-
-                                                   val byTag = case SM.find (byTag, s) of
-                                                                   NONE => SM.insert (byTag, s, f)
-                                                                 | SOME f' =>
-                                                                   (if f = f' then
-                                                                       ()
-                                                                    else
-                                                                        ErrorMsg.errorAt loc 
-                                                                                         ("Duplicate HTTP tag "
-                                                                                          ^ s);
-                                                                    byTag)
-
-                                                   val e = (EClosure (cn, args), loc)
-                                                   val t = (CFfi ("Basis", "string"), loc)
-                                               in
-                                                   (((CName "href", loc), e, t),
-                                                    (count, tags, byTag, newTags))
-                                               end
-                                             | _ => ((x, e, t), (count, tags, byTag, newTags)))
+                                           let
+                                               fun tagIt newAttr =
+                                                   let
+                                                       fun unravel (e, _) =
+                                                           case e of
+                                                               ENamed n => (n, [])
+                                                             | EApp (e1, e2) =>
+                                                               let
+                                                                   val (n, es) = unravel e1
+                                                               in
+                                                                   (n, es @ [e2])
+                                                               end
+                                                             | _ => (ErrorMsg.errorAt loc "Invalid link expression";
+                                                                     (0, []))
+
+
+
+                                                       val (f, args) = unravel e
+
+                                                       val (cn, count, tags, newTags) =
+                                                           case IM.find (tags, f) of
+                                                               NONE =>
+                                                               (count, count + 1, IM.insert (tags, f, count),
+                                                                (f, count) :: newTags)
+                                                             | SOME cn => (cn, count, tags, newTags)
+                                                                          
+                                                       val (_, _, _, s) = E.lookupENamed env f
+
+                                                       val byTag = case SM.find (byTag, s) of
+                                                                       NONE => SM.insert (byTag, s, f)
+                                                                     | SOME f' =>
+                                                                       (if f = f' then
+                                                                            ()
+                                                                        else
+                                                                            ErrorMsg.errorAt loc 
+                                                                                             ("Duplicate HTTP tag "
+                                                                                              ^ s);
+                                                                        byTag)
+
+                                                       val e = (EClosure (cn, args), loc)
+                                                       val t = (CFfi ("Basis", "string"), loc)
+                                                   in
+                                                       (((CName newAttr, loc), e, t),
+                                                        (count, tags, byTag, newTags))
+                                                   end
+                                           in
+                                               case x of
+                                                   (CName "Link", _) => tagIt "Href"
+                                                 | (CName "Action", _) => tagIt "Action"
+                                                 | _ => ((x, e, t), (count, tags, byTag, newTags))
+                                           end)
                      s xets
              in
                  (EApp (