Mercurial > urweb

comparison src/monoize.sml @ 598:4c2c740c6931

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Hooking a source into an input
author Adam Chlipala <adamc@hcoop.net>
date Sun, 11 Jan 2009 10:05:06 -0500
parents 57f476c934da
children 889dc9fceb3a
comparison
equal deleted inserted replaced
597:d49d58a69877 598:4c2c740c6931
508 508
509 fun strcatR loc e xs = strcatComma loc (map (fn (x, _) => (L'.EField (e, x), loc)) xs) 509 fun strcatR loc e xs = strcatComma loc (map (fn (x, _) => (L'.EField (e, x), loc)) xs)
510 510
511 fun monoExp (env, st, fm) (all as (e, loc)) = 511 fun monoExp (env, st, fm) (all as (e, loc)) =
512 let 512 let
513 val strcat = strcat loc
514 val strcatComma = strcatComma loc
515 fun str s = (L'.EPrim (Prim.String s), loc)
516
513 fun poly () = 517 fun poly () =
514 (E.errorAt loc "Unsupported expression"; 518 (E.errorAt loc "Unsupported expression";
515 Print.eprefaces' [("Expression", CorePrint.p_exp env all)]; 519 Print.eprefaces' [("Expression", CorePrint.p_exp env all)];
516 (dummyExp, fm)) 520 (dummyExp, fm))
517 521
1078 val rt = (L'.TRecord fields, loc) 1082 val rt = (L'.TRecord fields, loc)
1079 fun sc s = (L'.EPrim (Prim.String s), loc) 1083 fun sc s = (L'.EPrim (Prim.String s), loc)
1080 in 1084 in
1081 ((L'.EAbs ("tab", s, (L'.TFun (rt, s), loc), 1085 ((L'.EAbs ("tab", s, (L'.TFun (rt, s), loc),
1082 (L'.EAbs ("fs", rt, s, 1086 (L'.EAbs ("fs", rt, s,
1083 strcat loc [sc "INSERT INTO ", 1087 strcat [sc "INSERT INTO ",
1084 (L'.ERel 1, loc), 1088 (L'.ERel 1, loc),
1085 sc " (", 1089 sc " (",
1086 strcatComma loc (map (fn (x, _) => sc ("uw_" ^ x)) fields), 1090 strcatComma (map (fn (x, _) => sc ("uw_" ^ x)) fields),
1087 sc ") VALUES (", 1091 sc ") VALUES (",
1088 strcatComma loc (map (fn (x, _) => 1092 strcatComma (map (fn (x, _) =>
1089 (L'.EField ((L'.ERel 0, loc), 1093 (L'.EField ((L'.ERel 0, loc),
1090 x), loc)) fields), 1094 x), loc)) fields),
1091 sc ")"]), loc)), loc), 1095 sc ")"]), loc)), loc),
1092 fm) 1096 fm)
1093 end 1097 end
1094 | _ => poly ()) 1098 | _ => poly ())
1095 1099
1096 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "update"), _), _), _), changed) => 1100 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "update"), _), _), _), changed) =>
1103 fun sc s = (L'.EPrim (Prim.String s), loc) 1107 fun sc s = (L'.EPrim (Prim.String s), loc)
1104 in 1108 in
1105 ((L'.EAbs ("fs", rt, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), 1109 ((L'.EAbs ("fs", rt, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
1106 (L'.EAbs ("tab", s, (L'.TFun (s, s), loc), 1110 (L'.EAbs ("tab", s, (L'.TFun (s, s), loc),
1107 (L'.EAbs ("e", s, s, 1111 (L'.EAbs ("e", s, s,
1108 strcat loc [sc "UPDATE ", 1112 strcat [sc "UPDATE ",
1109 (L'.ERel 1, loc), 1113 (L'.ERel 1, loc),
1110 sc " AS T SET ", 1114 sc " AS T SET ",
1111 strcatComma loc (map (fn (x, _) => 1115 strcatComma (map (fn (x, _) =>
1112 strcat loc [sc ("uw_" ^ x 1116 strcat [sc ("uw_" ^ x
1113 ^ " = "), 1117 ^ " = "),
1114 (L'.EField 1118 (L'.EField
1115 ((L'.ERel 2, 1119 ((L'.ERel 2,
1116 loc), 1120 loc),
1117 x), loc)]) 1121 x), loc)])
1118 changed), 1122 changed),
1119 sc " WHERE ", 1123 sc " WHERE ",
1120 (L'.ERel 0, loc)]), loc)), loc)), loc), 1124 (L'.ERel 0, loc)]), loc)), loc)), loc),
1121 fm) 1125 fm)
1122 end 1126 end
1123 | _ => poly ()) 1127 | _ => poly ())
1124 1128
1125 | L.ECApp ((L.EFfi ("Basis", "delete"), _), _) => 1129 | L.ECApp ((L.EFfi ("Basis", "delete"), _), _) =>
1127 val s = (L'.TFfi ("Basis", "string"), loc) 1131 val s = (L'.TFfi ("Basis", "string"), loc)
1128 fun sc s = (L'.EPrim (Prim.String s), loc) 1132 fun sc s = (L'.EPrim (Prim.String s), loc)
1129 in 1133 in
1130 ((L'.EAbs ("tab", s, (L'.TFun (s, s), loc), 1134 ((L'.EAbs ("tab", s, (L'.TFun (s, s), loc),
1131 (L'.EAbs ("e", s, s, 1135 (L'.EAbs ("e", s, s,
1132 strcat loc [sc "DELETE FROM ", 1136 strcat [sc "DELETE FROM ",
1133 (L'.ERel 1, loc), 1137 (L'.ERel 1, loc),
1134 sc " AS T WHERE ", 1138 sc " AS T WHERE ",
1135 (L'.ERel 0, loc)]), loc)), loc), 1139 (L'.ERel 0, loc)]), loc)), loc),
1136 fm) 1140 fm)
1137 end 1141 end
1138 1142
1139 | L.ECApp ( 1143 | L.ECApp (
1140 (L.ECApp ( 1144 (L.ECApp (
1196 fun gf s = (L'.EField ((L'.ERel 0, loc), s), loc) 1200 fun gf s = (L'.EField ((L'.ERel 0, loc), s), loc)
1197 in 1201 in
1198 ((L'.EAbs ("r", 1202 ((L'.EAbs ("r",
1199 (L'.TRecord [("Rows", s), ("OrderBy", s), ("Limit", s), ("Offset", s)], loc), 1203 (L'.TRecord [("Rows", s), ("OrderBy", s), ("Limit", s), ("Offset", s)], loc),
1200 s, 1204 s,
1201 strcat loc [gf "Rows", 1205 strcat [gf "Rows",
1202 (L'.ECase (gf "OrderBy", 1206 (L'.ECase (gf "OrderBy",
1203 [((L'.PPrim (Prim.String ""), loc), sc ""), 1207 [((L'.PPrim (Prim.String ""), loc), sc ""),
1204 ((L'.PWild, loc), 1208 ((L'.PWild, loc),
1205 strcat loc [sc " ORDER BY ", 1209 strcat [sc " ORDER BY ",
1206 gf "OrderBy"])], 1210 gf "OrderBy"])],
1207 {disc = s, result = s}), loc), 1211 {disc = s, result = s}), loc),
1208 gf "Limit", 1212 gf "Limit",
1209 gf "Offset"]), loc), fm) 1213 gf "Offset"]), loc), fm)
1210 end 1214 end
1211 1215
1212 | L.ECApp ( 1216 | L.ECApp (
1213 (L.ECApp ( 1217 (L.ECApp (
1214 (L.ECApp ( 1218 (L.ECApp (
1262 ("Having", s), 1266 ("Having", s),
1263 ("SelectFields", un), 1267 ("SelectFields", un),
1264 ("SelectExps", (L'.TRecord (map (fn (x, _) => (x, s)) sexps), loc))], 1268 ("SelectExps", (L'.TRecord (map (fn (x, _) => (x, s)) sexps), loc))],
1265 loc), 1269 loc),
1266 s, 1270 s,
1267 strcat loc [sc "SELECT ", 1271 strcat [sc "SELECT ",
1268 strcatComma loc (map (fn (x, t) => 1272 strcatComma (map (fn (x, t) =>
1269 strcat loc [ 1273 strcat [
1270 (L'.EField (gf "SelectExps", x), loc), 1274 (L'.EField (gf "SelectExps", x), loc),
1271 sc (" AS _" ^ x) 1275 sc (" AS _" ^ x)
1272 ]) sexps 1276 ]) sexps
1273 @ map (fn (x, xts) => 1277 @ map (fn (x, xts) =>
1274 strcatComma loc 1278 strcatComma
1275 (map (fn (x', _) => 1279 (map (fn (x', _) =>
1276 sc (x ^ ".uw_" ^ x')) 1280 sc (x ^ ".uw_" ^ x'))
1277 xts)) stables), 1281 xts)) stables),
1278 sc " FROM ", 1282 sc " FROM ",
1279 strcatComma loc (map (fn (x, _) => strcat loc [(L'.EField (gf "From", x), loc), 1283 strcatComma (map (fn (x, _) => strcat [(L'.EField (gf "From", x), loc),
1280 sc (" AS " ^ x)]) tables), 1284 sc (" AS " ^ x)]) tables),
1281 (L'.ECase (gf "Where", 1285 (L'.ECase (gf "Where",
1282 [((L'.PPrim (Prim.String "TRUE"), loc), 1286 [((L'.PPrim (Prim.String "TRUE"), loc),
1283 sc ""), 1287 sc ""),
1284 ((L'.PWild, loc), 1288 ((L'.PWild, loc),
1285 strcat loc [sc " WHERE ", gf "Where"])], 1289 strcat [sc " WHERE ", gf "Where"])],
1286 {disc = s, 1290 {disc = s,
1287 result = s}), loc), 1291 result = s}), loc),
1288 1292
1289 if List.all (fn (x, xts) => 1293 if List.all (fn (x, xts) =>
1290 case List.find (fn (x', _) => x' = x) grouped of 1294 case List.find (fn (x', _) => x' = x) grouped of
1291 NONE => List.null xts 1295 NONE => List.null xts
1292 | SOME (_, xts') => 1296 | SOME (_, xts') =>
1293 List.all (fn (x, _) => 1297 List.all (fn (x, _) =>
1294 List.exists (fn (x', _) => x' = x) 1298 List.exists (fn (x', _) => x' = x)
1295 xts') xts) tables then 1299 xts') xts) tables then
1296 sc "" 1300 sc ""
1297 else 1301 else
1298 strcat loc [ 1302 strcat [
1299 sc " GROUP BY ", 1303 sc " GROUP BY ",
1300 strcatComma loc (map (fn (x, xts) => 1304 strcatComma (map (fn (x, xts) =>
1301 strcatComma loc 1305 strcatComma
1302 (map (fn (x', _) => 1306 (map (fn (x', _) =>
1303 sc (x ^ ".uw_" ^ x')) 1307 sc (x ^ ".uw_" ^ x'))
1304 xts)) grouped) 1308 xts)) grouped)
1305 ], 1309 ],
1306 1310
1307 (L'.ECase (gf "Having", 1311 (L'.ECase (gf "Having",
1308 [((L'.PPrim (Prim.String "TRUE"), loc), 1312 [((L'.PPrim (Prim.String "TRUE"), loc),
1309 sc ""), 1313 sc ""),
1310 ((L'.PWild, loc), 1314 ((L'.PWild, loc),
1311 strcat loc [sc " HAVING ", gf "Having"])], 1315 strcat [sc " HAVING ", gf "Having"])],
1312 {disc = s, 1316 {disc = s,
1313 result = s}), loc) 1317 result = s}), loc)
1314 ]), loc), 1318 ]), loc),
1315 fm) 1319 fm)
1316 end 1320 end
1317 | _ => poly () 1321 | _ => poly ()
1318 end 1322 end
1396 ((L'.EAbs ("e1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), 1400 ((L'.EAbs ("e1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
1397 (L'.EAbs ("d", s, (L'.TFun (s, s), loc), 1401 (L'.EAbs ("d", s, (L'.TFun (s, s), loc),
1398 (L'.EAbs ("e2", s, s, 1402 (L'.EAbs ("e2", s, s,
1399 (L'.ECase ((L'.ERel 0, loc), 1403 (L'.ECase ((L'.ERel 0, loc),
1400 [((L'.PPrim (Prim.String ""), loc), 1404 [((L'.PPrim (Prim.String ""), loc),
1401 strcat loc [(L'.ERel 2, loc), 1405 strcat [(L'.ERel 2, loc),
1402 (L'.ERel 1, loc)]), 1406 (L'.ERel 1, loc)]),
1403 ((L'.PWild, loc), 1407 ((L'.PWild, loc),
1404 strcat loc [(L'.ERel 2, loc), 1408 strcat [(L'.ERel 2, loc),
1405 (L'.ERel 1, loc), 1409 (L'.ERel 1, loc),
1406 sc ", ", 1410 sc ", ",
1407 (L'.ERel 0, loc)])], 1411 (L'.ERel 0, loc)])],
1408 {disc = s, result = s}), loc)), loc)), loc)), loc), 1412 {disc = s, result = s}), loc)), loc)), loc)), loc),
1409 fm) 1413 fm)
1410 end 1414 end
1411 1415
1412 | L.EFfi ("Basis", "sql_no_limit") => 1416 | L.EFfi ("Basis", "sql_no_limit") =>
1413 ((L'.EPrim (Prim.String ""), loc), fm) 1417 ((L'.EPrim (Prim.String ""), loc), fm)
1414 | L.EFfiApp ("Basis", "sql_limit", [e]) => 1418 | L.EFfiApp ("Basis", "sql_limit", [e]) =>
1415 let 1419 let
1416 val (e, fm) = monoExp (env, st, fm) e 1420 val (e, fm) = monoExp (env, st, fm) e
1417 in 1421 in
1418 (strcat loc [ 1422 (strcat [
1419 (L'.EPrim (Prim.String " LIMIT "), loc), 1423 (L'.EPrim (Prim.String " LIMIT "), loc),
1420 (L'.EFfiApp ("Basis", "sqlifyInt", [e]), loc) 1424 (L'.EFfiApp ("Basis", "sqlifyInt", [e]), loc)
1421 ], 1425 ],
1422 fm) 1426 fm)
1423 end 1427 end
1426 ((L'.EPrim (Prim.String ""), loc), fm) 1430 ((L'.EPrim (Prim.String ""), loc), fm)
1427 | L.EFfiApp ("Basis", "sql_offset", [e]) => 1431 | L.EFfiApp ("Basis", "sql_offset", [e]) =>
1428 let 1432 let
1429 val (e, fm) = monoExp (env, st, fm) e 1433 val (e, fm) = monoExp (env, st, fm) e
1430 in 1434 in
1431 (strcat loc [ 1435 (strcat [
1432 (L'.EPrim (Prim.String " OFFSET "), loc), 1436 (L'.EPrim (Prim.String " OFFSET "), loc),
1433 (L'.EFfiApp ("Basis", "sqlifyInt", [e]), loc) 1437 (L'.EFfiApp ("Basis", "sqlifyInt", [e]), loc)
1434 ], 1438 ],
1435 fm) 1439 fm)
1436 end 1440 end
1478 val s = (L'.TFfi ("Basis", "string"), loc) 1482 val s = (L'.TFfi ("Basis", "string"), loc)
1479 fun sc s = (L'.EPrim (Prim.String s), loc) 1483 fun sc s = (L'.EPrim (Prim.String s), loc)
1480 in 1484 in
1481 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), 1485 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
1482 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), 1486 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
1483 strcat loc [sc "(", 1487 strcat [sc "(",
1484 (L'.ERel 1, loc), 1488 (L'.ERel 1, loc),
1485 sc " ", 1489 sc " ",
1486 (L'.ERel 0, loc), 1490 (L'.ERel 0, loc),
1487 sc ")"]), loc)), loc), 1491 sc ")"]), loc)), loc),
1488 fm) 1492 fm)
1489 end 1493 end
1490 | L.EFfi ("Basis", "sql_not") => ((L'.EPrim (Prim.String "NOT"), loc), fm) 1494 | L.EFfi ("Basis", "sql_not") => ((L'.EPrim (Prim.String "NOT"), loc), fm)
1491 | L.ECApp ((L.EFfi ("Basis", "sql_neg"), _), _) => 1495 | L.ECApp ((L.EFfi ("Basis", "sql_neg"), _), _) =>
1492 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), 1496 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
1510 fun sc s = (L'.EPrim (Prim.String s), loc) 1514 fun sc s = (L'.EPrim (Prim.String s), loc)
1511 in 1515 in
1512 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), 1516 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
1513 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), 1517 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
1514 (L'.EAbs ("e2", s, s, 1518 (L'.EAbs ("e2", s, s,
1515 strcat loc [sc "(", 1519 strcat [sc "(",
1516 (L'.ERel 1, loc), 1520 (L'.ERel 1, loc),
1517 sc " ", 1521 sc " ",
1518 (L'.ERel 2, loc), 1522 (L'.ERel 2, loc),
1519 sc " ", 1523 sc " ",
1520 (L'.ERel 0, loc), 1524 (L'.ERel 0, loc),
1521 sc ")"]), loc)), loc)), loc), 1525 sc ")"]), loc)), loc)), loc),
1522 fm) 1526 fm)
1523 end 1527 end
1524 | L.EFfi ("Basis", "sql_and") => ((L'.EPrim (Prim.String "AND"), loc), fm) 1528 | L.EFfi ("Basis", "sql_and") => ((L'.EPrim (Prim.String "AND"), loc), fm)
1525 | L.EFfi ("Basis", "sql_or") => ((L'.EPrim (Prim.String "OR"), loc), fm) 1529 | L.EFfi ("Basis", "sql_or") => ((L'.EPrim (Prim.String "OR"), loc), fm)
1526 1530
1566 fun sc s = (L'.EPrim (Prim.String s), loc) 1570 fun sc s = (L'.EPrim (Prim.String s), loc)
1567 in 1571 in
1568 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), 1572 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
1569 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), 1573 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
1570 (L'.EAbs ("e2", s, s, 1574 (L'.EAbs ("e2", s, s,
1571 strcat loc [sc "((", 1575 strcat [sc "((",
1572 (L'.ERel 1, loc), 1576 (L'.ERel 1, loc),
1573 sc ") ", 1577 sc ") ",
1574 (L'.ERel 2, loc), 1578 (L'.ERel 2, loc),
1575 sc " (", 1579 sc " (",
1576 (L'.ERel 0, loc), 1580 (L'.ERel 0, loc),
1577 sc "))"]), loc)), loc)), loc), 1581 sc "))"]), loc)), loc)), loc),
1578 fm) 1582 fm)
1579 end 1583 end
1580 1584
1581 | L.EFfi ("Basis", "sql_union") => ((L'.EPrim (Prim.String "UNION"), loc), fm) 1585 | L.EFfi ("Basis", "sql_union") => ((L'.EPrim (Prim.String "UNION"), loc), fm)
1582 | L.EFfi ("Basis", "sql_intersect") => ((L'.EPrim (Prim.String "INTERSECT"), loc), fm) 1586 | L.EFfi ("Basis", "sql_intersect") => ((L'.EPrim (Prim.String "INTERSECT"), loc), fm)
1604 val s = (L'.TFfi ("Basis", "string"), loc) 1608 val s = (L'.TFfi ("Basis", "string"), loc)
1605 fun sc s = (L'.EPrim (Prim.String s), loc) 1609 fun sc s = (L'.EPrim (Prim.String s), loc)
1606 in 1610 in
1607 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), 1611 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
1608 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), 1612 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
1609 strcat loc [(L'.ERel 1, loc), 1613 strcat [(L'.ERel 1, loc),
1610 sc "(", 1614 sc "(",
1611 (L'.ERel 0, loc), 1615 (L'.ERel 0, loc),
1612 sc ")"]), loc)), loc), 1616 sc ")"]), loc)), loc),
1613 fm) 1617 fm)
1614 end 1618 end
1615 1619
1616 | L.EFfi ("Basis", "sql_summable_int") => ((L'.ERecord [], loc), fm) 1620 | L.EFfi ("Basis", "sql_summable_int") => ((L'.ERecord [], loc), fm)
1617 | L.EFfi ("Basis", "sql_summable_float") => ((L'.ERecord [], loc), fm) 1621 | L.EFfi ("Basis", "sql_summable_float") => ((L'.ERecord [], loc), fm)
1671 let 1675 let
1672 val s = (L'.TFfi ("Basis", "string"), loc) 1676 val s = (L'.TFfi ("Basis", "string"), loc)
1673 fun sc s = (L'.EPrim (Prim.String s), loc) 1677 fun sc s = (L'.EPrim (Prim.String s), loc)
1674 in 1678 in
1675 ((L'.EAbs ("s", s, s, 1679 ((L'.EAbs ("s", s, s,
1676 strcat loc [sc "(", 1680 strcat [sc "(",
1677 (L'.ERel 0, loc), 1681 (L'.ERel 0, loc),
1678 sc " IS NULL)"]), loc), 1682 sc " IS NULL)"]), loc),
1679 fm) 1683 fm)
1680 end 1684 end
1681 1685
1682 | L.EFfiApp ("Basis", "nextval", [e]) => 1686 | L.EFfiApp ("Basis", "nextval", [e]) =>
1683 let 1687 let
1755 ("", [])) 1759 ("", []))
1756 1760
1757 val (tag, targs) = getTag tag 1761 val (tag, targs) = getTag tag
1758 1762
1759 val (attrs, fm) = monoExp (env, st, fm) attrs 1763 val (attrs, fm) = monoExp (env, st, fm) attrs
1764 val attrs = case #1 attrs of
1765 L'.ERecord xes => xes
1766 | _ => raise Fail "Non-record attributes!"
1760 1767
1761 fun tagStart tag = 1768 fun tagStart tag =
1762 case #1 attrs of 1769 let
1763 L'.ERecord xes => 1770 fun lowercaseFirst "" = ""
1764 let 1771 | lowercaseFirst s = String.str (Char.toLower (String.sub (s, 0)))
1765 fun lowercaseFirst "" = "" 1772 ^ String.extract (s, 1, NONE)
1766 | lowercaseFirst s = str (Char.toLower (String.sub (s, 0))) 1773
1767 ^ String.extract (s, 1, NONE) 1774 val s = (L'.EPrim (Prim.String (String.concat ["<", tag])), loc)
1768 1775 in
1769 val s = (L'.EPrim (Prim.String (String.concat ["<", tag])), loc) 1776 foldl (fn (("Action", _, _), acc) => acc
1770 in 1777 | (("Source", _, _), acc) => acc
1771 foldl (fn (("Action", _, _), acc) => acc 1778 | ((x, e, t), (s, fm)) =>
1772 | ((x, e, t), (s, fm)) => 1779 case t of
1773 case t of 1780 (L'.TFfi ("Basis", "bool"), _) =>
1774 (L'.TFfi ("Basis", "bool"), _) => 1781 let
1775 let 1782 val s' = " " ^ lowercaseFirst x
1776 val s' = " " ^ lowercaseFirst x 1783 in
1777 in 1784 ((L'.ECase (e,
1778 ((L'.ECase (e, 1785 [((L'.PCon (L'.Enum,
1779 [((L'.PCon (L'.Enum, 1786 L'.PConFfi {mod = "Basis",
1780 L'.PConFfi {mod = "Basis", 1787 datatyp = "bool",
1781 datatyp = "bool", 1788 con = "True",
1782 con = "True", 1789 arg = NONE},
1783 arg = NONE}, 1790 NONE), loc),
1784 NONE), loc), 1791 (L'.EStrcat (s,
1785 (L'.EStrcat (s, 1792 (L'.EPrim (Prim.String s'), loc)), loc)),
1786 (L'.EPrim (Prim.String s'), loc)), loc)), 1793 ((L'.PCon (L'.Enum,
1787 ((L'.PCon (L'.Enum, 1794 L'.PConFfi {mod = "Basis",
1788 L'.PConFfi {mod = "Basis", 1795 datatyp = "bool",
1789 datatyp = "bool", 1796 con = "False",
1790 con = "False", 1797 arg = NONE},
1791 arg = NONE}, 1798 NONE), loc),
1792 NONE), loc), 1799 s)],
1793 s)], 1800 {disc = (L'.TFfi ("Basis", "bool"), loc),
1794 {disc = (L'.TFfi ("Basis", "bool"), loc), 1801 result = (L'.TFfi ("Basis", "string"), loc)}), loc),
1795 result = (L'.TFfi ("Basis", "string"), loc)}), loc), 1802 fm)
1796 fm) 1803 end
1797 end 1804 | (L'.TFun _, _) =>
1798 | (L'.TFun _, _) => 1805 let
1799 let 1806 val s' = " " ^ lowercaseFirst x ^ "='"
1800 val s' = " " ^ lowercaseFirst x ^ "='" 1807 in
1801 in 1808 ((L'.EStrcat (s,
1802 ((L'.EStrcat (s, 1809 (L'.EStrcat (
1803 (L'.EStrcat ( 1810 (L'.EPrim (Prim.String s'), loc),
1804 (L'.EPrim (Prim.String s'), loc), 1811 (L'.EStrcat (
1805 (L'.EStrcat ( 1812 (L'.EJavaScript (L'.Attribute, e, NONE), loc),
1806 (L'.EJavaScript (L'.Attribute, e, NONE), loc), 1813 (L'.EPrim (Prim.String "'"), loc)), loc)),
1807 (L'.EPrim (Prim.String "'"), loc)), loc)), 1814 loc)), loc),
1808 loc)), loc), 1815 fm)
1809 fm) 1816 end
1810 end 1817 | _ =>
1811 | _ => 1818 let
1812 let 1819 val fooify =
1813 val fooify = 1820 case x of
1814 case x of 1821 "Href" => urlifyExp
1815 "Href" => urlifyExp 1822 | "Link" => urlifyExp
1816 | "Link" => urlifyExp 1823 | _ => attrifyExp
1817 | _ => attrifyExp 1824
1818 1825 val xp = " " ^ lowercaseFirst x ^ "=\""
1819 val xp = " " ^ lowercaseFirst x ^ "=\"" 1826
1820 1827 val (e, fm) = fooify env fm (e, t)
1821 val (e, fm) = fooify env fm (e, t) 1828 in
1822 in 1829 ((L'.EStrcat (s,
1823 ((L'.EStrcat (s, 1830 (L'.EStrcat ((L'.EPrim (Prim.String xp), loc),
1824 (L'.EStrcat ((L'.EPrim (Prim.String xp), loc), 1831 (L'.EStrcat (e,
1825 (L'.EStrcat (e, 1832 (L'.EPrim (Prim.String "\""),
1826 (L'.EPrim (Prim.String "\""), 1833 loc)),
1827 loc)), 1834 loc)),
1828 loc)), 1835 loc)), loc),
1829 loc)), loc), 1836 fm)
1830 fm) 1837 end)
1831 end) 1838 (s, fm) attrs
1832 (s, fm) xes 1839 end
1833 end
1834 | _ => raise Fail "Non-record attributes!"
1835 1840
1836 fun input typ = 1841 fun input typ =
1837 case targs of 1842 case targs of
1838 [_, (L.CName name, _)] => 1843 [_, (L.CName name, _)] =>
1839 let 1844 let
1886 SOME (L'.EStrcat ((L'.EPrim (Prim.String "<script src=\"/app.js\"></script>"), loc), 1891 SOME (L'.EStrcat ((L'.EPrim (Prim.String "<script src=\"/app.js\"></script>"), loc),
1887 (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), 1892 (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]),
1888 loc)), loc)) 1893 loc)), loc))
1889 1894
1890 | "dyn" => 1895 | "dyn" =>
1891 (case #1 attrs of 1896 (case attrs of
1892 L'.ERecord [("Signal", (L'.EApp ((L'.EAbs (_, _, _, (L'.ESignalReturn (L'.ERel 0, _), _)), _), 1897 [("Signal", (L'.EApp ((L'.EAbs (_, _, _, (L'.ESignalReturn (L'.ERel 0, _), _)), _),
1893 e), _), _)] => (e, fm) 1898 e), _), _)] => (e, fm)
1894 | L'.ERecord [("Signal", e, _)] => 1899 | [("Signal", e, _)] =>
1895 ((L'.EStrcat 1900 ((L'.EStrcat
1896 ((L'.EPrim (Prim.String "<script type=\"text/javascript\">dyn("), loc), 1901 ((L'.EPrim (Prim.String "<script type=\"text/javascript\">dyn("), loc),
1897 (L'.EStrcat ((L'.EJavaScript (L'.Script, e, NONE), loc), 1902 (L'.EStrcat ((L'.EJavaScript (L'.Script, e, NONE), loc),
1898 (L'.EPrim (Prim.String ")</script>"), loc)), loc)), loc), 1903 (L'.EPrim (Prim.String ")</script>"), loc)), loc)), loc),
1899 fm) 1904 fm)
1902 | "submit" => normal ("input type=\"submit\"", NONE, NONE) 1907 | "submit" => normal ("input type=\"submit\"", NONE, NONE)
1903 1908
1904 | "textbox" => 1909 | "textbox" =>
1905 (case targs of 1910 (case targs of
1906 [_, (L.CName name, _)] => 1911 [_, (L.CName name, _)] =>
1907 let 1912 (case List.find (fn ("Source", _, _) => true | _ => false) attrs of
1908 val (ts, fm) = tagStart "input" 1913 NONE =>
1909 in 1914 let
1910 ((L'.EStrcat (ts, 1915 val (ts, fm) = tagStart "input"
1911 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\"/>")), 1916 in
1912 loc)), loc), fm) 1917 ((L'.EStrcat (ts,
1913 end 1918 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\"/>")),
1919 loc)), loc), fm)
1920 end
1921 | SOME (_, src, _) =>
1922 (strcat [str "<script type=\"text/javascript\">inp(\"input\",",
1923 (L'.EJavaScript (L'.Script, src, NONE), loc),
1924 str ")</script>"],
1925 fm))
1914 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); 1926 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
1915 raise Fail "No name passed to textarea tag")) 1927 raise Fail "No name passed to textbox tag"))
1916 | "password" => input "password" 1928 | "password" => input "password"
1917 | "textarea" => 1929 | "textarea" =>
1918 (case targs of 1930 (case targs of
1919 [_, (L.CName name, _)] => 1931 [_, (L.CName name, _)] =>
1920 let 1932 let
1953 let 1965 let
1954 val (ts, fm) = tagStart "select" 1966 val (ts, fm) = tagStart "select"
1955 val (xml, fm) = monoExp (env, st, fm) xml 1967 val (xml, fm) = monoExp (env, st, fm) xml
1956 in 1968 in
1957 ((L'.EStrcat ((L'.EStrcat (ts, 1969 ((L'.EStrcat ((L'.EStrcat (ts,
1958 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc), 1970 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")),
1971 loc)), loc),
1959 (L'.EStrcat (xml, 1972 (L'.EStrcat (xml,
1960 (L'.EPrim (Prim.String "</select>"), 1973 (L'.EPrim (Prim.String "</select>"),
1961 loc)), loc)), 1974 loc)), loc)),
1962 loc), 1975 loc),
1963 fm) 1976 fm)
2023 NotFound => Found et 2036 NotFound => Found et
2024 | _ => Error) 2037 | _ => Error)
2025 | _ => findSubmit xml) 2038 | _ => findSubmit xml)
2026 | _ => NotFound 2039 | _ => NotFound
2027 2040
2028 val (action, actionT) = case findSubmit xml of 2041 val (action, fm) = case findSubmit xml of
2029 NotFound => raise Fail "No submit found" 2042 NotFound => ((L'.EPrim (Prim.String ""), loc), fm)
2030 | Error => raise Fail "Not ready for multi-submit lforms yet" 2043 | Error => raise Fail "Not ready for multi-submit lforms yet"
2031 | Found et => et 2044 | Found (action, actionT) =>
2032 2045 let
2033 val actionT = monoType env actionT 2046 val actionT = monoType env actionT
2034 val (action, fm) = monoExp (env, st, fm) action 2047 val (action, fm) = monoExp (env, st, fm) action
2035 val (action, fm) = urlifyExp env fm (action, actionT) 2048 val (action, fm) = urlifyExp env fm (action, actionT)
2049 in
2050 ((L'.EStrcat ((L'.EPrim (Prim.String " action=\""), loc),
2051 (L'.EStrcat (action,
2052 (L'.EPrim (Prim.String "\""), loc)), loc)), loc),
2053 fm)
2054 end
2055
2036 val (xml, fm) = monoExp (env, st, fm) xml 2056 val (xml, fm) = monoExp (env, st, fm) xml
2037 in 2057 in
2038 ((L'.EStrcat ((L'.EStrcat ((L'.EPrim (Prim.String "<form action=\""), loc), 2058 ((L'.EStrcat ((L'.EStrcat ((L'.EPrim (Prim.String "<form"), loc),
2039 (L'.EStrcat (action, 2059 (L'.EStrcat (action,
2040 (L'.EPrim (Prim.String "\">"), loc)), loc)), loc), 2060 (L'.EPrim (Prim.String ">"), loc)), loc)), loc),
2041 (L'.EStrcat (xml, 2061 (L'.EStrcat (xml,
2042 (L'.EPrim (Prim.String "</form>"), loc)), loc)), loc), 2062 (L'.EPrim (Prim.String "</form>"), loc)), loc)), loc),
2043 fm) 2063 fm)
2044 end 2064 end
2045 2065