Mercurial > urweb
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 ()