From 54eac9ca9c3e3979003d95a58ffb7f1289877b2b Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Sun, 23 Jan 2011 11:18:24 -0500
Subject: Allow CSS class specification for <form>

---
 src/monoize.sml | 22 ++++++++++++++++++----
 src/urweb.grm   | 18 ++++++++++++------
 2 files changed, 30 insertions(+), 10 deletions(-)

(limited to 'src')

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
-- 
cgit v1.2.3