Use 'id' attribute for <form>

5 files changed, 48 insertions, 21 deletions

diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 8b0d4faa..82d8f6e4 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -947,7 +947,8 @@ val img : bodyTag ([Alt = string, Src = url, Width = int, Height = int,
 
 val form : ctx ::: {Unit} -> bind ::: {Type}
            -> [[MakeForm, Form] ~ ctx] =>
-    option css_class
+    option id
+    -> option css_class
     -> xml ([Form] ++ ctx) [] bind
     -> xml ([MakeForm] ++ ctx) [] []
 
diff --git a/src/monoize.sml b/src/monoize.sml
index 86f2b4a5..ddf6cd4c 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -3657,9 +3657,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
             end
 
           | L.EApp (
-            (L.EApp ((L.ECApp (
-                      (L.ECApp ((L.EFfi ("Basis", "form"), _), _), _),
-                      (L.CRecord (_, fields), _)), _),
+            (L.EApp ((L.EApp ((L.ECApp (
+                                    (L.ECApp ((L.EFfi ("Basis", "form"), _), _), _),
+                                    (L.CRecord (_, fields), _)), _),
+                              id), _),
                      class), _),
             xml) =>
             let
@@ -3793,6 +3794,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                  action
 
                 val stt = (L'.TFfi ("Basis", "string"), loc)
+                val (id, fm) = monoExp (env, st, fm) id
                 val (class, fm) = monoExp (env, st, fm) class
                 val action = (L'.EStrcat (action,
                                           (L'.ECase (class,
@@ -3806,8 +3808,17 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                                       result = stt}), loc)), loc)
             in
                 ((L'.EStrcat ((L'.EStrcat (strH "<form method=\"post\"",
-                                           (L'.EStrcat (action,
-                                                        strH ">"), loc)), loc),
+                                           (L'.EStrcat ((L'.ECase (id,
+                                                                   [((L'.PNone stt, loc),
+                                                                     strH ""),
+                                                                    ((L'.PSome (stt, (L'.PVar ("id", stt), loc)), loc),
+                                                                     (L'.EStrcat (strH " id=\"",
+                                                                                  (L'.EStrcat ((L'.ERel 0, loc),
+                                                                                               strH "\""), loc)), loc))],
+                                                                   {disc = (L'.TOption stt, loc),
+                                                                    result = stt}), loc),
+                                                        (L'.EStrcat (action,
+                                                                     strH ">"), loc)), loc)), loc),
                               (L'.EStrcat (xml,
                                            strH "</form>"), loc)), loc),
                  fm)
diff --git a/src/urweb.grm b/src/urweb.grm
index c1ee74f2..db5473a6 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -479,7 +479,7 @@ fun patternOut (e : exp) =
  | xml of exp
  | xmlOne of exp
  | xmlOpt of exp
- | tag of (string * exp) * exp option * exp option * exp
+ | tag of (string * exp) * exp option * exp option * exp option * exp
  | tagHead of string * exp
  | bind of pat * con option * exp
  | edecl of edecl
@@ -500,7 +500,7 @@ fun patternOut (e : exp) =
  | rpat of (string * pat) list * bool
  | ptuple of pat list
 
- | attrs of exp option * exp option * exp option * exp option * (string * string * exp) list * (con * exp) list
+ | attrs of exp option * exp option * exp option * exp option * exp option * (string * string * exp) list * (con * exp) list
  | attr of attr
  | attrv of exp
 
