summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/basis.lig21
-rw-r--r--src/lacweb.grm45
-rw-r--r--src/lacweb.lex7
-rw-r--r--src/monoize.sml43
-rw-r--r--tests/attrs.lac5
5 files changed, 90 insertions, 31 deletions
diff --git a/lib/basis.lig b/lib/basis.lig
index 49549f5e..cd106950 100644
--- a/lib/basis.lig
+++ b/lib/basis.lig
@@ -3,13 +3,15 @@ type float
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 @@ val join : shared :: {Unit}
-> 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]
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 ()
diff --git a/tests/attrs.lac b/tests/attrs.lac
new file mode 100644
index 00000000..0495c4eb
--- /dev/null
+++ b/tests/attrs.lac
@@ -0,0 +1,5 @@
+val main = fn () => <html><body>
+ <font face="awesome">Welcome</font>
+</body></html>
+
+page main
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-05 10:02:16 +0000