Ur/Web: src/urweb.grm comparison

comparison src/urweb.grm @ 2008:93ff76058825

HTML5 data-* attributes

author	Adam Chlipala <adam@chlipala.net>
date	Fri, 02 May 2014 15:32:10 -0400
parents	c3b03d099e04
children	799be3911ce3

comparison

equal deleted inserted replaced

-:d3a0f2b8af28
+:93ff76058825
 "table" => "tabl"
 | _ => bt
 datatype prop_kind = Delete | Update
-datatype attr = Class of exp | DynClass of exp | Style of exp | DynStyle of exp | Normal of con * exp
+datatype attr = Class of exp | DynClass of exp | Style of exp | DynStyle of exp | Normal of con * exp | Data of string * exp
 fun patType loc (p : pat) =
 case #1 p of
 PAnnot (_, t) => t
 | _ => (CWild (KType, loc), loc)
 | patS of pat
 | pterm of pat
 | rpat of (string * pat) list * bool
 | ptuple of pat list
-| attrs of exp option * exp option * exp option * exp option * (con * exp) list
+| attrs of exp option * exp option * exp option * exp option * (string * exp) list * (con * exp) list
 | attr of attr
 | attrv of exp
 | query of exp
 | query1 of exp
 val eo = case #4 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 (#5 attrs), pos)), pos)
+val atts = case #5 attrs of
+[] => #6 attrs
+| data :: datas =>
+let
+fun doOne (name, value) =
+let
+val e = (EVar (["Basis"], "data_attr", Infer), pos)
+val e = (EApp (e, (EPrim (Prim.String name), pos)), pos)
+in
+(EApp (e, value), pos)
+end
+val datas' = foldl (fn (nv, acc) =>
+let
+val e = (EVar (["Basis"], "data_attrs", Infer), pos)
+val e = (EApp (e, acc), pos)
+in
+(EApp (e, doOne nv), pos)
+end) (doOne data) datas
+in
+((CName "Data", pos), datas') :: #6 attrs
+end
+val e = (EApp (e, (ERecord atts, pos)), pos)
 val e = (EApp (e, (EApp (#2 tagHead,
 (ERecord [], pos)), pos)), pos)
 in
 (tagHead, #1 attrs, #2 attrs, e)
 end)
 (bt,
 (EVar ([], bt, Infer), pos))
 end)
 | tagHead LBRACE cexp RBRACE     (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright)))
-attrs  :                                (NONE, NONE, NONE, NONE, [])
+attrs  :                                (NONE, NONE, NONE, NONE, [], [])
 | attr attrs                     (let
 val loc = s (attrleft, attrsright)
 in
 case attr of
 Class e =>
 (case #1 attrs of
 NONE => ()
 | SOME _ => ErrorMsg.errorAt loc "Multiple classes specified for tag";
-(SOME e, #2 attrs, #3 attrs, #4 attrs, #5 attrs))
+(SOME e, #2 attrs, #3 attrs, #4 attrs, #5 attrs, #6 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))
+(#1 attrs, SOME e, #3 attrs, #4 attrs, #5 attrs, #6 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))
+(#1 attrs, #2 attrs, SOME e, #4 attrs, #5 attrs, #6 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))
+(#1 attrs, #2 attrs, #3 attrs, SOME e, #5 attrs, #6 attrs))
+| Data xe =>
+(#1 attrs, #2 attrs, #3 attrs, #4 attrs, xe :: #5 attrs, #6 attrs)
 | Normal xe =>
-(#1 attrs, #2 attrs, #3 attrs, #4 attrs, xe :: #5 attrs)
+(#1 attrs, #2 attrs, #3 attrs, #4 attrs, #5 attrs, xe :: #6 attrs)
 end)
 attr   : SYMBOL EQ attrv                (case SYMBOL of
 					     "class" => Class attrv
 					   | "dynClass" => DynClass attrv
 | "style" => Style attrv
 					   | "dynStyle" => DynStyle attrv
 					   | _ =>
-let
+if String.isPrefix "data-" SYMBOL then
-val sym = makeAttr SYMBOL
+Data (String.extract (SYMBOL, 5, NONE), attrv)
-in
+else
-Normal ((CName sym, s (SYMBOLleft, SYMBOLright)),
+let
-if (sym = "Href" orelse sym = "Src")
+val sym = makeAttr SYMBOL
-andalso (case #1 attrv of
+in
-EPrim _ => true
+Normal ((CName sym, s (SYMBOLleft, SYMBOLright)),
-| _ => false) then
+if (sym = "Href" orelse sym = "Src")
-let
+andalso (case #1 attrv of
-val loc = s (attrvleft, attrvright)
+EPrim _ => true
-in
+| _ => false) then
-(EApp ((EVar (["Basis"], "bless", Infer), loc),
+let
-attrv), loc)
+val loc = s (attrvleft, attrvright)
-end
+in
-else
+(EApp ((EVar (["Basis"], "bless", Infer), loc),
-attrv)
+attrv), loc)
-end)
+end
+else
+attrv)
+end)
 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))
 | LBRACE eexp RBRACE             (eexp)

Mercurial > urweb

comparison src/urweb.grm @ 2008:93ff76058825