Mercurial > urweb

comparison src/urweb.grm @ 2211:ef766ef6e242

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merge.
author Ziv Scully <ziv@mit.edu>
date Sat, 13 Sep 2014 19:16:07 -0400
parents 4d64af730e35
children fde864eacd47
comparison
equal deleted inserted replaced
2210:69c0f36255cb 2211:ef766ef6e242
223 "table" => "tabl" 223 "table" => "tabl"
224 | _ => bt 224 | _ => bt
225 225
226 datatype prop_kind = Delete | Update 226 datatype prop_kind = Delete | Update
227 227
228 datatype attr = Class of exp | DynClass of exp | Style of exp | DynStyle of exp | Normal of con * exp | Data of string * exp 228 datatype attr = Class of exp | DynClass of exp | Style of exp | DynStyle of exp | Normal of con * exp | Data of string * string * exp
229 229
230 fun patType loc (p : pat) = 230 fun patType loc (p : pat) =
231 case #1 p of 231 case #1 p of
232 PAnnot (_, t) => t 232 PAnnot (_, t) => t
233 | _ => (CWild (KType, loc), loc) 233 | _ => (CWild (KType, loc), loc)
280 else 280 else
281 s 281 s
282 in 282 in
283 (EApp ((EVar (["Basis"], "css_url", Infer), pos), 283 (EApp ((EVar (["Basis"], "css_url", Infer), pos),
284 (EApp ((EVar (["Basis"], "bless", Infer), pos), 284 (EApp ((EVar (["Basis"], "bless", Infer), pos),
285 (EPrim (Prim.String s), pos)), pos)), pos) 285 (EPrim (Prim.String (Prim.Normal, s)), pos)), pos)), pos)
286 end 286 end
287 else 287 else
288 (EApp ((EVar (["Basis"], "atom", Infer), pos), 288 (EApp ((EVar (["Basis"], "atom", Infer), pos),
289 (EPrim (Prim.String s), pos)), pos) 289 (EPrim (Prim.String (Prim.Normal, s)), pos)), pos)
290 290
291 fun parseProperty s pos = 291 fun parseProperty s pos =
292 let 292 let
293 val (befor, after) = Substring.splitl (fn ch => ch <> #":") (Substring.full s) 293 val (befor, after) = Substring.splitl (fn ch => ch <> #":") (Substring.full s)
294 in 294 in
295 if Substring.isEmpty after then 295 if Substring.isEmpty after then
296 (ErrorMsg.errorAt pos ("Invalid CSS property syntax: " ^ s); 296 (ErrorMsg.errorAt pos ("Invalid CSS property syntax: " ^ s);
297 (EPrim (Prim.String ""), pos)) 297 (EPrim (Prim.String (Prim.Normal, "")), pos))
298 else 298 else
299 foldl (fn (value, e) => (EApp ((EApp ((EVar (["Basis"], "value", Infer), pos), e), pos), parseValue value pos), pos)) 299 foldl (fn (value, e) => (EApp ((EApp ((EVar (["Basis"], "value", Infer), pos), e), pos), parseValue value pos), pos))
300 (EApp ((EVar (["Basis"], "property", Infer), pos), 300 (EApp ((EVar (["Basis"], "property", Infer), pos),
301 (EPrim (Prim.String (Substring.string (#2 (Substring.splitl Char.isSpace befor)))), pos)), pos) 301 (EPrim (Prim.String (Prim.Normal, Substring.string (#2 (Substring.splitl Char.isSpace befor)))), pos)), pos)
302 (String.tokens Char.isSpace (Substring.string (Substring.slice (after, 1, NONE)))) 302 (String.tokens Char.isSpace (Substring.string (Substring.slice (after, 1, NONE))))
303 end 303 end
304 304
305 fun parseStyle s pos = 305 fun parseStyle s pos =
306 case String.tokens (fn ch => ch = #";") s of 306 case String.tokens (fn ch => ch = #";") s of
484 | patS of pat 484 | patS of pat
485 | pterm of pat 485 | pterm of pat
486 | rpat of (string * pat) list * bool 486 | rpat of (string * pat) list * bool
487 | ptuple of pat list 487 | ptuple of pat list
488 488
489 | attrs of exp option * exp option * exp option * exp option * (string * exp) list * (con * exp) list 489 | attrs of exp option * exp option * exp option * exp option * (string * string * exp) list * (con * exp) list
490 | attr of attr 490 | attr of attr
491 | attrv of exp 491 | attrv of exp
492 492
493 | query of exp 493 | query of exp
494 | query1 of exp 494 | query1 of exp
1150 | eapps eterm (EApp (eapps, eterm), s (eappsleft, etermright)) 1150 | eapps eterm (EApp (eapps, eterm), s (eappsleft, etermright))
1151 | eapps LBRACK cexp RBRACK (ECApp (eapps, cexp), s (eappsleft, RBRACKright)) 1151 | eapps LBRACK cexp RBRACK (ECApp (eapps, cexp), s (eappsleft, RBRACKright))
1152 | eapps BANG (EDisjointApp eapps, s (eappsleft, BANGright)) 1152 | eapps BANG (EDisjointApp eapps, s (eappsleft, BANGright))
1153 1153
1154 eexp : eapps (case #1 eapps of 1154 eexp : eapps (case #1 eapps of
1155 EApp ((EVar ([], "CLASS", _), _), (EPrim (Prim.String s), loc)) => parseClass s loc 1155 EApp ((EVar ([], "CLASS", _), _), (EPrim (Prim.String (_, s)), loc)) => parseClass s loc
1156 | EApp ((EVar ([], "STYLE", _), _), (EPrim (Prim.String s), loc)) => parseStyle s loc 1156 | EApp ((EVar ([], "STYLE", _), _), (EPrim (Prim.String (_, s)), loc)) => parseStyle s loc
1157 | _ => eapps) 1157 | _ => eapps)
1158 | FN eargs DARROW eexp (let 1158 | FN eargs DARROW eexp (let
1159 val loc = s (FNleft, eexpright) 1159 val loc = s (FNleft, eexpright)
1160 in 1160 in
1161 #1 (eargs (eexp, (CWild (KType, loc), loc))) 1161 #1 (eargs (eexp, (CWild (KType, loc), loc)))
1345 | LBRACE RBRACE (ERecord ([], false), s (LBRACEleft, RBRACEright)) 1345 | LBRACE RBRACE (ERecord ([], false), s (LBRACEleft, RBRACEright))
1346 | UNIT (ERecord ([], false), s (UNITleft, UNITright)) 1346 | UNIT (ERecord ([], false), s (UNITleft, UNITright))
1347 1347
1348 | INT (EPrim (Prim.Int INT), s (INTleft, INTright)) 1348 | INT (EPrim (Prim.Int INT), s (INTleft, INTright))
1349 | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright)) 1349 | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright))
1350 | STRING (EPrim (Prim.String STRING), s (STRINGleft, STRINGright)) 1350 | STRING (EPrim (Prim.String (Prim.Normal, STRING)), s (STRINGleft, STRINGright))
1351 | CHAR (EPrim (Prim.Char CHAR), s (CHARleft, CHARright)) 1351 | CHAR (EPrim (Prim.Char CHAR), s (CHARleft, CHARright))
1352 1352
1353 | path DOT idents (let 1353 | path DOT idents (let
1354 val loc = s (pathleft, identsright) 1354 val loc = s (pathleft, identsright)
1355 in 1355 in
1394 if XML_BEGIN = "xml" then 1394 if XML_BEGIN = "xml" then
1395 () 1395 ()
1396 else 1396 else
1397 ErrorMsg.errorAt loc "Initial XML tag pair aren't both tagged \"xml\"."; 1397 ErrorMsg.errorAt loc "Initial XML tag pair aren't both tagged \"xml\".";
1398 (EApp ((EVar (["Basis"], "cdata", Infer), loc), 1398 (EApp ((EVar (["Basis"], "cdata", Infer), loc),
1399 (EPrim (Prim.String ""), loc)), 1399 (EPrim (Prim.String (Prim.Html, "")), loc)),
1400 loc) 1400 loc)
1401 end) 1401 end)
1402 | XML_BEGIN_END (let 1402 | XML_BEGIN_END (let
1403 val loc = s (XML_BEGIN_ENDleft, XML_BEGIN_ENDright) 1403 val loc = s (XML_BEGIN_ENDleft, XML_BEGIN_ENDright)
1404 in 1404 in
1405 if XML_BEGIN_END = "xml" then 1405 if XML_BEGIN_END = "xml" then
1406 () 1406 ()
1407 else 1407 else
1408 ErrorMsg.errorAt loc "Initial XML tag pair aren't both tagged \"xml\"."; 1408 ErrorMsg.errorAt loc "Initial XML tag pair aren't both tagged \"xml\".";
1409 (EApp ((EVar (["Basis"], "cdata", Infer), loc), 1409 (EApp ((EVar (["Basis"], "cdata", Infer), loc),
1410 (EPrim (Prim.String ""), loc)), 1410 (EPrim (Prim.String (Prim.Html, "")), loc)),
1411 loc) 1411 loc)
1412 end) 1412 end)
1413 1413
1414 | LPAREN query RPAREN (query) 1414 | LPAREN query RPAREN (query)
1415 | LPAREN CWHERE sqlexp RPAREN (sqlexp) 1415 | LPAREN CWHERE sqlexp RPAREN (sqlexp)
1454 end) 1454 end)
1455 1455
1456 | UNDER (EWild, s (UNDERleft, UNDERright)) 1456 | UNDER (EWild, s (UNDERleft, UNDERright))
1457 1457
1458 | LET edecls IN eexp END (ELet (edecls, eexp), s (LETleft, ENDright)) 1458 | LET edecls IN eexp END (ELet (edecls, eexp), s (LETleft, ENDright))
1459 | LET eexp WHERE edecls END (ELet (edecls, eexp), s (LETleft, ENDright))
1459 1460
1460 | LBRACK RBRACK (EVar (["Basis"], "Nil", Infer), s (LBRACKleft, RBRACKright)) 1461 | LBRACK RBRACK (EVar (["Basis"], "Nil", Infer), s (LBRACKleft, RBRACKright))
1461 1462
1462 edecls : ([]) 1463 edecls : ([])
1463 | edecl edecls (edecl :: edecls) 1464 | edecl edecls (edecl :: edecls)
1508 pterm : SYMBOL (PVar SYMBOL, s (SYMBOLleft, SYMBOLright)) 1509 pterm : SYMBOL (PVar SYMBOL, s (SYMBOLleft, SYMBOLright))
1509 | cpath (PCon (#1 cpath, #2 cpath, NONE), s (cpathleft, cpathright)) 1510 | cpath (PCon (#1 cpath, #2 cpath, NONE), s (cpathleft, cpathright))
1510 | UNDER (PWild, s (UNDERleft, UNDERright)) 1511 | UNDER (PWild, s (UNDERleft, UNDERright))
1511 | INT (PPrim (Prim.Int INT), s (INTleft, INTright)) 1512 | INT (PPrim (Prim.Int INT), s (INTleft, INTright))
1512 | MINUS INT (PPrim (Prim.Int (~INT)), s (MINUSleft, INTright)) 1513 | MINUS INT (PPrim (Prim.Int (~INT)), s (MINUSleft, INTright))
1513 | STRING (PPrim (Prim.String STRING), s (STRINGleft, STRINGright)) 1514 | STRING (PPrim (Prim.String (Prim.Normal, STRING)), s (STRINGleft, STRINGright))
1514 | CHAR (PPrim (Prim.Char CHAR), s (CHARleft, CHARright)) 1515 | CHAR (PPrim (Prim.Char CHAR), s (CHARleft, CHARright))
1515 | LPAREN pat RPAREN (pat) 1516 | LPAREN pat RPAREN (pat)
1516 | LBRACE RBRACE (PRecord ([], false), s (LBRACEleft, RBRACEright)) 1517 | LBRACE RBRACE (PRecord ([], false), s (LBRACEleft, RBRACEright))
1517 | UNIT (PRecord ([], false), s (UNITleft, UNITright)) 1518 | UNIT (PRecord ([], false), s (UNITleft, UNITright))
1518 | LBRACE rpat RBRACE (PRecord rpat, s (LBRACEleft, RBRACEright)) 1519 | LBRACE rpat RBRACE (PRecord rpat, s (LBRACEleft, RBRACEright))
1544 end) 1545 end)
1545 | xmlOne (xmlOne) 1546 | xmlOne (xmlOne)
1546 1547
1547 xmlOpt : xml (xml) 1548 xmlOpt : xml (xml)
1548 | (EApp ((EVar (["Basis"], "cdata", Infer), dummy), 1549 | (EApp ((EVar (["Basis"], "cdata", Infer), dummy),
1549 (EPrim (Prim.String ""), dummy)), 1550 (EPrim (Prim.String (Prim.Html, "")), dummy)),
1550 dummy) 1551 dummy)
1551 1552
1552 xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer), s (NOTAGSleft, NOTAGSright)), 1553 xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer), s (NOTAGSleft, NOTAGSright)),
1553 (EPrim (Prim.String NOTAGS), s (NOTAGSleft, NOTAGSright))), 1554 (EPrim (Prim.String (Prim.Html, NOTAGS)), s (NOTAGSleft, NOTAGSright))),
1554 s (NOTAGSleft, NOTAGSright)) 1555 s (NOTAGSleft, NOTAGSright))
1555 | tag DIVIDE GT (let 1556 | tag DIVIDE GT (let
1556 val pos = s (tagleft, GTright) 1557 val pos = s (tagleft, GTright)
1557 1558
1558 val cdata = 1559 val cdata =
1565 end 1566 end
1566 else 1567 else
1567 (EVar (["Basis"], "cdata", Infer), pos) 1568 (EVar (["Basis"], "cdata", Infer), pos)
1568 1569
1569 val cdata = (EApp (cdata, 1570 val cdata = (EApp (cdata,
1570 (EPrim (Prim.String ""), pos)), 1571 (EPrim (Prim.String (Prim.Html, "")), pos)),
1571 pos) 1572 pos)
1572 in 1573 in
1573 (EApp (#4 tag, cdata), pos) 1574 (EApp (#4 tag, cdata), pos)
1574 end) 1575 end)
1575 1576
1626 val pos = s (tagHeadleft, attrsright) 1627 val pos = s (tagHeadleft, attrsright)
1627 1628
1628 val e = (EVar (["Basis"], "tag", Infer), pos) 1629 val e = (EVar (["Basis"], "tag", Infer), pos)
1629 val eo = case #1 attrs of 1630 val eo = case #1 attrs of
1630 NONE => (EVar (["Basis"], "null", Infer), pos) 1631 NONE => (EVar (["Basis"], "null", Infer), pos)
1631 | SOME (EPrim (Prim.String s), pos) => parseClass s pos 1632 | SOME (EPrim (Prim.String (_, s)), pos) => parseClass s pos
1632 | SOME e => e 1633 | SOME e => e
1633 val e = (EApp (e, eo), pos) 1634 val e = (EApp (e, eo), pos)
1634 val eo = case #2 attrs of 1635 val eo = case #2 attrs of
1635 NONE => (EVar (["Basis"], "None", Infer), pos) 1636 NONE => (EVar (["Basis"], "None", Infer), pos)
1636 | SOME e => (EApp ((EVar (["Basis"], "Some", Infer), pos), 1637 | SOME e => (EApp ((EVar (["Basis"], "Some", Infer), pos),
1637 e), pos) 1638 e), pos)
1638 val e = (EApp (e, eo), pos) 1639 val e = (EApp (e, eo), pos)
1639 val eo = case #3 attrs of 1640 val eo = case #3 attrs of
1640 NONE => (EVar (["Basis"], "noStyle", Infer), pos) 1641 NONE => (EVar (["Basis"], "noStyle", Infer), pos)
1641 | SOME (EPrim (Prim.String s), pos) => parseStyle s pos 1642 | SOME (EPrim (Prim.String (_, s)), pos) => parseStyle s pos
1642 | SOME e => e 1643 | SOME e => e
1643 val e = (EApp (e, eo), pos) 1644 val e = (EApp (e, eo), pos)
1644 val eo = case #4 attrs of 1645 val eo = case #4 attrs of
1645 NONE => (EVar (["Basis"], "None", Infer), pos) 1646 NONE => (EVar (["Basis"], "None", Infer), pos)
1646 | SOME e => (EApp ((EVar (["Basis"], "Some", Infer), pos), 1647 | SOME e => (EApp ((EVar (["Basis"], "Some", Infer), pos),
1649 1650
1650 val atts = case #5 attrs of 1651 val atts = case #5 attrs of
1651 [] => #6 attrs 1652 [] => #6 attrs
1652 | data :: datas => 1653 | data :: datas =>
1653 let 1654 let
1654 fun doOne (name, value) = 1655 fun doOne (kind, name, value) =
1655 let 1656 let
1656 val e = (EVar (["Basis"], "data_attr", Infer), pos) 1657 val e = (EVar (["Basis"], "data_attr", Infer), pos)
1657 val e = (EApp (e, (EPrim (Prim.String name), pos)), pos) 1658 val e = (EApp (e, (EVar (["Basis"], kind ^ "_kind", Infer), pos)), pos)
1659 val e = (EApp (e, (EPrim (Prim.String (Prim.Normal, name)), pos)), pos)
1658 in 1660 in
1659 (EApp (e, value), pos) 1661 (EApp (e, value), pos)
1660 end 1662 end
1661 1663
1662 val datas' = foldl (fn (nv, acc) => 1664 val datas' = foldl (fn (nv, acc) =>
1722 | "dynClass" => DynClass attrv 1724 | "dynClass" => DynClass attrv
1723 | "style" => Style attrv 1725 | "style" => Style attrv
1724 | "dynStyle" => DynStyle attrv 1726 | "dynStyle" => DynStyle attrv
1725 | _ => 1727 | _ =>
1726 if String.isPrefix "data-" SYMBOL then 1728 if String.isPrefix "data-" SYMBOL then
1727 Data (String.extract (SYMBOL, 5, NONE), attrv) 1729 Data ("data", String.extract (SYMBOL, 5, NONE), attrv)
1730 else if String.isPrefix "aria-" SYMBOL then
1731 Data ("aria", String.extract (SYMBOL, 5, NONE), attrv)
1728 else 1732 else
1729 let 1733 let
1730 val sym = makeAttr SYMBOL 1734 val sym = makeAttr SYMBOL
1731 in 1735 in
1732 Normal ((CName sym, s (SYMBOLleft, SYMBOLright)), 1736 Normal ((CName sym, s (SYMBOLleft, SYMBOLright)),
1744 attrv) 1748 attrv)
1745 end) 1749 end)
1746 1750
1747 attrv : INT (EPrim (Prim.Int INT), s (INTleft, INTright)) 1751 attrv : INT (EPrim (Prim.Int INT), s (INTleft, INTright))
1748 | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright)) 1752 | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright))
1749 | STRING (EPrim (Prim.String STRING), s (STRINGleft, STRINGright)) 1753 | STRING (EPrim (Prim.String (Prim.Normal, STRING)), s (STRINGleft, STRINGright))
1750 | LBRACE eexp RBRACE (eexp) 1754 | LBRACE eexp RBRACE (eexp)
1751 1755
1752 query : query1 obopt lopt ofopt (let 1756 query : query1 obopt lopt ofopt (let
1753 val loc = s (query1left, query1right) 1757 val loc = s (query1left, query1right)
1754 1758
1978 val e = (EVar (["Basis"], "sql_from_query", Infer), loc) 1982 val e = (EVar (["Basis"], "sql_from_query", Infer), loc)
1979 val e = (ECApp (e, tname), loc) 1983 val e = (ECApp (e, tname), loc)
1980 in 1984 in
1981 ([tname], (EApp (e, query), loc)) 1985 ([tname], (EApp (e, query), loc))
1982 end) 1986 end)
1987 | LPAREN LBRACE LBRACE eexp RBRACE RBRACE RPAREN AS tname (let
1988 val loc = s (LPARENleft, RPARENright)
1989
1990 val e = (EVar (["Basis"], "sql_from_query", Infer), loc)
1991 val e = (ECApp (e, tname), loc)
1992 in
1993 ([tname], (EApp (e, eexp), loc))
1994 end)
1983 | LPAREN fitem RPAREN (fitem) 1995 | LPAREN fitem RPAREN (fitem)
1984 1996
1985 tname : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright)) 1997 tname : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
1986 | LBRACE cexp RBRACE (cexp) 1998 | LBRACE cexp RBRACE (cexp)
1987 1999
2024 2036
2025 | INT (sql_inject (EPrim (Prim.Int INT), 2037 | INT (sql_inject (EPrim (Prim.Int INT),
2026 s (INTleft, INTright))) 2038 s (INTleft, INTright)))
2027 | FLOAT (sql_inject (EPrim (Prim.Float FLOAT), 2039 | FLOAT (sql_inject (EPrim (Prim.Float FLOAT),
2028 s (FLOATleft, FLOATright))) 2040 s (FLOATleft, FLOATright)))
2029 | STRING (sql_inject (EPrim (Prim.String STRING), 2041 | STRING (sql_inject (EPrim (Prim.String (Prim.Normal, STRING)),
2030 s (STRINGleft, STRINGright))) 2042 s (STRINGleft, STRINGright)))
2031 | CURRENT_TIMESTAMP (sql_nfunc ("current_timestamp", 2043 | CURRENT_TIMESTAMP (sql_nfunc ("current_timestamp",
2032 s (CURRENT_TIMESTAMPleft, CURRENT_TIMESTAMPright))) 2044 s (CURRENT_TIMESTAMPleft, CURRENT_TIMESTAMPright)))
2033 2045
2034 | tident DOT fident (let 2046 | tident DOT fident (let