diff options
Diffstat (limited to 'src')
-rw-r--r-- | src/lacweb.grm | 45 | ||||
-rw-r--r-- | src/lacweb.lex | 7 | ||||
-rw-r--r-- | src/monoize.sml | 43 |
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 () |