@@ -1610,7 +1610,7 @@ xmlOne : NOTAGS                         (EApp ((EVar (["Basis"], "cdata", Infer)
                                                                 (EPrim (Prim.String (Prim.Html, "")), pos)),
                                                           pos)
                                          in
-                                             (EApp (#4 tag, cdata), pos)
+                                             (EApp (#5 tag, cdata), pos)
                                          end)
          
        | tag GT xmlOpt END_TAG          (let
@@ -1626,6 +1626,9 @@ xmlOne : NOTAGS                         (EApp ((EVar (["Basis"], "cdata", Infer)
                                                  if et = "form" then
                                                      let
                                                          val e = (EVar (["Basis"], "form", Infer), pos)
+                                                         val e = (EApp (e, case #4 tag of
+                                                                               NONE => (EVar (["Basis"], "None", Infer), pos)
+                                                                             | SOME c => (EApp ((EVar (["Basis"], "Some", Infer), pos), c), pos)), pos)
                                                          val e = (EApp (e, case #2 tag of
                                                                                NONE => (EVar (["Basis"], "None", Infer), pos)
                                                                              | SOME (EPrim (Prim.String (_, s)), _) => (EApp ((EVar (["Basis"], "Some", Infer), pos), parseClass s pos), pos)
@@ -1643,7 +1646,7 @@ xmlOne : NOTAGS                         (EApp ((EVar (["Basis"], "cdata", Infer)
                                                      (EApp ((EVar (["Basis"], "entry", Infer), pos),
                                                             xmlOpt), pos)
                                                  else
-                                                     (EApp (#4 tag, xmlOpt), pos)
+                                                     (EApp (#5 tag, xmlOpt), pos)
                                              else
                                                  (if ErrorMsg.anyErrors () then
                                                       ()
@@ -1688,8 +1691,8 @@ tag    : tagHead attrs                  (let
                                                                            e), pos)
                                              val e = (EApp (e, eo), pos)
 
-                                             val atts = case #5 attrs of
-                                                            [] => #6 attrs
+                                             val atts = case #6 attrs of
+                                                            [] => #7 attrs
                                                           | data :: datas =>
                                                             let
                                                                 fun doOne (kind, name, value) =
@@ -1709,14 +1712,14 @@ tag    : tagHead attrs                  (let
                                                                                            (EApp (e, doOne nv), pos)
                                                                                        end) (doOne data) datas
                                                             in
-                                                                ((CName "Data", pos), datas') :: #6 attrs
+                                                                ((CName "Data", pos), datas') :: #7 attrs
                                                             end
 
                                              val e = (EApp (e, (ERecord (atts, false), pos)), pos)
                                              val e = (EApp (e, (EApp (#2 tagHead,
                                                                       (ERecord ([], false), pos)), pos)), pos)
                                          in
-                                             (tagHead, #1 attrs, #2 attrs, e)
+                                             (tagHead, #1 attrs, #2 attrs, #5 attrs, e)
                                          end)
 
 tagHead: BEGIN_TAG                      (let
@@ -1728,7 +1731,7 @@ tagHead: BEGIN_TAG                      (let
                                          end)
        | tagHead LBRACE cexp RBRACE     (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright)))
                                           
-attrs  :                                (NONE, NONE, NONE, NONE, [], [])
+attrs  :                                (NONE, NONE, NONE, NONE, NONE, [], [])
        | attr attrs                     (let
                                              val loc = s (attrleft, attrsright)
                                          in
@@ -1737,26 +1740,28 @@ attrs  :                                (NONE, NONE, NONE, NONE, [], [])
                                                  (case #1 attrs of
                                                       NONE => ()
                                                     | SOME _ => ErrorMsg.errorAt loc "Multiple classes specified for tag";
-                                                  (SOME e, #2 attrs, #3 attrs, #4 attrs, #5 attrs, #6 attrs))
+                                                  (SOME e, #2 attrs, #3 attrs, #4 attrs, #5 attrs, #6 attrs, #7 attrs))
                                                | DynClass e =>
                                                  (case #2 attrs of
                                                       NONE => ()
                                                     | SOME _ => ErrorMsg.errorAt loc "Multiple dynamic classes specified for tag";
-                                                  (#1 attrs, SOME e, #3 attrs, #4 attrs, #5 attrs, #6 attrs))
+                                                  (#1 attrs, SOME e, #3 attrs, #4 attrs, #5 attrs, #6 attrs, #7 attrs))
                                                | Style e =>
                                                  (case #3 attrs of
                                                       NONE => ()
                                                     | SOME _ => ErrorMsg.errorAt loc "Multiple styles specified for tag";
-                                                  (#1 attrs, #2 attrs, SOME e, #4 attrs, #5 attrs, #6 attrs))
+                                                  (#1 attrs, #2 attrs, SOME e, #4 attrs, #5 attrs, #6 attrs, #7 attrs))
                                                | DynStyle e =>
                                                  (case #4 attrs of
                                                       NONE => ()
                                                     | SOME _ => ErrorMsg.errorAt loc "Multiple dynamic classes specified for tag";
-                                                  (#1 attrs, #2 attrs, #3 attrs, SOME e, #5 attrs, #6 attrs))
+                                                  (#1 attrs, #2 attrs, #3 attrs, SOME e, #5 attrs, #6 attrs, #7 attrs))
                                                | Data xe =>
-                                                 (#1 attrs, #2 attrs, #3 attrs, #4 attrs, xe :: #5 attrs, #6 attrs)
+                                                 (#1 attrs, #2 attrs, #3 attrs, #4 attrs, #5 attrs, xe :: #6 attrs, #7 attrs)
                                                | Normal xe =>
-                                                 (#1 attrs, #2 attrs, #3 attrs, #4 attrs, #5 attrs, xe :: #6 attrs)
+                                                 (#1 attrs, #2 attrs, #3 attrs, #4 attrs, (case #1 (#1 xe) of
+                                                                                               CName "Id" => SOME (#2 xe)
+                                                                                             | _ => #5 attrs), #6 attrs, xe :: #7 attrs)
                                          end)
 
 attr   : SYMBOL EQ attrv                (case SYMBOL of
diff --git a/tests/formid.ur b/tests/formid.ur
new file mode 100644
index 00000000..c9e3317d
--- /dev/null
+++ b/tests/formid.ur
@@ -0,0 +1,9 @@
+fun handler () = return <xml></xml>
+
+fun main () : transaction page =
+    id <- fresh;
+    return <xml><body>
+      <form id={id}>
+        <submit action={handler}/>
+      </form>
+    </body></xml>
diff --git a/tests/formid.urs b/tests/formid.urs
new file mode 100644
index 00000000..6ac44e0b
--- /dev/null
+++ b/tests/formid.urs
@@ -0,0 +1 @@
+val main : unit -> transaction page