diff options
Diffstat (limited to 'src/urweb.grm')
-rw-r--r-- | src/urweb.grm | 55 |
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 |