Mercurial > urweb
comparison src/urweb.grm @ 1750:277480862cef
'style' attributes
author | Adam Chlipala <adam@chlipala.net> |
---|---|
date | Sun, 06 May 2012 14:01:29 -0400 |
parents | f9e5a8e09cdf |
children | acadf9d1214a |
comparison
equal
deleted
inserted
replaced
1749:f9e5a8e09cdf | 1750:277480862cef |
---|---|
217 "table" => "tabl" | 217 "table" => "tabl" |
218 | _ => bt | 218 | _ => bt |
219 | 219 |
220 datatype prop_kind = Delete | Update | 220 datatype prop_kind = Delete | Update |
221 | 221 |
222 datatype attr = Class of exp | DynClass of exp | Normal of con * exp | 222 datatype attr = Class of exp | DynClass of exp | Style of exp | Normal of con * exp |
223 | 223 |
224 fun patType loc (p : pat) = | 224 fun patType loc (p : pat) = |
225 case #1 p of | 225 case #1 p of |
226 PAnnot (_, t) => t | 226 PAnnot (_, t) => t |
227 | _ => (CWild (KType, loc), loc) | 227 | _ => (CWild (KType, loc), loc) |
253 [] => (EVar (["Basis"], "null", Infer), pos) | 253 [] => (EVar (["Basis"], "null", Infer), pos) |
254 | class :: classes => | 254 | class :: classes => |
255 foldl (fn (s, e) => (EApp ((EApp ((EVar (["Basis"], "classes", Infer), pos), e), pos), classOut (s, pos)), pos)) | 255 foldl (fn (s, e) => (EApp ((EApp ((EVar (["Basis"], "classes", Infer), pos), e), pos), classOut (s, pos)), pos)) |
256 (classOut (class, pos)) classes | 256 (classOut (class, pos)) classes |
257 | 257 |
258 fun parseValue s pos = | |
259 if String.isPrefix "url(" s andalso String.isSuffix ")" s then | |
260 let | |
261 val s = String.substring (s, 4, size s - 5) | |
262 | |
263 val s = if size s >= 2 | |
264 andalso ((String.isPrefix "\"" s andalso String.isSuffix "\"" s) | |
265 orelse (String.isPrefix "'" s andalso String.isSuffix "'" s)) then | |
266 String.substring (s, 1, size s - 2) | |
267 else | |
268 s | |
269 in | |
270 (EApp ((EVar (["Basis"], "css_url", Infer), pos), | |
271 (EApp ((EVar (["Basis"], "bless", Infer), pos), | |
272 (EPrim (Prim.String s), pos)), pos)), pos) | |
273 end | |
274 else | |
275 (EApp ((EVar (["Basis"], "atom", Infer), pos), | |
276 (EPrim (Prim.String s), pos)), pos) | |
277 | |
278 fun parseProperty s pos = | |
279 let | |
280 val (befor, after) = Substring.splitl (fn ch => ch <> #":") (Substring.full s) | |
281 in | |
282 if Substring.isEmpty after then | |
283 (ErrorMsg.errorAt pos ("Invalid CSS property syntax: " ^ s); | |
284 (EPrim (Prim.String ""), pos)) | |
285 else | |
286 foldl (fn (value, e) => (EApp ((EApp ((EVar (["Basis"], "value", Infer), pos), e), pos), parseValue value pos), pos)) | |
287 (EApp ((EVar (["Basis"], "property", Infer), pos), | |
288 (EPrim (Prim.String (Substring.string (#2 (Substring.splitl Char.isSpace befor)))), pos)), pos) | |
289 (String.tokens Char.isSpace (Substring.string (Substring.slice (after, 1, NONE)))) | |
290 end | |
291 | |
292 fun parseStyle s pos = | |
293 case String.tokens (fn ch => ch = #";") s of | |
294 [] => (EVar (["Basis"], "noStyle", Infer), pos) | |
295 | props => | |
296 foldl (fn (s, e) => (EApp ((EApp ((EVar (["Basis"], "oneProperty", Infer), pos), e), pos), parseProperty s pos), pos)) | |
297 (EVar (["Basis"], "noStyle", Infer), pos) props | |
298 | |
258 %% | 299 %% |
259 %header (functor UrwebLrValsFn(structure Token : TOKEN)) | 300 %header (functor UrwebLrValsFn(structure Token : TOKEN)) |
260 | 301 |
261 %term | 302 %term |
262 EOF | 303 EOF |
384 | patS of pat | 425 | patS of pat |
385 | pterm of pat | 426 | pterm of pat |
386 | rpat of (string * pat) list * bool | 427 | rpat of (string * pat) list * bool |
387 | ptuple of pat list | 428 | ptuple of pat list |
388 | 429 |
389 | attrs of exp option * exp option * (con * exp) list | 430 | attrs of exp option * exp option * exp option * (con * exp) list |
390 | attr of attr | 431 | attr of attr |
391 | attrv of exp | 432 | attrv of exp |
392 | 433 |
393 | query of exp | 434 | query of exp |
394 | query1 of exp | 435 | query1 of exp |
1537 val eo = case #2 attrs of | 1578 val eo = case #2 attrs of |
1538 NONE => (EVar (["Basis"], "None", Infer), pos) | 1579 NONE => (EVar (["Basis"], "None", Infer), pos) |
1539 | SOME e => (EApp ((EVar (["Basis"], "Some", Infer), pos), | 1580 | SOME e => (EApp ((EVar (["Basis"], "Some", Infer), pos), |
1540 e), pos) | 1581 e), pos) |
1541 val e = (EApp (e, eo), pos) | 1582 val e = (EApp (e, eo), pos) |
1542 val e = (EApp (e, (ERecord (#3 attrs), pos)), pos) | 1583 val eo = case #3 attrs of |
1584 NONE => (EVar (["Basis"], "noStyle", Infer), pos) | |
1585 | SOME (EPrim (Prim.String s), pos) => parseStyle s pos | |
1586 | SOME e => e | |
1587 val e = (EApp (e, eo), pos) | |
1588 val e = (EApp (e, (ERecord (#4 attrs), pos)), pos) | |
1543 val e = (EApp (e, (EApp (#2 tagHead, | 1589 val e = (EApp (e, (EApp (#2 tagHead, |
1544 (ERecord [], pos)), pos)), pos) | 1590 (ERecord [], pos)), pos)), pos) |
1545 in | 1591 in |
1546 (tagHead, #1 attrs, #2 attrs, e) | 1592 (tagHead, #1 attrs, #2 attrs, e) |
1547 end) | 1593 end) |
1553 (bt, | 1599 (bt, |
1554 (EVar (["Basis"], bt, Infer), pos)) | 1600 (EVar (["Basis"], bt, Infer), pos)) |
1555 end) | 1601 end) |
1556 | tagHead LBRACE cexp RBRACE (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright))) | 1602 | tagHead LBRACE cexp RBRACE (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright))) |
1557 | 1603 |
1558 attrs : (NONE, NONE, []) | 1604 attrs : (NONE, NONE, NONE, []) |
1559 | attr attrs (let | 1605 | attr attrs (let |
1560 val loc = s (attrleft, attrsright) | 1606 val loc = s (attrleft, attrsright) |
1561 in | 1607 in |
1562 case attr of | 1608 case attr of |
1563 Class e => | 1609 Class e => |
1564 (case #1 attrs of | 1610 (case #1 attrs of |
1565 NONE => () | 1611 NONE => () |
1566 | SOME _ => ErrorMsg.errorAt loc "Multiple classes specified for tag"; | 1612 | SOME _ => ErrorMsg.errorAt loc "Multiple classes specified for tag"; |
1567 (SOME e, #2 attrs, #3 attrs)) | 1613 (SOME e, #2 attrs, #3 attrs, #4 attrs)) |
1568 | DynClass e => | 1614 | DynClass e => |
1569 (case #2 attrs of | 1615 (case #2 attrs of |
1570 NONE => () | 1616 NONE => () |
1571 | SOME _ => ErrorMsg.errorAt loc "Multiple dynamic classes specified for tag"; | 1617 | SOME _ => ErrorMsg.errorAt loc "Multiple dynamic classes specified for tag"; |
1572 (#1 attrs, SOME e, #3 attrs)) | 1618 (#1 attrs, SOME e, #3 attrs, #4 attrs)) |
1619 | Style e => | |
1620 (case #3 attrs of | |
1621 NONE => () | |
1622 | SOME _ => ErrorMsg.errorAt loc "Multiple styles specified for tag"; | |
1623 (#1 attrs, #2 attrs, SOME e, #4 attrs)) | |
1573 | Normal xe => | 1624 | Normal xe => |
1574 (#1 attrs, #2 attrs, xe :: #3 attrs) | 1625 (#1 attrs, #2 attrs, #3 attrs, xe :: #4 attrs) |
1575 end) | 1626 end) |
1576 | 1627 |
1577 attr : SYMBOL EQ attrv (case SYMBOL of | 1628 attr : SYMBOL EQ attrv (case SYMBOL of |
1578 "class" => Class attrv | 1629 "class" => Class attrv |
1579 | "dynClass" => DynClass attrv | 1630 | "dynClass" => DynClass attrv |
1631 | "style" => Style attrv | |
1580 | _ => | 1632 | _ => |
1581 let | 1633 let |
1582 val sym = | 1634 val sym = |
1583 case SYMBOL of | 1635 case SYMBOL of |
1584 "type" => "Typ" | 1636 "type" => "Typ" |