Mercurial > urweb

comparison src/urweb.grm @ 2048:4d64af730e35

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Differentiate between HTML and normal string literals
author Adam Chlipala <adam@chlipala.net>
date Fri, 01 Aug 2014 15:44:17 -0400
parents 6be31671911b
children fde864eacd47
comparison
equal deleted inserted replaced
2047:6be31671911b 2048:4d64af730e35
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
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)
1509 pterm : SYMBOL (PVar SYMBOL, s (SYMBOLleft, SYMBOLright)) 1509 pterm : SYMBOL (PVar SYMBOL, s (SYMBOLleft, SYMBOLright))
1510 | cpath (PCon (#1 cpath, #2 cpath, NONE), s (cpathleft, cpathright)) 1510 | cpath (PCon (#1 cpath, #2 cpath, NONE), s (cpathleft, cpathright))
1511 | UNDER (PWild, s (UNDERleft, UNDERright)) 1511 | UNDER (PWild, s (UNDERleft, UNDERright))
1512 | INT (PPrim (Prim.Int INT), s (INTleft, INTright)) 1512 | INT (PPrim (Prim.Int INT), s (INTleft, INTright))
1513 | MINUS INT (PPrim (Prim.Int (~INT)), s (MINUSleft, INTright)) 1513 | MINUS INT (PPrim (Prim.Int (~INT)), s (MINUSleft, INTright))
1514 | STRING (PPrim (Prim.String STRING), s (STRINGleft, STRINGright)) 1514 | STRING (PPrim (Prim.String (Prim.Normal, STRING)), s (STRINGleft, STRINGright))
1515 | CHAR (PPrim (Prim.Char CHAR), s (CHARleft, CHARright)) 1515 | CHAR (PPrim (Prim.Char CHAR), s (CHARleft, CHARright))
1516 | LPAREN pat RPAREN (pat) 1516 | LPAREN pat RPAREN (pat)
1517 | LBRACE RBRACE (PRecord ([], false), s (LBRACEleft, RBRACEright)) 1517 | LBRACE RBRACE (PRecord ([], false), s (LBRACEleft, RBRACEright))
1518 | UNIT (PRecord ([], false), s (UNITleft, UNITright)) 1518 | UNIT (PRecord ([], false), s (UNITleft, UNITright))
1519 | LBRACE rpat RBRACE (PRecord rpat, s (LBRACEleft, RBRACEright)) 1519 | LBRACE rpat RBRACE (PRecord rpat, s (LBRACEleft, RBRACEright))
1545 end) 1545 end)
1546 | xmlOne (xmlOne) 1546 | xmlOne (xmlOne)
1547 1547
1548 xmlOpt : xml (xml) 1548 xmlOpt : xml (xml)
1549 | (EApp ((EVar (["Basis"], "cdata", Infer), dummy), 1549 | (EApp ((EVar (["Basis"], "cdata", Infer), dummy),
1550 (EPrim (Prim.String ""), dummy)), 1550 (EPrim (Prim.String (Prim.Html, "")), dummy)),
1551 dummy) 1551 dummy)
1552 1552
1553 xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer), s (NOTAGSleft, NOTAGSright)), 1553 xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer), s (NOTAGSleft, NOTAGSright)),
1554 (EPrim (Prim.String NOTAGS), s (NOTAGSleft, NOTAGSright))), 1554 (EPrim (Prim.String (Prim.Html, NOTAGS)), s (NOTAGSleft, NOTAGSright))),
1555 s (NOTAGSleft, NOTAGSright)) 1555 s (NOTAGSleft, NOTAGSright))
1556 | tag DIVIDE GT (let 1556 | tag DIVIDE GT (let
1557 val pos = s (tagleft, GTright) 1557 val pos = s (tagleft, GTright)
1558 1558
1559 val cdata = 1559 val cdata =
1566 end 1566 end
1567 else 1567 else
1568 (EVar (["Basis"], "cdata", Infer), pos) 1568 (EVar (["Basis"], "cdata", Infer), pos)
1569 1569
1570 val cdata = (EApp (cdata, 1570 val cdata = (EApp (cdata,
1571 (EPrim (Prim.String ""), pos)), 1571 (EPrim (Prim.String (Prim.Html, "")), pos)),
1572 pos) 1572 pos)
1573 in 1573 in
1574 (EApp (#4 tag, cdata), pos) 1574 (EApp (#4 tag, cdata), pos)
1575 end) 1575 end)
1576 1576
1627 val pos = s (tagHeadleft, attrsright) 1627 val pos = s (tagHeadleft, attrsright)
1628 1628
1629 val e = (EVar (["Basis"], "tag", Infer), pos) 1629 val e = (EVar (["Basis"], "tag", Infer), pos)
1630 val eo = case #1 attrs of 1630 val eo = case #1 attrs of
1631 NONE => (EVar (["Basis"], "null", Infer), pos) 1631 NONE => (EVar (["Basis"], "null", Infer), pos)
1632 | SOME (EPrim (Prim.String s), pos) => parseClass s pos 1632 | SOME (EPrim (Prim.String (_, s)), pos) => parseClass s pos
1633 | SOME e => e 1633 | SOME e => e
1634 val e = (EApp (e, eo), pos) 1634 val e = (EApp (e, eo), pos)
1635 val eo = case #2 attrs of 1635 val eo = case #2 attrs of
1636 NONE => (EVar (["Basis"], "None", Infer), pos) 1636 NONE => (EVar (["Basis"], "None", Infer), pos)
1637 | SOME e => (EApp ((EVar (["Basis"], "Some", Infer), pos), 1637 | SOME e => (EApp ((EVar (["Basis"], "Some", Infer), pos),
1638 e), pos) 1638 e), pos)
1639 val e = (EApp (e, eo), pos) 1639 val e = (EApp (e, eo), pos)
1640 val eo = case #3 attrs of 1640 val eo = case #3 attrs of
1641 NONE => (EVar (["Basis"], "noStyle", Infer), pos) 1641 NONE => (EVar (["Basis"], "noStyle", Infer), pos)
1642 | SOME (EPrim (Prim.String s), pos) => parseStyle s pos 1642 | SOME (EPrim (Prim.String (_, s)), pos) => parseStyle s pos
1643 | SOME e => e 1643 | SOME e => e
1644 val e = (EApp (e, eo), pos) 1644 val e = (EApp (e, eo), pos)
1645 val eo = case #4 attrs of 1645 val eo = case #4 attrs of
1646 NONE => (EVar (["Basis"], "None", Infer), pos) 1646 NONE => (EVar (["Basis"], "None", Infer), pos)
1647 | SOME e => (EApp ((EVar (["Basis"], "Some", Infer), pos), 1647 | SOME e => (EApp ((EVar (["Basis"], "Some", Infer), pos),
1654 let 1654 let
1655 fun doOne (kind, name, value) = 1655 fun doOne (kind, name, value) =
1656 let 1656 let
1657 val e = (EVar (["Basis"], "data_attr", Infer), pos) 1657 val e = (EVar (["Basis"], "data_attr", Infer), pos)
1658 val e = (EApp (e, (EVar (["Basis"], kind ^ "_kind", Infer), pos)), pos) 1658 val e = (EApp (e, (EVar (["Basis"], kind ^ "_kind", Infer), pos)), pos)
1659 val e = (EApp (e, (EPrim (Prim.String name), pos)), pos) 1659 val e = (EApp (e, (EPrim (Prim.String (Prim.Normal, name)), pos)), pos)
1660 in 1660 in
1661 (EApp (e, value), pos) 1661 (EApp (e, value), pos)
1662 end 1662 end
1663 1663
1664 val datas' = foldl (fn (nv, acc) => 1664 val datas' = foldl (fn (nv, acc) =>
1748 attrv) 1748 attrv)
1749 end) 1749 end)
1750 1750
1751 attrv : INT (EPrim (Prim.Int INT), s (INTleft, INTright)) 1751 attrv : INT (EPrim (Prim.Int INT), s (INTleft, INTright))
1752 | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright)) 1752 | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright))
1753 | STRING (EPrim (Prim.String STRING), s (STRINGleft, STRINGright)) 1753 | STRING (EPrim (Prim.String (Prim.Normal, STRING)), s (STRINGleft, STRINGright))
1754 | LBRACE eexp RBRACE (eexp) 1754 | LBRACE eexp RBRACE (eexp)
1755 1755
1756 query : query1 obopt lopt ofopt (let 1756 query : query1 obopt lopt ofopt (let
1757 val loc = s (query1left, query1right) 1757 val loc = s (query1left, query1right)
1758 1758
2036 2036
2037 | INT (sql_inject (EPrim (Prim.Int INT), 2037 | INT (sql_inject (EPrim (Prim.Int INT),
2038 s (INTleft, INTright))) 2038 s (INTleft, INTright)))
2039 | FLOAT (sql_inject (EPrim (Prim.Float FLOAT), 2039 | FLOAT (sql_inject (EPrim (Prim.Float FLOAT),
2040 s (FLOATleft, FLOATright))) 2040 s (FLOATleft, FLOATright)))
2041 | STRING (sql_inject (EPrim (Prim.String STRING), 2041 | STRING (sql_inject (EPrim (Prim.String (Prim.Normal, STRING)),
2042 s (STRINGleft, STRINGright))) 2042 s (STRINGleft, STRINGright)))
2043 | CURRENT_TIMESTAMP (sql_nfunc ("current_timestamp", 2043 | CURRENT_TIMESTAMP (sql_nfunc ("current_timestamp",
2044 s (CURRENT_TIMESTAMPleft, CURRENT_TIMESTAMPright))) 2044 s (CURRENT_TIMESTAMPleft, CURRENT_TIMESTAMPright)))
2045 2045
2046 | tident DOT fident (let 2046 | tident DOT fident (let