summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--lib/ur/basis.urs3
-rw-r--r--src/monoize.sml22
-rw-r--r--src/urweb.grm18
3 files changed, 32 insertions, 11 deletions
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 8ca2e81c..fe3f0635 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -710,7 +710,8 @@ val img : bodyTag ([Src = url, Width = int, Height = int,
val form : ctx ::: {Unit} -> bind ::: {Type}
-> [[Body, Form, Table] ~ ctx] =>
- xml ([Body, Form] ++ ctx) [] bind
+ option css_class
+ -> xml ([Body, Form] ++ ctx) [] bind
-> xml ([Body] ++ ctx) [] []
val subform : ctx ::: {Unit} -> use ::: {Type} -> bind ::: {Type}
diff --git a/src/monoize.sml b/src/monoize.sml
index e7354e98..25594e1f 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -3390,10 +3390,12 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
| _ => normal (tag, NONE, NONE))
end
- | L.EApp ((L.ECApp (
- (L.ECApp ((L.EFfi ("Basis", "form"), _), _), _),
- (L.CRecord (_, fields), _)), _),
- xml) =>
+ | L.EApp (
+ (L.EApp ((L.ECApp (
+ (L.ECApp ((L.EFfi ("Basis", "form"), _), _), _),
+ (L.CRecord (_, fields), _)), _),
+ class), _),
+ xml) =>
let
fun findSubmit (e, _) =
case e of
@@ -3518,6 +3520,18 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
else
action
+ val stt = (L'.TFfi ("Basis", "string"), loc)
+ val (class, fm) = monoExp (env, st, fm) class
+ val action = (L'.EStrcat (action,
+ (L'.ECase (class,
+ [((L'.PNone stt, loc),
+ (L'.EPrim (Prim.String ""), loc)),
+ ((L'.PSome (stt, (L'.PVar ("x", stt), loc)), loc),
+ (L'.EStrcat ((L'.EPrim (Prim.String " class=\""), loc),
+ (L'.EStrcat ((L'.ERel 0, loc),
+ (L'.EPrim (Prim.String "\""), loc)), loc)), loc))],
+ {disc = (L'.TOption stt, loc),
+ result = stt}), loc)), loc)
in
((L'.EStrcat ((L'.EStrcat ((L'.EPrim (Prim.String "<form method=\"post\""), loc),
(L'.EStrcat (action,
diff --git a/src/urweb.grm b/src/urweb.grm
index 37bddef7..75599235 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -311,7 +311,7 @@ fun tnamesOf (e, _) =
| xml of exp
| xmlOne of exp
| xmlOpt of exp
- | tag of (string * exp) * exp
+ | tag of (string * exp) * exp option * exp
| tagHead of string * exp
| bind of string * con option * exp
| edecl of edecl
@@ -1383,7 +1383,7 @@ xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer)
(EPrim (Prim.String ""), pos)),
pos)
in
- (EApp (#2 tag, cdata), pos)
+ (EApp (#3 tag, cdata), pos)
end)
| tag GT xmlOpt END_TAG (let
@@ -1392,8 +1392,14 @@ xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer)
in
if #1 (#1 tag) = et then
if et = "form" then
- (EApp ((EVar (["Basis"], "form", Infer), pos),
- xmlOpt), pos)
+ let
+ val e = (EVar (["Basis"], "form", Infer), pos)
+ val e = (EApp (e, case #2 tag of
+ NONE => (EVar (["Basis"], "None", Infer), pos)
+ | SOME c => (EApp ((EVar (["Basis"], "Some", Infer), pos), c), pos)), pos)
+ in
+ (EApp (e, xmlOpt), pos)
+ end
else if et = "subform" orelse et = "subforms" then
(EApp (#2 (#1 tag),
xmlOpt), pos)
@@ -1401,7 +1407,7 @@ xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer)
(EApp ((EVar (["Basis"], "entry", Infer), pos),
xmlOpt), pos)
else
- (EApp (#2 tag, xmlOpt), pos)
+ (EApp (#3 tag, xmlOpt), pos)
else
(if ErrorMsg.anyErrors () then
()
@@ -1434,7 +1440,7 @@ tag : tagHead attrs (let
val e = (EApp (e, (EApp (#2 tagHead,
(ERecord [], pos)), pos)), pos)
in
- (tagHead, e)
+ (tagHead, #1 attrs, e)
end)
tagHead: BEGIN_TAG (let