summaryrefslogtreecommitdiff
path: root/src/urweb.grm
diff options
context:
space:
mode:
Diffstat (limited to 'src/urweb.grm')
-rw-r--r--src/urweb.grm55
1 files changed, 32 insertions, 23 deletions
diff --git a/src/urweb.grm b/src/urweb.grm
index 40101056..db5473a6 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -475,10 +475,11 @@ fun patternOut (e : exp) =
| eterm of exp
| etuple of exp list
| rexp of (con * exp) list * bool
+ | rpath of con
| xml of exp
| xmlOne of exp
| xmlOpt of exp
- | tag of (string * exp) * exp option * exp option * exp
+ | tag of (string * exp) * exp option * exp option * exp option * exp
| tagHead of string * exp
| bind of pat * con option * exp
| edecl of edecl
@@ -499,7 +500,7 @@ fun patternOut (e : exp) =
| rpat of (string * pat) list * bool
| ptuple of pat list
- | attrs of exp option * exp option * exp option * exp option * (string * string * exp) list * (con * exp) list
+ | attrs of exp option * exp option * exp option * exp option * exp option * (string * string * exp) list * (con * exp) list
| attr of attr
| attrv of exp
@@ -1151,15 +1152,15 @@ ctuple : capps STAR capps ([capps1, capps2])
| capps STAR ctuple (capps :: ctuple)
rcon : ([])
- | ident EQ cexp ([(ident, cexp)])
- | ident EQ cexp COMMA rcon ((ident, cexp) :: rcon)
+ | rpath EQ cexp ([(rpath, cexp)])
+ | rpath EQ cexp COMMA rcon ((rpath, cexp) :: rcon)
-rconn : ident ([(ident, (CUnit, s (identleft, identright)))])
- | ident COMMA rconn ((ident, (CUnit, s (identleft, identright))) :: rconn)
+rconn : rpath ([(rpath, (CUnit, s (rpathleft, rpathright)))])
+ | rpath COMMA rconn ((rpath, (CUnit, s (rpathleft, rpathright))) :: rconn)
rcone : ([])
- | ident COLON cexp ([(ident, cexp)])
- | ident COLON cexp COMMA rcone ((ident, cexp) :: rcone)
+ | rpath COLON cexp ([(rpath, cexp)])
+ | rpath COLON cexp COMMA rcone ((rpath, cexp) :: rcone)
ident : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
| INT (CName (Int64.toString INT), s (INTleft, INTright))
@@ -1567,8 +1568,11 @@ ptuple : pat COMMA pat ([pat1, pat2])
| pat COMMA ptuple (pat :: ptuple)
rexp : DOTDOTDOT ([], true)
- | ident EQ eexp ([(ident, eexp)], false)
- | ident EQ eexp COMMA rexp ((ident, eexp) :: #1 rexp, #2 rexp)
+ | rpath EQ eexp ([(rpath, eexp)], false)
+ | rpath EQ eexp COMMA rexp ((rpath, eexp) :: #1 rexp, #2 rexp)
+
+rpath : path (CVar path, s (pathleft, pathright))
+ | CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
xml : xmlOne xml (let
val pos = s (xmlOneleft, xmlright)
@@ -1606,7 +1610,7 @@ xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer)
(EPrim (Prim.String (Prim.Html, "")), pos)),
pos)
in
- (EApp (#4 tag, cdata), pos)
+ (EApp (#5 tag, cdata), pos)
end)
| tag GT xmlOpt END_TAG (let
@@ -1622,6 +1626,9 @@ xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer)
if et = "form" then
let
val e = (EVar (["Basis"], "form", Infer), pos)
+ val e = (EApp (e, case #4 tag of
+ NONE => (EVar (["Basis"], "None", Infer), pos)
+ | SOME c => (EApp ((EVar (["Basis"], "Some", Infer), pos), c), pos)), pos)
val e = (EApp (e, case #2 tag of
NONE => (EVar (["Basis"], "None", Infer), pos)
| SOME (EPrim (Prim.String (_, s)), _) => (EApp ((EVar (["Basis"], "Some", Infer), pos), parseClass s pos), pos)
@@ -1639,7 +1646,7 @@ xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer)
(EApp ((EVar (["Basis"], "entry", Infer), pos),
xmlOpt), pos)
else
- (EApp (#4 tag, xmlOpt), pos)
+ (EApp (#5 tag, xmlOpt), pos)
else
(if ErrorMsg.anyErrors () then
()
@@ -1684,8 +1691,8 @@ tag : tagHead attrs (let
e), pos)
val e = (EApp (e, eo), pos)
- val atts = case #5 attrs of
- [] => #6 attrs
+ val atts = case #6 attrs of
+ [] => #7 attrs
| data :: datas =>
let
fun doOne (kind, name, value) =
@@ -1705,14 +1712,14 @@ tag : tagHead attrs (let
(EApp (e, doOne nv), pos)
end) (doOne data) datas
in
- ((CName "Data", pos), datas') :: #6 attrs
+ ((CName "Data", pos), datas') :: #7 attrs
end
val e = (EApp (e, (ERecord (atts, false), pos)), pos)
val e = (EApp (e, (EApp (#2 tagHead,
(ERecord ([], false), pos)), pos)), pos)
in
- (tagHead, #1 attrs, #2 attrs, e)
+ (tagHead, #1 attrs, #2 attrs, #5 attrs, e)
end)
tagHead: BEGIN_TAG (let
@@ -1724,7 +1731,7 @@ tagHead: BEGIN_TAG (let
end)
| tagHead LBRACE cexp RBRACE (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright)))
-attrs : (NONE, NONE, NONE, NONE, [], [])
+attrs : (NONE, NONE, NONE, NONE, NONE, [], [])
| attr attrs (let
val loc = s (attrleft, attrsright)
in
@@ -1733,26 +1740,28 @@ attrs : (NONE, NONE, NONE, NONE, [], [])
(case #1 attrs of
NONE => ()
| SOME _ => ErrorMsg.errorAt loc "Multiple classes specified for tag";
- (SOME e, #2 attrs, #3 attrs, #4 attrs, #5 attrs, #6 attrs))
+ (SOME e, #2 attrs, #3 attrs, #4 attrs, #5 attrs, #6 attrs, #7 attrs))
| DynClass e =>
(case #2 attrs of
NONE => ()
| SOME _ => ErrorMsg.errorAt loc "Multiple dynamic classes specified for tag";
- (#1 attrs, SOME e, #3 attrs, #4 attrs, #5 attrs, #6 attrs))
+ (#1 attrs, SOME e, #3 attrs, #4 attrs, #5 attrs, #6 attrs, #7 attrs))
| Style e =>
(case #3 attrs of
NONE => ()
| SOME _ => ErrorMsg.errorAt loc "Multiple styles specified for tag";
- (#1 attrs, #2 attrs, SOME e, #4 attrs, #5 attrs, #6 attrs))
+ (#1 attrs, #2 attrs, SOME e, #4 attrs, #5 attrs, #6 attrs, #7 attrs))
| DynStyle e =>
(case #4 attrs of
NONE => ()
| SOME _ => ErrorMsg.errorAt loc "Multiple dynamic classes specified for tag";
- (#1 attrs, #2 attrs, #3 attrs, SOME e, #5 attrs, #6 attrs))
+ (#1 attrs, #2 attrs, #3 attrs, SOME e, #5 attrs, #6 attrs, #7 attrs))
| Data xe =>
- (#1 attrs, #2 attrs, #3 attrs, #4 attrs, xe :: #5 attrs, #6 attrs)
+ (#1 attrs, #2 attrs, #3 attrs, #4 attrs, #5 attrs, xe :: #6 attrs, #7 attrs)
| Normal xe =>
- (#1 attrs, #2 attrs, #3 attrs, #4 attrs, #5 attrs, xe :: #6 attrs)
+ (#1 attrs, #2 attrs, #3 attrs, #4 attrs, (case #1 (#1 xe) of
+ CName "Id" => SOME (#2 xe)
+ | _ => #5 attrs), #6 attrs, xe :: #7 attrs)
end)
attr : SYMBOL EQ attrv (case SYMBOL of
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-01 02:15:09 +0000