Mercurial > urweb
comparison src/urweb.grm @ 2048:4d64af730e35
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 |