summaryrefslogtreecommitdiff
path: root/src/urweb.grm
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adam@chlipala.net>2011-12-27 16:20:48 -0500
committerGravatar Adam Chlipala <adam@chlipala.net>2011-12-27 16:20:48 -0500
commit7da813265f0601380cdc23e5f89b01dd187a4458 (patch)
treeb79292fd3c487498c7837ad6008636a1ed5163cf /src/urweb.grm
parent0bd86cec8a712d19d4378d84584c7d0ba4e5a7af (diff)
'dynClass' pseudo-attribute
Diffstat (limited to 'src/urweb.grm')
-rw-r--r--src/urweb.grm42
1 files changed, 28 insertions, 14 deletions
diff --git a/src/urweb.grm b/src/urweb.grm
index 22616c79..167e841d 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008-2010, Adam Chlipala
+(* Copyright (c) 2008-2011, Adam Chlipala
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
@@ -219,7 +219,7 @@ fun tagIn bt =
datatype prop_kind = Delete | Update
-datatype attr = Class of exp | Normal of con * exp
+datatype attr = Class of exp | DynClass of exp | Normal of con * exp
fun patType loc (p : pat) =
case #1 p of
@@ -355,7 +355,7 @@ fun tnamesOf (e, _) =
| xml of exp
| xmlOne of exp
| xmlOpt of exp
- | tag of (string * exp) * exp option * exp
+ | tag of (string * exp) * exp option * exp option * exp
| tagHead of string * exp
| bind of string * con option * exp
| edecl of edecl
@@ -376,7 +376,7 @@ fun tnamesOf (e, _) =
| rpat of (string * pat) list * bool
| ptuple of pat list
- | attrs of exp option * (con * exp) list
+ | attrs of exp option * exp option * (con * exp) list
| attr of attr
| attrv of exp
@@ -1442,7 +1442,7 @@ xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer)
(EPrim (Prim.String ""), pos)),
pos)
in
- (EApp (#3 tag, cdata), pos)
+ (EApp (#4 tag, cdata), pos)
end)
| tag GT xmlOpt END_TAG (let
@@ -1461,6 +1461,9 @@ xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer)
val e = (EApp (e, case #2 tag of
NONE => (EVar (["Basis"], "None", Infer), pos)
| SOME c => (EApp ((EVar (["Basis"], "Some", Infer), pos), c), pos)), pos)
+ val e = (EApp (e, case #3 tag of
+ NONE => (EVar (["Basis"], "None", Infer), pos)
+ | SOME c => (EApp ((EVar (["Basis"], "Some", Infer), pos), c), pos)), pos)
in
(EApp (e, xmlOpt), pos)
end
@@ -1471,7 +1474,7 @@ xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer)
(EApp ((EVar (["Basis"], "entry", Infer), pos),
xmlOpt), pos)
else
- (EApp (#3 tag, xmlOpt), pos)
+ (EApp (#4 tag, xmlOpt), pos)
else
(if ErrorMsg.anyErrors () then
()
@@ -1500,11 +1503,16 @@ tag : tagHead attrs (let
| SOME e => (EApp ((EVar (["Basis"], "Some", Infer), pos),
e), pos)
val e = (EApp (e, eo), pos)
- val e = (EApp (e, (ERecord (#2 attrs), pos)), pos)
+ val eo = case #2 attrs of
+ NONE => (EVar (["Basis"], "None", Infer), pos)
+ | SOME e => (EApp ((EVar (["Basis"], "Some", Infer), pos),
+ e), pos)
+ val e = (EApp (e, eo), pos)
+ val e = (EApp (e, (ERecord (#3 attrs), pos)), pos)
val e = (EApp (e, (EApp (#2 tagHead,
(ERecord [], pos)), pos)), pos)
in
- (tagHead, #1 attrs, e)
+ (tagHead, #1 attrs, #2 attrs, e)
end)
tagHead: BEGIN_TAG (let
@@ -1516,7 +1524,7 @@ tagHead: BEGIN_TAG (let
end)
| tagHead LBRACE cexp RBRACE (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright)))
-attrs : (NONE, [])
+attrs : (NONE, NONE, [])
| attr attrs (let
val loc = s (attrleft, attrsright)
in
@@ -1525,14 +1533,20 @@ attrs : (NONE, [])
(case #1 attrs of
NONE => ()
| SOME _ => ErrorMsg.errorAt loc "Multiple classes specified for tag";
- (SOME e, #2 attrs))
+ (SOME e, #2 attrs, #3 attrs))
+ | DynClass e =>
+ (case #2 attrs of
+ NONE => ()
+ | SOME _ => ErrorMsg.errorAt loc "Multiple dynamic classes specified for tag";
+ (#1 attrs, SOME e, #3 attrs))
| Normal xe =>
- (#1 attrs, xe :: #2 attrs)
+ (#1 attrs, #2 attrs, xe :: #3 attrs)
end)
-attr : SYMBOL EQ attrv (if SYMBOL = "class" then
- Class attrv
- else
+attr : SYMBOL EQ attrv (case SYMBOL of
+ "class" => Class attrv
+ | "dynClass" => DynClass attrv
+ | _ =>
let
val sym =
case SYMBOL of