changeset 104:b1e5398a7f30

Initial HTML attributes support
author Adam Chlipala <adamc@hcoop.net>
date Thu, 10 Jul 2008 15:04:32 -0400
parents 8921f0344193
children da760c34f5ed
files lib/basis.lig src/lacweb.grm src/lacweb.lex src/monoize.sml tests/attrs.lac
diffstat 5 files changed, 90 insertions(+), 31 deletions(-) [+]
line wrap: on
line diff
--- a/lib/basis.lig	Thu Jul 10 14:14:23 2008 -0400
+++ b/lib/basis.lig	Thu Jul 10 15:04:32 2008 -0400
@@ -3,13 +3,15 @@
 type string
 
 
-con tag :: {Unit} -> {Unit} -> Type
+con tag :: {Type} -> {Unit} -> {Unit} -> Type
 
 
 con xml :: {Unit} -> Type
 val cdata : ctx ::: {Unit} -> string -> xml ctx
-val tag : outer ::: {Unit} -> inner ::: {Unit}
-        -> tag outer inner
+val tag : attrsGiven ::: {Type} -> attrsAbsent ::: {Type} -> attrsGiven ~ attrsAbsent
+        -> outer ::: {Unit} -> inner ::: {Unit}
+        -> $attrsGiven
+        -> tag (attrsGiven ++ attrsAbsent) outer inner
         -> xml inner
         -> xml outer
 val join : shared :: {Unit}
@@ -18,10 +20,11 @@
         -> xml (shared ++ ctx1) -> xml (shared ++ ctx2) -> xml shared
 
 
-val head : tag [Html] [Head]
-val title : tag [Head] []
+val head : tag [] [Html] [Head]
+val title : tag [] [Head] []
 
-val body : tag [Html] [Body]
-val p : tag [Body] [Body]
-val b : tag [Body] [Body]
-val i : tag [Body] [Body]
+val body : tag [] [Html] [Body]
+val p : tag [] [Body] [Body]
+val b : tag [] [Body] [Body]
+val i : tag [] [Body] [Body]
+val font : tag [Size = int, Face = string] [Body] [Body]
--- a/src/lacweb.grm	Thu Jul 10 14:14:23 2008 -0400
+++ b/src/lacweb.grm	Thu Jul 10 15:04:32 2008 -0400
@@ -31,6 +31,9 @@
 
 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 @@
  | 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 @@
 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 @@
                                                   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))
--- a/src/lacweb.lex	Thu Jul 10 14:14:23 2008 -0400
+++ b/src/lacweb.lex	Thu Jul 10 15:04:32 2008 -0400
@@ -143,7 +143,10 @@
 
 <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 @@
                                        continue ()));
 <XMLTAG> "\""         => (YYBEGIN STRING;
 			  xmlString := true;
-			  strStart := yypos; str := []; continue());
+			  strStart := yypos; str := []; continue ());
 
 <XMLTAG> "{"          => (YYBEGIN INITIAL;
 			  pushLevel (fn () => YYBEGIN XMLTAG);
--- a/src/monoize.sml	Thu Jul 10 14:14:23 2008 -0400
+++ b/src/monoize.sml	Thu Jul 10 15:04:32 2008 -0400
@@ -109,11 +109,14 @@
 
           | 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 @@
 
                 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 ()
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/attrs.lac	Thu Jul 10 15:04:32 2008 -0400
@@ -0,0 +1,5 @@
+val main = fn () => <html><body>
+        <font face="awesome">Welcome</font>
+</body></html>
+
+page main