summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adam@chlipala.net>2016-12-31 15:54:06 -0500
committerGravatar Adam Chlipala <adam@chlipala.net>2016-12-31 15:54:06 -0500
commit923cc0fcad46eae0a00f7d5c8ea39e627b1aaa57 (patch)
treeb1cc7a27167772b2c601b4bac8b740ea152369b5
parent10c0bc3c889568717ce97b6d3bda000b3fd46227 (diff)
Use 'id' attribute for <form>
-rw-r--r--lib/ur/basis.urs3
-rw-r--r--src/monoize.sml21
-rw-r--r--src/urweb.grm35
-rw-r--r--tests/formid.ur9
-rw-r--r--tests/formid.urs1
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