Mercurial > urweb

comparison src/monoize.sml @ 1663:0577be31a435

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
First part of changes to avoid depending on C function call argument order of evaluation (omitting normal Ur function calls, so far)
author Adam Chlipala <adam@chlipala.net>
date Sat, 07 Jan 2012 15:56:22 -0500
parents b694f9153faa
children a12186d99e4f
comparison
equal deleted inserted replaced
1662:edf86cef0dba 1663:0577be31a435
507 attrify (args, ft, (L'.EPrim (Prim.String (Settings.getUrlPrefix () ^ s)), loc), fm) 507 attrify (args, ft, (L'.EPrim (Prim.String (Settings.getUrlPrefix () ^ s)), loc), fm)
508 end 508 end
509 | _ => 509 | _ =>
510 case t of 510 case t of
511 L'.TFfi ("Basis", "unit") => ((L'.EPrim (Prim.String ""), loc), fm) 511 L'.TFfi ("Basis", "unit") => ((L'.EPrim (Prim.String ""), loc), fm)
512 | L'.TFfi (m, x) => ((L'.EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [e]), loc), fm) 512 | L'.TFfi (m, x) => ((L'.EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm)
513 513
514 | L'.TRecord [] => ((L'.EPrim (Prim.String ""), loc), fm) 514 | L'.TRecord [] => ((L'.EPrim (Prim.String ""), loc), fm)
515 | L'.TRecord ((x, t) :: xts) => 515 | L'.TRecord ((x, t) :: xts) =>
516 let 516 let
517 val (se, fm) = fooify fm ((L'.EField (e, x), loc), t) 517 val (se, fm) = fooify fm ((L'.EField (e, x), loc), t)
942 | L.EFfi ("Basis", "eq_time") => 942 | L.EFfi ("Basis", "eq_time") =>
943 ((L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc), 943 ((L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc),
944 (L'.TFun ((L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), 944 (L'.TFun ((L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
945 (L'.EAbs ("y", (L'.TFfi ("Basis", "time"), loc), 945 (L'.EAbs ("y", (L'.TFfi ("Basis", "time"), loc),
946 (L'.TFfi ("Basis", "bool"), loc), 946 (L'.TFfi ("Basis", "bool"), loc),
947 (L'.EFfiApp ("Basis", "eq_time", [(L'.ERel 1, loc), (L'.ERel 0, loc)]), loc)), loc)), loc), 947 (L'.EFfiApp ("Basis", "eq_time", [((L'.ERel 1, loc), (L'.TFfi ("Basis", "time"), loc)),
948 ((L'.ERel 0, loc), (L'.TFfi ("Basis", "time"), loc))]), loc)), loc)), loc),
948 fm) 949 fm)
949 950
950 | L.ECApp ((L.EFfi ("Basis", "mkEq"), _), t) => 951 | L.ECApp ((L.EFfi ("Basis", "mkEq"), _), t) =>
951 let 952 let
952 val t = monoType env t 953 val t = monoType env t
1167 fun boolBin s = 1168 fun boolBin s =
1168 (L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc), 1169 (L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc),
1169 (L'.TFun ((L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), 1170 (L'.TFun ((L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
1170 (L'.EAbs ("y", (L'.TFfi ("Basis", "time"), loc), 1171 (L'.EAbs ("y", (L'.TFfi ("Basis", "time"), loc),
1171 (L'.TFfi ("Basis", "bool"), loc), 1172 (L'.TFfi ("Basis", "bool"), loc),
1172 (L'.EFfiApp ("Basis", s, [(L'.ERel 1, loc), (L'.ERel 0, loc)]), loc)), loc)), loc) 1173 (L'.EFfiApp ("Basis", s, [((L'.ERel 1, loc), (L'.TFfi ("Basis", "time"), loc)),
1174 ((L'.ERel 0, loc), (L'.TFfi ("Basis", "time"), loc))]), loc)), loc)), loc)
1173 in 1175 in
1174 ordEx ((L'.TFfi ("Basis", "time"), loc), 1176 ordEx ((L'.TFfi ("Basis", "time"), loc),
1175 boolBin "lt_time", 1177 boolBin "lt_time",
1176 boolBin "le_time") 1178 boolBin "le_time")
1177 end 1179 end
1366 in 1368 in
1367 ((L'.EAbs ("_", un, un, (L'.ERecv (liftExpInExp 0 ch, t1), loc)), loc), fm) 1369 ((L'.EAbs ("_", un, un, (L'.ERecv (liftExpInExp 0 ch, t1), loc)), loc), fm)
1368 end 1370 end
1369 | L.EFfiApp ("Basis", "recv", _) => poly () 1371 | L.EFfiApp ("Basis", "recv", _) => poly ()
1370 1372
1371 | L.EFfiApp ("Basis", "float", [e]) => 1373 | L.EFfiApp ("Basis", "float", [(e, t)]) =>
1372 let 1374 let
1373 val (e, fm) = monoExp (env, st, fm) e 1375 val (e, fm) = monoExp (env, st, fm) e
1374 in 1376 in
1375 ((L'.EFfiApp ("Basis", "floatFromInt", [e]), loc), fm) 1377 ((L'.EFfiApp ("Basis", "floatFromInt", [(e, monoType env t)]), loc), fm)
1376 end 1378 end
1377 1379
1378 | L.EFfiApp ("Basis", "sleep", [n]) => 1380 | L.EFfiApp ("Basis", "sleep", [(n, _)]) =>
1379 let 1381 let
1380 val (n, fm) = monoExp (env, st, fm) n 1382 val (n, fm) = monoExp (env, st, fm) n
1381 in 1383 in
1382 ((L'.ESleep n, loc), fm) 1384 ((L'.ESleep n, loc), fm)
1383 end 1385 end
1388 val t = monoType env t 1390 val t = monoType env t
1389 in 1391 in
1390 ((L'.EAbs ("x", t, (L'.TFun ((L'.TRecord [], loc), (L'.TSource, loc)), loc), 1392 ((L'.EAbs ("x", t, (L'.TFun ((L'.TRecord [], loc), (L'.TSource, loc)), loc),
1391 (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TSource, loc), 1393 (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TSource, loc),
1392 (L'.EFfiApp ("Basis", "new_client_source", 1394 (L'.EFfiApp ("Basis", "new_client_source",
1393 [(L'.EJavaScript (L'.Source t, (L'.ERel 1, loc)), loc)]), 1395 [((L'.EJavaScript (L'.Source t, (L'.ERel 1, loc)), loc),
1396 (L'.TSource, loc))]),
1394 loc)), loc)), 1397 loc)), loc)),
1395 loc), 1398 loc),
1396 fm) 1399 fm)
1397 end 1400 end
1398 | L.ECApp ((L.EFfi ("Basis", "set"), _), t) => 1401 | L.ECApp ((L.EFfi ("Basis", "set"), _), t) =>
1402 ((L'.EAbs ("src", (L'.TSource, loc), 1405 ((L'.EAbs ("src", (L'.TSource, loc),
1403 (L'.TFun (t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc)), loc), 1406 (L'.TFun (t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc)), loc),
1404 (L'.EAbs ("v", t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc), 1407 (L'.EAbs ("v", t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc),
1405 (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc), 1408 (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
1406 (L'.EFfiApp ("Basis", "set_client_source", 1409 (L'.EFfiApp ("Basis", "set_client_source",
1407 [(L'.ERel 2, loc), 1410 [((L'.ERel 2, loc), (L'.TSource, loc)),
1408 (L'.EJavaScript (L'.Source t, 1411 ((L'.EJavaScript (L'.Source t,
1409 (L'.ERel 1, loc)), loc)]), 1412 (L'.ERel 1, loc)), loc),
1413 t)]),
1410 loc)), loc)), loc)), loc), 1414 loc)), loc)), loc)), loc),
1411 fm) 1415 fm)
1412 end 1416 end
1413 | L.ECApp ((L.EFfi ("Basis", "get"), _), t) => 1417 | L.ECApp ((L.EFfi ("Basis", "get"), _), t) =>
1414 let 1418 let
1416 in 1420 in
1417 ((L'.EAbs ("src", (L'.TSource, loc), 1421 ((L'.EAbs ("src", (L'.TSource, loc),
1418 (L'.TFun ((L'.TRecord [], loc), t), loc), 1422 (L'.TFun ((L'.TRecord [], loc), t), loc),
1419 (L'.EAbs ("_", (L'.TRecord [], loc), t, 1423 (L'.EAbs ("_", (L'.TRecord [], loc), t,
1420 (L'.EFfiApp ("Basis", "get_client_source", 1424 (L'.EFfiApp ("Basis", "get_client_source",
1421 [(L'.ERel 1, loc)]), 1425 [((L'.ERel 1, loc), (L'.TSource, loc))]),
1422 loc)), loc)), loc), 1426 loc)), loc)), loc),
1423 fm) 1427 fm)
1424 end 1428 end
1425 | L.ECApp ((L.EFfi ("Basis", "current"), _), t) => 1429 | L.ECApp ((L.EFfi ("Basis", "current"), _), t) =>
1426 let 1430 let
1428 in 1432 in
1429 ((L'.EAbs ("src", (L'.TSource, loc), 1433 ((L'.EAbs ("src", (L'.TSource, loc),
1430 (L'.TFun ((L'.TRecord [], loc), t), loc), 1434 (L'.TFun ((L'.TRecord [], loc), t), loc),
1431 (L'.EAbs ("_", (L'.TRecord [], loc), t, 1435 (L'.EAbs ("_", (L'.TRecord [], loc), t,
1432 (L'.EFfiApp ("Basis", "current", 1436 (L'.EFfiApp ("Basis", "current",
1433 [(L'.ERel 1, loc)]), 1437 [((L'.ERel 1, loc), (L'.TSource, loc))]),
1434 loc)), loc)), loc), 1438 loc)), loc)), loc),
1435 fm) 1439 fm)
1436 end 1440 end
1437 1441
1438 | L.EFfiApp ("Basis", "spawn", [e]) => 1442 | L.EFfiApp ("Basis", "spawn", [(e, _)]) =>
1439 let 1443 let
1440 val (e, fm) = monoExp (env, st, fm) e 1444 val (e, fm) = monoExp (env, st, fm) e
1441 in 1445 in
1442 ((L'.ESpawn e, loc), fm) 1446 ((L'.ESpawn e, loc), fm)
1443 end 1447 end
1478 val un = (L'.TRecord [], loc) 1482 val un = (L'.TRecord [], loc)
1479 val t = monoType env t 1483 val t = monoType env t
1480 in 1484 in
1481 ((L'.EAbs ("c", s, (L'.TFun (un, s), loc), 1485 ((L'.EAbs ("c", s, (L'.TFun (un, s), loc),
1482 (L'.EAbs ("_", un, s, 1486 (L'.EAbs ("_", un, s,
1483 (L'.EUnurlify ((L'.EFfiApp ("Basis", "get_cookie", [(L'.ERel 1, loc)]), loc), 1487 (L'.EUnurlify ((L'.EFfiApp ("Basis", "get_cookie", [((L'.ERel 1, loc), s)]), loc),
1484 t, true), 1488 t, true),
1485 loc)), loc)), loc), 1489 loc)), loc)), loc),
1486 fm) 1490 fm)
1487 end 1491 end
1488 1492
1500 val (e, fm) = urlifyExp env fm (fd "Value", t) 1504 val (e, fm) = urlifyExp env fm (fd "Value", t)
1501 in 1505 in
1502 ((L'.EAbs ("c", s, (L'.TFun (rt, (L'.TFun (un, un), loc)), loc), 1506 ((L'.EAbs ("c", s, (L'.TFun (rt, (L'.TFun (un, un), loc)), loc),
1503 (L'.EAbs ("r", rt, (L'.TFun (un, un), loc), 1507 (L'.EAbs ("r", rt, (L'.TFun (un, un), loc),
1504 (L'.EAbs ("_", un, un, 1508 (L'.EAbs ("_", un, un,
1505 (L'.EFfiApp ("Basis", "set_cookie", [(L'.EPrim (Prim.String 1509 (L'.EFfiApp ("Basis", "set_cookie", [((L'.EPrim (Prim.String
1506 (Settings.getUrlPrefix ())), 1510 (Settings.getUrlPrefix ())),
1507 loc), 1511 loc), s),
1508 (L'.ERel 2, loc), 1512 ((L'.ERel 2, loc), s),
1509 e, 1513 (e, s),
1510 fd "Expires", 1514 (fd "Expires", (L'.TOption (L'.TFfi ("Basis", "time"), loc), loc)),
1511 fd "Secure"]) 1515 (fd "Secure", (L'.TFfi ("Basis", "bool"), loc))])
1512 , loc)), loc)), loc)), loc), 1516 , loc)), loc)), loc)), loc),
1513 fm) 1517 fm)
1514 end 1518 end
1515 1519
1516 | L.ECApp ((L.EFfi ("Basis", "clearCookie"), _), t) => 1520 | L.ECApp ((L.EFfi ("Basis", "clearCookie"), _), t) =>
1519 val un = (L'.TRecord [], loc) 1523 val un = (L'.TRecord [], loc)
1520 in 1524 in
1521 ((L'.EAbs ("c", s, (L'.TFun (un, un), loc), 1525 ((L'.EAbs ("c", s, (L'.TFun (un, un), loc),
1522 (L'.EAbs ("_", un, un, 1526 (L'.EAbs ("_", un, un,
1523 (L'.EFfiApp ("Basis", "clear_cookie", 1527 (L'.EFfiApp ("Basis", "clear_cookie",
1524 [(L'.EPrim (Prim.String 1528 [((L'.EPrim (Prim.String
1525 (Settings.getUrlPrefix ())), 1529 (Settings.getUrlPrefix ())),
1526 loc), 1530 loc), s),
1527 (L'.ERel 1, loc)]), 1531 ((L'.ERel 1, loc), s)]),
1528 loc)), loc)), loc), 1532 loc)), loc)), loc),
1529 fm) 1533 fm)
1530 end 1534 end
1531 1535
1532 | L.ECApp ((L.EFfi ("Basis", "channel"), _), t) => 1536 | L.ECApp ((L.EFfi ("Basis", "channel"), _), t) =>
1533 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "channel"), loc), 1537 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "channel"), loc),
1534 (L'.EFfiApp ("Basis", "new_channel", [(L'.ERecord [], loc)]), loc)), loc), 1538 (L'.EFfiApp ("Basis", "new_channel", [((L'.ERecord [], loc), (L'.TRecord [], loc))]), loc)), loc),
1535 fm) 1539 fm)
1536 | L.ECApp ((L.EFfi ("Basis", "send"), _), t) => 1540 | L.ECApp ((L.EFfi ("Basis", "send"), _), t) =>
1537 let 1541 let
1538 val t = monoType env t 1542 val t = monoType env t
1539 val (e, fm) = urlifyExp env fm ((L'.ERel 1, loc), t) 1543 val (e, fm) = urlifyExp env fm ((L'.ERel 1, loc), t)
1541 ((L'.EAbs ("ch", (L'.TFfi ("Basis", "channel"), loc), 1545 ((L'.EAbs ("ch", (L'.TFfi ("Basis", "channel"), loc),
1542 (L'.TFun (t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc)), loc), 1546 (L'.TFun (t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc)), loc),
1543 (L'.EAbs ("v", t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc), 1547 (L'.EAbs ("v", t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc),
1544 (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc), 1548 (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
1545 (L'.EFfiApp ("Basis", "send", 1549 (L'.EFfiApp ("Basis", "send",
1546 [(L'.ERel 2, loc), 1550 [((L'.ERel 2, loc), (L'.TFfi ("Basis", "channel"), loc)),
1547 e]), 1551 (e, (L'.TFfi ("Basis", "string"), loc))]),
1548 loc)), loc)), loc)), loc), 1552 loc)), loc)), loc)), loc),
1549 fm) 1553 fm)
1550 end 1554 end
1551 1555
1552 | L.ECApp ((L.EFfi ("Basis", "no_primary_key"), _), _) => 1556 | L.ECApp ((L.EFfi ("Basis", "no_primary_key"), _), _) =>
1761 val string = (L'.TFfi ("Basis", "string"), loc) 1765 val string = (L'.TFfi ("Basis", "string"), loc)
1762 in 1766 in
1763 ((L'.EAbs ("e", string, string, 1767 ((L'.EAbs ("e", string, string,
1764 (L'.EStrcat ((L'.EPrim (Prim.String "CHECK "), loc), 1768 (L'.EStrcat ((L'.EPrim (Prim.String "CHECK "), loc),
1765 (L'.EFfiApp ("Basis", "checkString", 1769 (L'.EFfiApp ("Basis", "checkString",
1766 [(L'.ERel 0, loc)]), loc)), loc)), loc), 1770 [((L'.ERel 0, loc), string)]), loc)), loc)), loc),
1767 fm) 1771 fm)
1768 end 1772 end
1769 1773
1770 | L.EFfiApp ("Basis", "dml", [e]) => 1774 | L.EFfiApp ("Basis", "dml", [(e, _)]) =>
1771 let 1775 let
1772 val (e, fm) = monoExp (env, st, fm) e 1776 val (e, fm) = monoExp (env, st, fm) e
1773 in 1777 in
1774 ((L'.EDml (e, L'.Error), loc), 1778 ((L'.EDml (e, L'.Error), loc),
1775 fm) 1779 fm)
1776 end 1780 end
1777 1781
1778 | L.EFfiApp ("Basis", "tryDml", [e]) => 1782 | L.EFfiApp ("Basis", "tryDml", [(e, _)]) =>
1779 let 1783 let
1780 val (e, fm) = monoExp (env, st, fm) e 1784 val (e, fm) = monoExp (env, st, fm) e
1781 in 1785 in
1782 ((L'.EDml (e, L'.None), loc), 1786 ((L'.EDml (e, L'.None), loc),
1783 fm) 1787 fm)
1839 sc " SET ", 1843 sc " SET ",
1840 strcatComma (map (fn (x, _) => 1844 strcatComma (map (fn (x, _) =>
1841 strcat [sc ("uw_" ^ x 1845 strcat [sc ("uw_" ^ x
1842 ^ " = "), 1846 ^ " = "),
1843 (L'.EFfiApp ("Basis", "unAs", 1847 (L'.EFfiApp ("Basis", "unAs",
1844 [(L'.EField 1848 [((L'.EField
1845 ((L'.ERel 2, 1849 ((L'.ERel 2,
1846 loc), 1850 loc),
1847 x), loc)]), loc)]) 1851 x), loc),
1852 s)]), loc)])
1848 changed), 1853 changed),
1849 sc " WHERE ", 1854 sc " WHERE ",
1850 (L'.EFfiApp ("Basis", "unAs", [(L'.ERel 0, loc)]), loc)]), 1855 (L'.EFfiApp ("Basis", "unAs", [((L'.ERel 0, loc), s)]), loc)]),
1851 loc)), loc)), loc), 1856 loc)), loc)), loc),
1852 fm) 1857 fm)
1853 end 1858 end
1854 | _ => poly ()) 1859 | _ => poly ())
1855 1860
1867 (L'.ERel 0, loc)] 1872 (L'.ERel 0, loc)]
1868 else 1873 else
1869 strcat [sc "DELETE FROM ", 1874 strcat [sc "DELETE FROM ",
1870 (L'.ERel 1, loc), 1875 (L'.ERel 1, loc),
1871 sc " WHERE ", 1876 sc " WHERE ",
1872 (L'.EFfiApp ("Basis", "unAs", [(L'.ERel 0, loc)]), loc)]), loc)), loc), 1877 (L'.EFfiApp ("Basis", "unAs", [((L'.ERel 0, loc), s)]), loc)]), loc)), loc),
1873 fm) 1878 fm)
1874 end 1879 end
1875 1880
1876 | L.ECApp ( 1881 | L.ECApp (
1877 (L.ECApp ( 1882 (L.ECApp (
2106 (L'.ERel 0, loc)), loc), fm) 2111 (L'.ERel 0, loc)), loc), fm)
2107 end 2112 end
2108 2113
2109 | L.EFfi ("Basis", "sql_int") => 2114 | L.EFfi ("Basis", "sql_int") =>
2110 ((L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "string"), loc), 2115 ((L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "string"), loc),
2111 (L'.EFfiApp ("Basis", "sqlifyInt", [(L'.ERel 0, loc)]), loc)), loc), 2116 (L'.EFfiApp ("Basis", "sqlifyInt", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "int"), loc))]), loc)), loc),
2112 fm) 2117 fm)
2113 | L.EFfi ("Basis", "sql_float") => 2118 | L.EFfi ("Basis", "sql_float") =>
2114 ((L'.EAbs ("x", (L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "string"), loc), 2119 ((L'.EAbs ("x", (L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "string"), loc),
2115 (L'.EFfiApp ("Basis", "sqlifyFloat", [(L'.ERel 0, loc)]), loc)), loc), 2120 (L'.EFfiApp ("Basis", "sqlifyFloat", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "float"), loc))]), loc)), loc),
2116 fm) 2121 fm)
2117 | L.EFfi ("Basis", "sql_bool") => 2122 | L.EFfi ("Basis", "sql_bool") =>
2118 ((L'.EAbs ("x", (L'.TFfi ("Basis", "bool"), loc), (L'.TFfi ("Basis", "string"), loc), 2123 ((L'.EAbs ("x", (L'.TFfi ("Basis", "bool"), loc), (L'.TFfi ("Basis", "string"), loc),
2119 (L'.EFfiApp ("Basis", "sqlifyBool", [(L'.ERel 0, loc)]), loc)), loc), 2124 (L'.EFfiApp ("Basis", "sqlifyBool", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "bool"), loc))]), loc)), loc),
2120 fm) 2125 fm)
2121 | L.EFfi ("Basis", "sql_string") => 2126 | L.EFfi ("Basis", "sql_string") =>
2122 ((L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "string"), loc), 2127 ((L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "string"), loc),
2123 (L'.EFfiApp ("Basis", "sqlifyString", [(L'.ERel 0, loc)]), loc)), loc), 2128 (L'.EFfiApp ("Basis", "sqlifyString", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "string"), loc))]), loc)), loc),
2124 fm) 2129 fm)
2125 | L.EFfi ("Basis", "sql_char") => 2130 | L.EFfi ("Basis", "sql_char") =>
2126 ((L'.EAbs ("x", (L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "string"), loc), 2131 ((L'.EAbs ("x", (L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "string"), loc),
2127 (L'.EFfiApp ("Basis", "sqlifyChar", [(L'.ERel 0, loc)]), loc)), loc), 2132 (L'.EFfiApp ("Basis", "sqlifyChar", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "char"), loc))]), loc)), loc),
2128 fm) 2133 fm)
2129 | L.EFfi ("Basis", "sql_time") => 2134 | L.EFfi ("Basis", "sql_time") =>
2130 ((L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "string"), loc), 2135 ((L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "string"), loc),
2131 (L'.EFfiApp ("Basis", "sqlifyTime", [(L'.ERel 0, loc)]), loc)), loc), 2136 (L'.EFfiApp ("Basis", "sqlifyTime", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "time"), loc))]), loc)), loc),
2132 fm) 2137 fm)
2133 | L.EFfi ("Basis", "sql_blob") => 2138 | L.EFfi ("Basis", "sql_blob") =>
2134 ((L'.EAbs ("x", (L'.TFfi ("Basis", "blob"), loc), (L'.TFfi ("Basis", "string"), loc), 2139 ((L'.EAbs ("x", (L'.TFfi ("Basis", "blob"), loc), (L'.TFfi ("Basis", "string"), loc),
2135 (L'.EFfiApp ("Basis", "sqlifyBlob", [(L'.ERel 0, loc)]), loc)), loc), 2140 (L'.EFfiApp ("Basis", "sqlifyBlob", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "blob"), loc))]), loc)), loc),
2136 fm) 2141 fm)
2137 | L.ECApp ((L.EFfi ("Basis", "sql_channel"), _), _) => 2142 | L.ECApp ((L.EFfi ("Basis", "sql_channel"), _), _) =>
2138 ((L'.EAbs ("x", (L'.TFfi ("Basis", "channel"), loc), (L'.TFfi ("Basis", "string"), loc), 2143 ((L'.EAbs ("x", (L'.TFfi ("Basis", "channel"), loc), (L'.TFfi ("Basis", "string"), loc),
2139 (L'.EFfiApp ("Basis", "sqlifyChannel", [(L'.ERel 0, loc)]), loc)), loc), 2144 (L'.EFfiApp ("Basis", "sqlifyChannel", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "channel"), loc))]), loc)), loc),
2140 fm) 2145 fm)
2141 | L.EFfi ("Basis", "sql_client") => 2146 | L.EFfi ("Basis", "sql_client") =>
2142 ((L'.EAbs ("x", (L'.TFfi ("Basis", "client"), loc), (L'.TFfi ("Basis", "string"), loc), 2147 ((L'.EAbs ("x", (L'.TFfi ("Basis", "client"), loc), (L'.TFfi ("Basis", "string"), loc),
2143 (L'.EFfiApp ("Basis", "sqlifyClient", [(L'.ERel 0, loc)]), loc)), loc), 2148 (L'.EFfiApp ("Basis", "sqlifyClient", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "client"), loc))]), loc)), loc),
2144 fm) 2149 fm)
2145 | L.ECApp ((L.EFfi ("Basis", "sql_serialized"), _), _) => 2150 | L.ECApp ((L.EFfi ("Basis", "sql_serialized"), _), _) =>
2146 ((L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "string"), loc), 2151 ((L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "string"), loc),
2147 (L'.EFfiApp ("Basis", "sqlifyString", [(L'.ERel 0, loc)]), loc)), loc), 2152 (L'.EFfiApp ("Basis", "sqlifyString", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "string"), loc))]), loc)), loc),
2148 fm) 2153 fm)
2149 | L.ECApp ((L.EFfi ("Basis", "sql_prim"), _), t) => 2154 | L.ECApp ((L.EFfi ("Basis", "sql_prim"), _), t) =>
2150 let 2155 let
2151 val t = monoType env t 2156 val t = monoType env t
2152 val tf = (L'.TFun (t, (L'.TFfi ("Basis", "string"), loc)), loc) 2157 val tf = (L'.TFun (t, (L'.TFfi ("Basis", "string"), loc)), loc)
2428 fm) 2433 fm)
2429 end 2434 end
2430 2435
2431 | L.EFfi ("Basis", "sql_no_limit") => 2436 | L.EFfi ("Basis", "sql_no_limit") =>
2432 ((L'.EPrim (Prim.String ""), loc), fm) 2437 ((L'.EPrim (Prim.String ""), loc), fm)
2433 | L.EFfiApp ("Basis", "sql_limit", [e]) => 2438 | L.EFfiApp ("Basis", "sql_limit", [(e, t)]) =>
2434 let 2439 let
2435 val (e, fm) = monoExp (env, st, fm) e 2440 val (e, fm) = monoExp (env, st, fm) e
2436 in 2441 in
2437 (strcat [ 2442 (strcat [
2438 (L'.EPrim (Prim.String " LIMIT "), loc), 2443 (L'.EPrim (Prim.String " LIMIT "), loc),
2439 (L'.EFfiApp ("Basis", "sqlifyInt", [e]), loc) 2444 (L'.EFfiApp ("Basis", "sqlifyInt", [(e, monoType env t)]), loc)
2440 ], 2445 ],
2441 fm) 2446 fm)
2442 end 2447 end
2443 2448
2444 | L.EFfi ("Basis", "sql_no_offset") => 2449 | L.EFfi ("Basis", "sql_no_offset") =>
2445 ((L'.EPrim (Prim.String ""), loc), fm) 2450 ((L'.EPrim (Prim.String ""), loc), fm)
2446 | L.EFfiApp ("Basis", "sql_offset", [e]) => 2451 | L.EFfiApp ("Basis", "sql_offset", [(e, t)]) =>
2447 let 2452 let
2448 val (e, fm) = monoExp (env, st, fm) e 2453 val (e, fm) = monoExp (env, st, fm) e
2449 in 2454 in
2450 (strcat [ 2455 (strcat [
2451 (L'.EPrim (Prim.String " OFFSET "), loc), 2456 (L'.EPrim (Prim.String " OFFSET "), loc),
2452 (L'.EFfiApp ("Basis", "sqlifyInt", [e]), loc) 2457 (L'.EFfiApp ("Basis", "sqlifyInt", [(e, monoType env t)]), loc)
2453 ], 2458 ],
2454 fm) 2459 fm)
2455 end 2460 end
2456 2461
2457 | L.ECApp ((L.EFfi ("Basis", "sql_eq"), _), _) => 2462 | L.ECApp ((L.EFfi ("Basis", "sql_eq"), _), _) =>
2912 (L'.ERel 0, loc), 2917 (L'.ERel 0, loc),
2913 sc ")"]), loc)), loc), 2918 sc ")"]), loc)), loc),
2914 fm) 2919 fm)
2915 end 2920 end
2916 2921
2917 | L.EFfiApp ("Basis", "nextval", [e]) => 2922 | L.EFfiApp ("Basis", "nextval", [(e, _)]) =>
2918 let 2923 let
2919 val (e, fm) = monoExp (env, st, fm) e 2924 val (e, fm) = monoExp (env, st, fm) e
2920 in 2925 in
2921 ((L'.ENextval e, loc), fm) 2926 ((L'.ENextval e, loc), fm)
2922 end 2927 end
2923 | L.EFfiApp ("Basis", "setval", [e1, e2]) => 2928 | L.EFfiApp ("Basis", "setval", [(e1, _), (e2, _)]) =>
2924 let 2929 let
2925 val (e1, fm) = monoExp (env, st, fm) e1 2930 val (e1, fm) = monoExp (env, st, fm) e1
2926 val (e2, fm) = monoExp (env, st, fm) e2 2931 val (e2, fm) = monoExp (env, st, fm) e2
2927 in 2932 in
2928 ((L'.ESetval (e1, e2), loc), fm) 2933 ((L'.ESetval (e1, e2), loc), fm)
2929 end 2934 end
2930 2935
2931 | L.EFfi ("Basis", "null") => ((L'.EPrim (Prim.String ""), loc), fm) 2936 | L.EFfi ("Basis", "null") => ((L'.EPrim (Prim.String ""), loc), fm)
2932 2937
2933 | L.EFfiApp ("Basis", "classes", [s1, s2]) => 2938 | L.EFfiApp ("Basis", "classes", [(s1, _), (s2, _)]) =>
2934 let 2939 let
2935 val (s1, fm) = monoExp (env, st, fm) s1 2940 val (s1, fm) = monoExp (env, st, fm) s1
2936 val (s2, fm) = monoExp (env, st, fm) s2 2941 val (s2, fm) = monoExp (env, st, fm) s2
2937 in 2942 in
2938 ((L'.EStrcat (s1, (L'.EStrcat ((L'.EPrim (Prim.String " "), loc), s2), loc)), loc), 2943 ((L'.EStrcat (s1, (L'.EStrcat ((L'.EPrim (Prim.String " "), loc), s2), loc)), loc),
2945 _), _), 2950 _), _),
2946 se) => 2951 se) =>
2947 let 2952 let
2948 val (se, fm) = monoExp (env, st, fm) se 2953 val (se, fm) = monoExp (env, st, fm) se
2949 in 2954 in
2950 ((L'.EFfiApp ("Basis", "htmlifyString", [se]), loc), fm) 2955 ((L'.EFfiApp ("Basis", "htmlifyString", [(se, (L'.TFfi ("Basis", "string"), loc))]), loc), fm)
2951 end 2956 end
2952 | L.ECApp ( 2957 | L.ECApp (
2953 (L.ECApp ((L.EFfi ("Basis", "cdataChar"), _), _), _), 2958 (L.ECApp ((L.EFfi ("Basis", "cdataChar"), _), _), _),
2954 _) => 2959 _) =>
2955 ((L'.EAbs ("ch", (L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "string"), loc), 2960 ((L'.EAbs ("ch", (L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "string"), loc),
2956 (L'.EFfiApp ("Basis", "htmlifySpecialChar", [(L'.ERel 0, loc)]), loc)), loc), fm) 2961 (L'.EFfiApp ("Basis", "htmlifySpecialChar", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "char"), loc))]), loc)), loc), fm)
2957 2962
2958 | L.EApp ( 2963 | L.EApp (
2959 (L.EApp ( 2964 (L.EApp (
2960 (L.ECApp ( 2965 (L.ECApp (
2961 (L.ECApp ( 2966 (L.ECApp (
3008 Print.eprefaces' [("Expression", CorePrint.p_exp env tag)]; 3013 Print.eprefaces' [("Expression", CorePrint.p_exp env tag)];
3009 ("", [])) 3014 ("", []))
3010 3015
3011 fun getTag (e, _) = 3016 fun getTag (e, _) =
3012 case e of 3017 case e of
3013 L.EFfiApp ("Basis", tag, [(L.ERecord [], _)]) => (tag, []) 3018 L.EFfiApp ("Basis", tag, [((L.ERecord [], _), _)]) => (tag, [])
3014 | L.EApp (e, (L.ERecord [], _)) => getTag' e 3019 | L.EApp (e, (L.ERecord [], _)) => getTag' e
3015 | _ => (E.errorAt loc "Non-constant XML tag"; 3020 | _ => (E.errorAt loc "Non-constant XML tag";
3016 Print.eprefaces' [("Expression", CorePrint.p_exp env tag)]; 3021 Print.eprefaces' [("Expression", CorePrint.p_exp env tag)];
3017 ("", [])) 3022 ("", []))
3018 3023
3295 val baseAll as (base, fm) = 3300 val baseAll as (base, fm) =
3296 case tag of 3301 case tag of
3297 "body" => let 3302 "body" => let
3298 val onload = execify onload 3303 val onload = execify onload
3299 val onunload = execify onunload 3304 val onunload = execify onunload
3305 val s = (L'.TFfi ("Basis", "string"), loc)
3300 in 3306 in
3301 normal ("body", 3307 normal ("body",
3302 SOME (L'.EStrcat ((L'.EFfiApp ("Basis", "maybe_onload", 3308 SOME (L'.EStrcat ((L'.EFfiApp ("Basis", "maybe_onload",
3303 [(L'.EStrcat ((L'.EFfiApp ("Basis", "get_settings", 3309 [((L'.EStrcat ((L'.EFfiApp ("Basis", "get_settings",
3304 [(L'.ERecord [], loc)]), loc), 3310 [((L'.ERecord [], loc),
3305 onload), loc)]), 3311 (L'.TRecord [], loc))]), loc),
3312 onload), loc),
3313 s)]),
3306 loc), 3314 loc),
3307 (L'.EFfiApp ("Basis", "maybe_onunload", 3315 (L'.EFfiApp ("Basis", "maybe_onunload",
3308 [onunload]), 3316 [(onunload, s)]),
3309 loc)), loc), 3317 loc)), loc),
3310 SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc)) 3318 SOME (L'.EFfiApp ("Basis", "get_script", [((L'.ERecord [], loc), (L'.TRecord [], loc))]), loc))
3311 end 3319 end
3312 3320
3313 | "dyn" => 3321 | "dyn" =>
3314 let 3322 let
3315 fun inTag tag = case targs of 3323 fun inTag tag = case targs of
3643 else 3651 else
3644 "Sig" 3652 "Sig"
3645 end 3653 end
3646 3654
3647 val sigName = getSigName () 3655 val sigName = getSigName ()
3648 val sigSet = (L'.EFfiApp ("Basis", "sigString", [(L'.ERecord [], loc)]), loc) 3656 val sigSet = (L'.EFfiApp ("Basis", "sigString", [((L'.ERecord [], loc), (L'.TRecord [], loc))]), loc)
3649 val sigSet = (L'.EStrcat ((L'.EPrim (Prim.String ("<input type=\"hidden\" name=\"" 3657 val sigSet = (L'.EStrcat ((L'.EPrim (Prim.String ("<input type=\"hidden\" name=\""
3650 ^ sigName 3658 ^ sigName
3651 ^ "\" value=\"")), loc), 3659 ^ "\" value=\"")), loc),
3652 sigSet), loc) 3660 sigSet), loc)
3653 val sigSet = (L'.EStrcat (sigSet, 3661 val sigSet = (L'.EStrcat (sigSet,
3786 ((L'.EAbs ("v", (L'.TFfi ("Basis", "string"), loc), t, (L'.EUnurlify ((L'.ERel 0, loc), t, false), 3794 ((L'.EAbs ("v", (L'.TFfi ("Basis", "string"), loc), t, (L'.EUnurlify ((L'.ERel 0, loc), t, false),
3787 loc)), loc), 3795 loc)), loc),
3788 fm) 3796 fm)
3789 end 3797 end
3790 3798
3791 | L.EFfiApp ("Basis", "url", [e]) => 3799 | L.EFfiApp ("Basis", "url", [(e, _)]) =>
3792 let 3800 let
3793 val (e, fm) = monoExp (env, st, fm) e 3801 val (e, fm) = monoExp (env, st, fm) e
3794 val (e, fm) = urlifyExp env fm (e, dummyTyp) 3802 val (e, fm) = urlifyExp env fm (e, dummyTyp)
3795 in 3803 in
3796 ((L'.EStrcat ((L'.EPrim (Prim.String (Settings.getUrlPrePrefix ())), loc), e), loc), fm) 3804 ((L'.EStrcat ((L'.EPrim (Prim.String (Settings.getUrlPrePrefix ())), loc), e), loc), fm)
3813 | L.ECAbs _ => poly () 3821 | L.ECAbs _ => poly ()
3814 3822
3815 | L.EFfi mx => ((L'.EFfi mx, loc), fm) 3823 | L.EFfi mx => ((L'.EFfi mx, loc), fm)
3816 | L.EFfiApp (m, x, es) => 3824 | L.EFfiApp (m, x, es) =>
3817 let 3825 let
3818 val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es 3826 val (es, fm) = ListUtil.foldlMap (fn ((e, t), fm) =>
3827 let
3828 val (e, fm) = monoExp (env, st, fm) e
3829 in
3830 ((e, monoType env t), fm)
3831 end) fm es
3819 in 3832 in
3820 ((L'.EFfiApp (m, x, es), loc), fm) 3833 ((L'.EFfiApp (m, x, es), loc), fm)
3821 end 3834 end
3822 3835
3823 | L.ERecord xes => 3836 | L.ERecord xes =>
4052 val e_name = (L'.EPrim (Prim.String s), loc) 4065 val e_name = (L'.EPrim (Prim.String s), loc)
4053 4066
4054 val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts 4067 val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
4055 4068
4056 val (e, fm) = monoExp (env, St.empty, fm) e 4069 val (e, fm) = monoExp (env, St.empty, fm) e
4057 val e = (L'.EFfiApp ("Basis", "viewify", [e]), loc) 4070 val e = (L'.EFfiApp ("Basis", "viewify", [(e, t')]), loc)
4058 in 4071 in
4059 SOME (Env.pushENamed env x n t NONE s, 4072 SOME (Env.pushENamed env x n t NONE s,
4060 fm, 4073 fm,
4061 [(L'.DView (s, xts, e), loc), 4074 [(L'.DView (s, xts, e), loc),
4062 (L'.DVal (x, n, t', e_name, s), loc)]) 4075 (L'.DVal (x, n, t', e_name, s), loc)])
4108 end 4121 end
4109 | L.DPolicy e => 4122 | L.DPolicy e =>
4110 let 4123 let
4111 fun policies (e, fm) = 4124 fun policies (e, fm) =
4112 case #1 e of 4125 case #1 e of
4113 L.EFfiApp ("Basis", "also", [e1, e2]) => 4126 L.EFfiApp ("Basis", "also", [(e1, _), (e2, _)]) =>
4114 let 4127 let
4115 val (ps1, fm) = policies (e1, fm) 4128 val (ps1, fm) = policies (e1, fm)
4116 val (ps2, fm) = policies (e2, fm) 4129 val (ps2, fm) = policies (e2, fm)
4117 in 4130 in
4118 (ps1 @ ps2, fm) 4131 (ps1 @ ps2, fm)
4127 (e, L'.PolInsert) 4140 (e, L'.PolInsert)
4128 | L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "mayDelete"), _), _), _), _), _), e) => 4141 | L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "mayDelete"), _), _), _), _), _), e) =>
4129 (e, L'.PolDelete) 4142 (e, L'.PolDelete)
4130 | L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "mayUpdate"), _), _), _), _), _), e) => 4143 | L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "mayUpdate"), _), _), _), _), _), e) =>
4131 (e, L'.PolUpdate) 4144 (e, L'.PolUpdate)
4132 | L.EFfiApp ("Basis", "sendOwnIds", [e]) => 4145 | L.EFfiApp ("Basis", "sendOwnIds", [(e, _)]) =>
4133 (e, L'.PolSequence) 4146 (e, L'.PolSequence)
4134 | _ => (poly (); (e, L'.PolClient)) 4147 | _ => (poly (); (e, L'.PolClient))
4135 4148
4136 val (e, fm) = monoExp (env, St.empty, fm) e 4149 val (e, fm) = monoExp (env, St.empty, fm) e
4137 in 4150 in
4184 | _ => st) 4197 | _ => st)
4185 | _ => st) ([], []) xts 4198 | _ => st) ([], []) xts
4186 4199
4187 fun expunger () = 4200 fun expunger () =
4188 let 4201 let
4189 val target = (L'.EFfiApp ("Basis", "sqlifyClient", [(L'.ERel 0, loc)]), loc) 4202 val target = (L'.EFfiApp ("Basis", "sqlifyClient", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "client"), loc))]), loc)
4190 4203
4191 fun doTable (tab, xts, e) = 4204 fun doTable (tab, xts, e) =
4192 case xts of 4205 case xts of
4193 L.CRecord (_, xts) => 4206 L.CRecord (_, xts) =>
4194 let 4207 let