Mercurial > urweb

comparison src/urweb.grm @ 1751:acadf9d1214a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
'dynStyle' pseudo-attribute
author Adam Chlipala <adam@chlipala.net>
date Sun, 06 May 2012 15:15:46 -0400
parents 277480862cef
children f8ddaa296115
comparison
equal deleted inserted replaced
1750:277480862cef 1751:acadf9d1214a
1 (* Copyright (c) 2008-2011, Adam Chlipala 1 (* Copyright (c) 2008-2012, Adam Chlipala
2 * All rights reserved. 2 * All rights reserved.
3 * 3 *
4 * Redistribution and use in source and binary forms, with or without 4 * Redistribution and use in source and binary forms, with or without
5 * modification, are permitted provided that the following conditions are met: 5 * modification, are permitted provided that the following conditions are met:
6 * 6 *
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 | Style of exp | Normal of con * exp 222 datatype attr = Class of exp | DynClass of exp | Style of exp | DynStyle 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)
425 | patS of pat 425 | patS of pat
426 | pterm of pat 426 | pterm of pat
427 | rpat of (string * pat) list * bool 427 | rpat of (string * pat) list * bool
428 | ptuple of pat list 428 | ptuple of pat list
429 429
430 | attrs of exp option * exp option * exp option * (con * exp) list 430 | attrs of exp option * exp option * exp option * exp option * (con * exp) list
431 | attr of attr 431 | attr of attr
432 | attrv of exp 432 | attrv of exp
433 433
434 | query of exp 434 | query of exp
435 | query1 of exp 435 | query1 of exp
1103 eapps : eterm (eterm) 1103 eapps : eterm (eterm)
1104 | eapps eterm (EApp (eapps, eterm), s (eappsleft, etermright)) 1104 | eapps eterm (EApp (eapps, eterm), s (eappsleft, etermright))
1105 | eapps LBRACK cexp RBRACK (ECApp (eapps, cexp), s (eappsleft, RBRACKright)) 1105 | eapps LBRACK cexp RBRACK (ECApp (eapps, cexp), s (eappsleft, RBRACKright))
1106 | eapps BANG (EDisjointApp eapps, s (eappsleft, BANGright)) 1106 | eapps BANG (EDisjointApp eapps, s (eappsleft, BANGright))
1107 1107
1108 eexp : eapps (eapps) 1108 eexp : eapps (case #1 eapps of
1109 EApp ((EVar ([], "CLASS", _), _), (EPrim (Prim.String s), loc)) => parseClass s loc
1110 | EApp ((EVar ([], "STYLE", _), _), (EPrim (Prim.String s), loc)) => parseStyle s loc
1111 | _ => eapps)
1109 | FN eargs DARROW eexp (let 1112 | FN eargs DARROW eexp (let
1110 val loc = s (FNleft, eexpright) 1113 val loc = s (FNleft, eexpright)
1111 in 1114 in
1112 #1 (eargs (eexp, (CWild (KType, loc), loc))) 1115 #1 (eargs (eexp, (CWild (KType, loc), loc)))
1113 end) 1116 end)
1583 val eo = case #3 attrs of 1586 val eo = case #3 attrs of
1584 NONE => (EVar (["Basis"], "noStyle", Infer), pos) 1587 NONE => (EVar (["Basis"], "noStyle", Infer), pos)
1585 | SOME (EPrim (Prim.String s), pos) => parseStyle s pos 1588 | SOME (EPrim (Prim.String s), pos) => parseStyle s pos
1586 | SOME e => e 1589 | SOME e => e
1587 val e = (EApp (e, eo), pos) 1590 val e = (EApp (e, eo), pos)
1588 val e = (EApp (e, (ERecord (#4 attrs), pos)), pos) 1591 val eo = case #4 attrs of
1592 NONE => (EVar (["Basis"], "None", Infer), pos)
1593 | SOME e => (EApp ((EVar (["Basis"], "Some", Infer), pos),
1594 e), pos)
1595 val e = (EApp (e, eo), pos)
1596 val e = (EApp (e, (ERecord (#5 attrs), pos)), pos)
1589 val e = (EApp (e, (EApp (#2 tagHead, 1597 val e = (EApp (e, (EApp (#2 tagHead,
1590 (ERecord [], pos)), pos)), pos) 1598 (ERecord [], pos)), pos)), pos)
1591 in 1599 in
1592 (tagHead, #1 attrs, #2 attrs, e) 1600 (tagHead, #1 attrs, #2 attrs, e)
1593 end) 1601 end)
1599 (bt, 1607 (bt,
1600 (EVar (["Basis"], bt, Infer), pos)) 1608 (EVar (["Basis"], bt, Infer), pos))
1601 end) 1609 end)
1602 | tagHead LBRACE cexp RBRACE (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright))) 1610 | tagHead LBRACE cexp RBRACE (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright)))
1603 1611
1604 attrs : (NONE, NONE, NONE, []) 1612 attrs : (NONE, NONE, NONE, NONE, [])
1605 | attr attrs (let 1613 | attr attrs (let
1606 val loc = s (attrleft, attrsright) 1614 val loc = s (attrleft, attrsright)
1607 in 1615 in
1608 case attr of 1616 case attr of
1609 Class e => 1617 Class e =>
1610 (case #1 attrs of 1618 (case #1 attrs of
1611 NONE => () 1619 NONE => ()
1612 | SOME _ => ErrorMsg.errorAt loc "Multiple classes specified for tag"; 1620 | SOME _ => ErrorMsg.errorAt loc "Multiple classes specified for tag";
1613 (SOME e, #2 attrs, #3 attrs, #4 attrs)) 1621 (SOME e, #2 attrs, #3 attrs, #4 attrs, #5 attrs))
1614 | DynClass e => 1622 | DynClass e =>
1615 (case #2 attrs of 1623 (case #2 attrs of
1616 NONE => () 1624 NONE => ()
1617 | SOME _ => ErrorMsg.errorAt loc "Multiple dynamic classes specified for tag"; 1625 | SOME _ => ErrorMsg.errorAt loc "Multiple dynamic classes specified for tag";
1618 (#1 attrs, SOME e, #3 attrs, #4 attrs)) 1626 (#1 attrs, SOME e, #3 attrs, #4 attrs, #5 attrs))
1619 | Style e => 1627 | Style e =>
1620 (case #3 attrs of 1628 (case #3 attrs of
1621 NONE => () 1629 NONE => ()
1622 | SOME _ => ErrorMsg.errorAt loc "Multiple styles specified for tag"; 1630 | SOME _ => ErrorMsg.errorAt loc "Multiple styles specified for tag";
1623 (#1 attrs, #2 attrs, SOME e, #4 attrs)) 1631 (#1 attrs, #2 attrs, SOME e, #4 attrs, #5 attrs))
1632 | DynStyle e =>
1633 (case #4 attrs of
1634 NONE => ()
1635 | SOME _ => ErrorMsg.errorAt loc "Multiple dynamic classes specified for tag";
1636 (#1 attrs, #2 attrs, #3 attrs, SOME e, #5 attrs))
1624 | Normal xe => 1637 | Normal xe =>
1625 (#1 attrs, #2 attrs, #3 attrs, xe :: #4 attrs) 1638 (#1 attrs, #2 attrs, #3 attrs, #4 attrs, xe :: #5 attrs)
1626 end) 1639 end)
1627 1640
1628 attr : SYMBOL EQ attrv (case SYMBOL of 1641 attr : SYMBOL EQ attrv (case SYMBOL of
1629 "class" => Class attrv 1642 "class" => Class attrv
1630 | "dynClass" => DynClass attrv 1643 | "dynClass" => DynClass attrv
1631 | "style" => Style attrv 1644 | "style" => Style attrv
1645 | "dynStyle" => DynStyle attrv
1632 | _ => 1646 | _ =>
1633 let 1647 let
1634 val sym = 1648 val sym =
1635 case SYMBOL of 1649 case SYMBOL of
1636 "type" => "Typ" 1650 "type" => "Typ"