Initial HTML attributes support

3 files changed, 73 insertions, 22 deletions

diff --git a/src/lacweb.grm b/src/lacweb.grm
index 811876f2..6e71721f 100644
--- a/src/lacweb.grm
+++ b/src/lacweb.grm
@@ -31,6 +31,9 @@ open Source
 
 val s = ErrorMsg.spanOf
 
+fun uppercaseFirst "" = ""
+  | uppercaseFirst s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
+
 %%
 %header (functor LacwebLrValsFn(structure Token : TOKEN))
 
@@ -86,6 +89,10 @@ val s = ErrorMsg.spanOf
  | xml of exp
  | xmlOne of exp
 
+ | attrs of (con * exp) list
+ | attr of con * exp
+ | attrv of exp
+
 %verbose                                (* print summary of errors *)
 %pos int                                (* positions *)
 %start file
@@ -304,10 +311,11 @@ xml    : xmlOne xml                  (let
 xmlOne : NOTAGS                      (EApp ((EVar (["Basis"], "cdata"), s (NOTAGSleft, NOTAGSright)),
                                             (EPrim (Prim.String NOTAGS), s (NOTAGSleft, NOTAGSright))),
                                       s (NOTAGSleft, NOTAGSright))
-       | BEGIN_TAG DIVIDE GT         (let
+       | BEGIN_TAG attrs DIVIDE GT   (let
                                           val pos = s (BEGIN_TAGleft, GTright)
                                       in
-                                          (EApp ((EApp ((EVar (["Basis"], "tag"), pos),
+                                          (EApp ((EApp ((EApp ((EVar (["Basis"], "tag"), pos),
+                                                               (ERecord attrs, pos)), pos),
                                                         (EVar ([], BEGIN_TAG), pos)),
                                                   pos),
                                                  (EApp ((EVar (["Basis"], "cdata"), pos),
@@ -315,16 +323,25 @@ xmlOne : NOTAGS                      (EApp ((EVar (["Basis"], "cdata"), s (NOTAG
                                                   pos)), pos)
                                       end)
 
-       | BEGIN_TAG GT xml END_TAG    (let
-                                          val pos = s (BEGIN_TAGleft, GTright)
-                                      in
-                                          if BEGIN_TAG = END_TAG then
-                                              (EApp ((EApp ((EVar (["Basis"], "tag"), pos),
-                                                            (EVar ([], BEGIN_TAG), pos)),
-                                                      pos),
-                                                     xml), pos)
-                                          else
-                                              (ErrorMsg.errorAt pos "Begin and end tags don't match.";
-                                               (EFold, pos))
-                                      end)
+       | BEGIN_TAG attrs GT xml END_TAG(let
+                                            val pos = s (BEGIN_TAGleft, GTright)
+                                        in
+                                            if BEGIN_TAG = END_TAG then
+                                                (EApp ((EApp ((EApp ((EVar (["Basis"], "tag"), pos),
+                                                                     (ERecord attrs, pos)), pos),
+                                                              (EVar ([], BEGIN_TAG), pos)),
+                                                        pos),
+                                                       xml), pos)
+                                            else
+                                                (ErrorMsg.errorAt pos "Begin and end tags don't match.";
+                                                 (EFold, pos))
+                                        end)
                                           
+attrs  :                                ([])
+       | attr attrs                     (attr :: attrs)
+
+attr   : SYMBOL EQ attrv                ((CName (uppercaseFirst SYMBOL), s (SYMBOLleft, SYMBOLright)), attrv)
+
+attrv  : INT                            (EPrim (Prim.Int INT), s (INTleft, INTright))
+       | FLOAT                          (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright))
+       | STRING                         (EPrim (Prim.String STRING), s (STRINGleft, STRINGright))
diff --git a/src/lacweb.lex b/src/lacweb.lex
index 8a57dba9..4856bdf2 100644
--- a/src/lacweb.lex
+++ b/src/lacweb.lex
@@ -143,7 +143,10 @@ notags = [^<{\n]+;
 
 <INITIAL> "\""        => (YYBEGIN STRING; strStart := pos yypos; str := []; continue());
 <STRING> "\\\""       => (str := #"\"" :: !str; continue());
-<STRING> "\""         => (YYBEGIN INITIAL;
+<STRING> "\""         => (if !xmlString then
+			  (xmlString := false; YYBEGIN XMLTAG)
+			  else
+			  YYBEGIN INITIAL;
 			  Tokens.STRING (String.implode (List.rev (!str)), !strStart, pos yypos + 1));
 <STRING> "\n"         => (newline yypos;
 			  str := #"\n" :: !str; continue());
@@ -196,7 +199,7 @@ notags = [^<{\n]+;
                                        continue ()));
 <XMLTAG> "\""         => (YYBEGIN STRING;
 			  xmlString := true;
-			  strStart := yypos; str := []; continue());
+			  strStart := yypos; str := []; continue ());
 
 <XMLTAG> "{"          => (YYBEGIN INITIAL;
 			  pushLevel (fn () => YYBEGIN XMLTAG);
diff --git a/src/monoize.sml b/src/monoize.sml
index 51044783..ab344a16 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -109,11 +109,14 @@ fun monoExp env (all as (e, loc)) =
 
           | L.EApp (
             (L.EApp (
-             (L.ECApp (
+             (L.EApp (
               (L.ECApp (
-               (L.EFfi ("Basis", "tag"),
-                _), _), _),
-              _), _),
+               (L.ECApp (
+                (L.ECApp (
+                 (L.ECApp (
+                  (L.EFfi ("Basis", "tag"),
+                   _), _), _), _), _), _), _), _), _),
+              attrs), _),
              tag), _),
             xml) =>
             let
@@ -126,17 +129,45 @@ fun monoExp env (all as (e, loc)) =
 
                 val tag = getTag tag
 
+                val attrs = monoExp env attrs
+
+                val tagStart =
+                    case #1 attrs of
+                        L'.ERecord xes =>
+                        let
+                            fun lowercaseFirst "" = ""
+                              | 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
+                            foldl (fn ((x, e, _), s) =>
+                                      let
+                                          val xp = " " ^ lowercaseFirst x ^ "=\""
+                                      in
+                                          (L'.EStrcat (s,
+                                                       (L'.EStrcat ((L'.EPrim (Prim.String xp), loc),
+                                                                    (L'.EStrcat (e,
+                                                                                 (L'.EPrim (Prim.String "\""), loc)),
+                                                                     loc)),
+                                                        loc)), loc)
+                                      end)
+                            s xes
+                        end
+                      | _ => raise Fail "Attributes!"
+
                 fun normal () =
-                    (L'.EStrcat ((L'.EPrim (Prim.String (String.concat ["<", tag, ">"])), loc),
+                    (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.EFfi ("Basis", "cdata"), _),
                                        _), _), (L.EPrim (Prim.String s), _)), _) =>
                     if CharVector.all Char.isSpace s then
-                        (L'.EPrim (Prim.String (String.concat ["<", tag, "/>"])), loc)
+                        (L'.EStrcat (tagStart, (L'.EPrim (Prim.String "/>"), loc)), loc)
                     else
                         normal ()
                   | _ => normal ()