Mercurial > urweb

comparison src/monoize.sml @ 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 7c2229aa22fc
comparison
equal deleted inserted replaced
2047:6be31671911b 2048:4d64af730e35
513 case #1 e of 513 case #1 e of
514 L'.EClosure (fnam, [(L'.ERecord [], _)]) => 514 L'.EClosure (fnam, [(L'.ERecord [], _)]) =>
515 let 515 let
516 val (_, _, _, s) = Env.lookupENamed env fnam 516 val (_, _, _, s) = Env.lookupENamed env fnam
517 in 517 in
518 ((L'.EPrim (Prim.String (Settings.getUrlPrefix () ^ s)), loc), fm) 518 ((L'.EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm)
519 end 519 end
520 | L'.EClosure (fnam, args) => 520 | L'.EClosure (fnam, args) =>
521 let 521 let
522 val (_, ft, _, s) = Env.lookupENamed env fnam 522 val (_, ft, _, s) = Env.lookupENamed env fnam
523 val ft = monoType env ft 523 val ft = monoType env ft
529 let 529 let
530 val (arg', fm) = fooify fm (arg, t) 530 val (arg', fm) = fooify fm (arg, t)
531 in 531 in
532 attrify (args, ft, 532 attrify (args, ft,
533 (L'.EStrcat (e, 533 (L'.EStrcat (e,
534 (L'.EStrcat ((L'.EPrim (Prim.String "/"), loc), 534 (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, "/")), loc),
535 arg'), loc)), loc), 535 arg'), loc)), loc),
536 fm) 536 fm)
537 end 537 end
538 | _ => (E.errorAt loc "Type mismatch encoding attribute"; 538 | _ => (E.errorAt loc "Type mismatch encoding attribute";
539 (e, fm)) 539 (e, fm))
540 in 540 in
541 attrify (args, ft, (L'.EPrim (Prim.String (Settings.getUrlPrefix () ^ s)), loc), fm) 541 attrify (args, ft, (L'.EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm)
542 end 542 end
543 | _ => 543 | _ =>
544 case t of 544 case t of
545 L'.TFfi ("Basis", "unit") => ((L'.EPrim (Prim.String ""), loc), fm) 545 L'.TFfi ("Basis", "unit") => ((L'.EPrim (Prim.String (Prim.Normal, "")), loc), fm)
546 | L'.TFfi (m, x) => ((L'.EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm) 546 | L'.TFfi (m, x) => ((L'.EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm)
547 547
548 | L'.TRecord [] => ((L'.EPrim (Prim.String ""), loc), fm) 548 | L'.TRecord [] => ((L'.EPrim (Prim.String (Prim.Normal, "")), loc), fm)
549 | L'.TRecord ((x, t) :: xts) => 549 | L'.TRecord ((x, t) :: xts) =>
550 let 550 let
551 val (se, fm) = fooify fm ((L'.EField (e, x), loc), t) 551 val (se, fm) = fooify fm ((L'.EField (e, x), loc), t)
552 in 552 in
553 foldl (fn ((x, t), (se, fm)) => 553 foldl (fn ((x, t), (se, fm)) =>
554 let 554 let
555 val (se', fm) = fooify fm ((L'.EField (e, x), loc), t) 555 val (se', fm) = fooify fm ((L'.EField (e, x), loc), t)
556 in 556 in
557 ((L'.EStrcat (se, 557 ((L'.EStrcat (se,
558 (L'.EStrcat ((L'.EPrim (Prim.String "/"), loc), 558 (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, "/")), loc),
559 se'), loc)), loc), 559 se'), loc)), loc),
560 fm) 560 fm)
561 end) (se, fm) xts 561 end) (se, fm) xts
562 end 562 end
563 563
583 ListUtil.foldlMap 583 ListUtil.foldlMap
584 (fn ((x, n, to), fm) => 584 (fn ((x, n, to), fm) =>
585 case to of 585 case to of
586 NONE => 586 NONE =>
587 (((L'.PCon (dk, L'.PConVar n, NONE), loc), 587 (((L'.PCon (dk, L'.PConVar n, NONE), loc),
588 (L'.EPrim (Prim.String x), loc)), 588 (L'.EPrim (Prim.String (Prim.Normal, x)), loc)),
589 fm) 589 fm)
590 | SOME t => 590 | SOME t =>
591 let 591 let
592 val (arg, fm) = fooify fm ((L'.ERel 0, loc), t) 592 val (arg, fm) = fooify fm ((L'.ERel 0, loc), t)
593 in 593 in
594 (((L'.PCon (dk, L'.PConVar n, SOME (L'.PVar ("a", t), loc)), loc), 594 (((L'.PCon (dk, L'.PConVar n, SOME (L'.PVar ("a", t), loc)), loc),
595 (L'.EStrcat ((L'.EPrim (Prim.String (x ^ "/")), loc), 595 (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, x ^ "/")), loc),
596 arg), loc)), 596 arg), loc)),
597 fm) 597 fm)
598 end) 598 end)
599 fm xncs 599 fm xncs
600 600
624 let 624 let
625 val (body, fm) = fooify fm ((L'.ERel 0, loc), t) 625 val (body, fm) = fooify fm ((L'.ERel 0, loc), t)
626 in 626 in
627 ((L'.ECase (e, 627 ((L'.ECase (e,
628 [((L'.PNone t, loc), 628 [((L'.PNone t, loc),
629 (L'.EPrim (Prim.String "None"), loc)), 629 (L'.EPrim (Prim.String (Prim.Normal, "None")), loc)),
630 630
631 ((L'.PSome (t, (L'.PVar ("x", t), loc)), loc), 631 ((L'.PSome (t, (L'.PVar ("x", t), loc)), loc),
632 (L'.EStrcat ((L'.EPrim (Prim.String "Some/"), loc), 632 (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, "Some/")), loc),
633 body), loc))], 633 body), loc))],
634 {disc = tAll, 634 {disc = tAll,
635 result = (L'.TFfi ("Basis", "string"), loc)}), loc), 635 result = (L'.TFfi ("Basis", "string"), loc)}), loc),
636 fm) 636 fm)
637 end 637 end
642 let 642 let
643 val rt = (L'.TRecord [("1", t), ("2", (L'.TList t, loc))], loc) 643 val rt = (L'.TRecord [("1", t), ("2", (L'.TList t, loc))], loc)
644 val (arg, fm) = fooify fm ((L'.ERel 0, loc), rt) 644 val (arg, fm) = fooify fm ((L'.ERel 0, loc), rt)
645 645
646 val branches = [((L'.PNone rt, loc), 646 val branches = [((L'.PNone rt, loc),
647 (L'.EPrim (Prim.String "Nil"), loc)), 647 (L'.EPrim (Prim.String (Prim.Normal, "Nil")), loc)),
648 ((L'.PSome (rt, (L'.PVar ("a", rt), loc)), loc), 648 ((L'.PSome (rt, (L'.PVar ("a", rt), loc)), loc),
649 (L'.EStrcat ((L'.EPrim (Prim.String "Cons/"), loc), 649 (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, "Cons/")), loc),
650 arg), loc))] 650 arg), loc))]
651 651
652 val dom = tAll 652 val dom = tAll
653 val ran = (L'.TFfi ("Basis", "string"), loc) 653 val ran = (L'.TFfi ("Basis", "string"), loc)
654 in 654 in
740 | L.PRecord xps => (L'.PRecord (map (fn (x, p, t) => (x, monoPat env p, monoType env t)) xps), loc) 740 | L.PRecord xps => (L'.PRecord (map (fn (x, p, t) => (x, monoPat env p, monoType env t)) xps), loc)
741 end 741 end
742 742
743 fun strcat loc es = 743 fun strcat loc es =
744 case es of 744 case es of
745 [] => (L'.EPrim (Prim.String ""), loc) 745 [] => (L'.EPrim (Prim.String (Prim.Normal, "")), loc)
746 | [e] => e 746 | [e] => e
747 | _ => 747 | _ =>
748 let 748 let
749 val e2 = List.last es 749 val e2 = List.last es
750 val es = List.take (es, length es - 1) 750 val es = List.take (es, length es - 1)
755 (L'.EStrcat (e1, e2), loc) es 755 (L'.EStrcat (e1, e2), loc) es
756 end 756 end
757 757
758 fun strcatComma loc es = 758 fun strcatComma loc es =
759 case es of 759 case es of
760 [] => (L'.EPrim (Prim.String ""), loc) 760 [] => (L'.EPrim (Prim.String (Prim.Normal, "")), loc)
761 | [e] => e 761 | [e] => e
762 | _ => 762 | _ =>
763 let 763 let
764 val e1 = List.last es 764 val e1 = List.last es
765 val es = List.take (es, length es - 1) 765 val es = List.take (es, length es - 1)
766 in 766 in
767 foldr (fn (e, e') => 767 foldr (fn (e, e') =>
768 case (e, e') of 768 case (e, e') of
769 ((L'.EPrim (Prim.String ""), _), _) => e' 769 ((L'.EPrim (Prim.String (_, "")), _), _) => e'
770 | (_, (L'.EPrim (Prim.String ""), _)) => e 770 | (_, (L'.EPrim (Prim.String (_, "")), _)) => e
771 | _ => 771 | _ =>
772 (L'.EStrcat (e, 772 (L'.EStrcat (e,
773 (L'.EStrcat ((L'.EPrim (Prim.String ", "), loc), e'), loc)), loc)) 773 (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, ", ")), loc), e'), loc)), loc))
774 e1 es 774 e1 es
775 end 775 end
776 776
777 fun strcatR loc e xs = strcatComma loc (map (fn (x, _) => (L'.EField (e, x), loc)) xs) 777 fun strcatR loc e xs = strcatComma loc (map (fn (x, _) => (L'.EField (e, x), loc)) xs)
778 778
786 786
787 fun monoExp (env, st, fm) (all as (e, loc)) = 787 fun monoExp (env, st, fm) (all as (e, loc)) =
788 let 788 let
789 val strcat = strcat loc 789 val strcat = strcat loc
790 val strcatComma = strcatComma loc 790 val strcatComma = strcatComma loc
791 fun str s = (L'.EPrim (Prim.String s), loc) 791 fun str s = (L'.EPrim (Prim.String (Prim.Normal, s)), loc)
792 fun strH s = (L'.EPrim (Prim.String (Prim.Html, s)), loc)
792 793
793 fun poly () = 794 fun poly () =
794 (E.errorAt loc "Unsupported expression"; 795 (E.errorAt loc "Unsupported expression";
795 Print.eprefaces' [("Expression", CorePrint.p_exp env all)]; 796 Print.eprefaces' [("Expression", CorePrint.p_exp env all)];
796 (dummyExp, fm)) 797 (dummyExp, fm))
1562 val (e, fm) = urlifyExp env fm (fd "Value", t) 1563 val (e, fm) = urlifyExp env fm (fd "Value", t)
1563 in 1564 in
1564 ((L'.EAbs ("c", s, (L'.TFun (rt, (L'.TFun (un, un), loc)), loc), 1565 ((L'.EAbs ("c", s, (L'.TFun (rt, (L'.TFun (un, un), loc)), loc),
1565 (L'.EAbs ("r", rt, (L'.TFun (un, un), loc), 1566 (L'.EAbs ("r", rt, (L'.TFun (un, un), loc),
1566 (L'.EAbs ("_", un, un, 1567 (L'.EAbs ("_", un, un,
1567 (L'.EFfiApp ("Basis", "set_cookie", [((L'.EPrim (Prim.String 1568 (L'.EFfiApp ("Basis", "set_cookie", [(str (Settings.getUrlPrefix ()), s),
1568 (Settings.getUrlPrefix ())),
1569 loc), s),
1570 ((L'.ERel 2, loc), s), 1569 ((L'.ERel 2, loc), s),
1571 (e, s), 1570 (e, s),
1572 (fd "Expires", (L'.TOption (L'.TFfi ("Basis", "time"), loc), loc)), 1571 (fd "Expires", (L'.TOption (L'.TFfi ("Basis", "time"), loc), loc)),
1573 (fd "Secure", (L'.TFfi ("Basis", "bool"), loc))]) 1572 (fd "Secure", (L'.TFfi ("Basis", "bool"), loc))])
1574 , loc)), loc)), loc)), loc), 1573 , loc)), loc)), loc)), loc),
1581 val un = (L'.TRecord [], loc) 1580 val un = (L'.TRecord [], loc)
1582 in 1581 in
1583 ((L'.EAbs ("c", s, (L'.TFun (un, un), loc), 1582 ((L'.EAbs ("c", s, (L'.TFun (un, un), loc),
1584 (L'.EAbs ("_", un, un, 1583 (L'.EAbs ("_", un, un,
1585 (L'.EFfiApp ("Basis", "clear_cookie", 1584 (L'.EFfiApp ("Basis", "clear_cookie",
1586 [((L'.EPrim (Prim.String 1585 [(str (Settings.getUrlPrefix ()), s),
1587 (Settings.getUrlPrefix ())),
1588 loc), s),
1589 ((L'.ERel 1, loc), s)]), 1586 ((L'.ERel 1, loc), s)]),
1590 loc)), loc)), loc), 1587 loc)), loc)), loc),
1591 fm) 1588 fm)
1592 end 1589 end
1593 1590
1610 loc)), loc)), loc)), loc), 1607 loc)), loc)), loc)), loc),
1611 fm) 1608 fm)
1612 end 1609 end
1613 1610
1614 | L.ECApp ((L.EFfi ("Basis", "no_primary_key"), _), _) => 1611 | L.ECApp ((L.EFfi ("Basis", "no_primary_key"), _), _) =>
1615 ((L'.EPrim (Prim.String ""), loc), 1612 (str "", fm)
1616 fm)
1617 | L.ECApp ( 1613 | L.ECApp (
1618 (L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "primary_key"), _), _), _), t), _), 1614 (L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "primary_key"), _), _), _), t), _),
1619 nm), _), 1615 nm), _),
1620 (L.CRecord (_, unique), _)) => 1616 (L.CRecord (_, unique), _)) =>
1621 let 1617 let
1622 val unique = (nm, t) :: unique 1618 val unique = (nm, t) :: unique
1623 val witnesses = (L'.TRecord (map (fn (nm, _) => (monoName env nm, (L'.TRecord [], loc))) unique), loc) 1619 val witnesses = (L'.TRecord (map (fn (nm, _) => (monoName env nm, (L'.TRecord [], loc))) unique), loc)
1624 in 1620 in
1625 ((L'.EAbs ("_", witnesses, (L'.TFfi ("Basis", "string"), loc), 1621 ((L'.EAbs ("_", witnesses, (L'.TFfi ("Basis", "string"), loc),
1626 (L'.EPrim (Prim.String 1622 (str
1627 (String.concatWith ", " 1623 (String.concatWith ", "
1628 (map (fn (x, _) => 1624 (map (fn (x, _) =>
1629 Settings.mangleSql (monoNameLc env x) 1625 Settings.mangleSql (monoNameLc env x)
1630 ^ (if #textKeysNeedLengths (Settings.currentDbms ()) 1626 ^ (if #textKeysNeedLengths (Settings.currentDbms ())
1631 andalso isBlobby t then 1627 andalso isBlobby t then
1632 "(767)" 1628 "(767)"
1633 else 1629 else
1634 "")) unique))), 1630 "")) unique)))),
1635 loc)), loc), 1631 loc),
1636 fm) 1632 fm)
1637 end 1633 end
1638 1634
1639 | L.ECApp ((L.EFfi ("Basis", "no_constraint"), _), _) => 1635 | L.ECApp ((L.EFfi ("Basis", "no_constraint"), _), _) =>
1640 ((L'.ERecord [], loc), 1636 ((L'.ERecord [], loc),
1666 nm), _), 1662 nm), _),
1667 (L.CRecord (_, unique), _)) => 1663 (L.CRecord (_, unique), _)) =>
1668 let 1664 let
1669 val unique = (nm, t) :: unique 1665 val unique = (nm, t) :: unique
1670 in 1666 in
1671 ((L'.EPrim (Prim.String ("UNIQUE (" 1667 (str ("UNIQUE ("
1672 ^ String.concatWith ", " 1668 ^ String.concatWith ", "
1673 (map (fn (x, t) => Settings.mangleSql (monoNameLc env x) 1669 (map (fn (x, t) => Settings.mangleSql (monoNameLc env x)
1674 ^ (if #textKeysNeedLengths (Settings.currentDbms ()) 1670 ^ (if #textKeysNeedLengths (Settings.currentDbms ())
1675 andalso isBlobby t then 1671 andalso isBlobby t then
1676 "(767)" 1672 "(767)"
1677 else 1673 else
1678 "")) unique) 1674 "")) unique)
1679 ^ ")")), loc), 1675 ^ ")"),
1680 fm) 1676 fm)
1681 end 1677 end
1682 1678
1683 | L.ECApp ((L.EFfi ("Basis", "linkable_same"), loc), _) => 1679 | L.ECApp ((L.EFfi ("Basis", "linkable_same"), loc), _) =>
1684 ((L'.ERecord [], loc), fm) 1680 ((L'.ERecord [], loc), fm)
1688 ((L'.ERecord [], loc), fm) 1684 ((L'.ERecord [], loc), fm)
1689 1685
1690 | L.EFfi ("Basis", "mat_nil") => 1686 | L.EFfi ("Basis", "mat_nil") =>
1691 let 1687 let
1692 val string = (L'.TFfi ("Basis", "string"), loc) 1688 val string = (L'.TFfi ("Basis", "string"), loc)
1693 val stringE = (L'.EPrim (Prim.String ""), loc) 1689 val stringE = str ""
1694 in 1690 in
1695 ((L'.ERecord [("1", stringE, string), 1691 ((L'.ERecord [("1", stringE, string),
1696 ("2", stringE, string)], loc), fm) 1692 ("2", stringE, string)], loc), fm)
1697 end 1693 end
1698 | L.ECApp ( 1694 | L.ECApp (
1713 val mat = (L'.TRecord [("1", string), ("2", string)], loc) 1709 val mat = (L'.TRecord [("1", string), ("2", string)], loc)
1714 in 1710 in
1715 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (mat, mat), loc), 1711 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (mat, mat), loc),
1716 (L'.EAbs ("m", mat, mat, 1712 (L'.EAbs ("m", mat, mat,
1717 (L'.ECase ((L'.EField ((L'.ERel 0, loc), "1"), loc), 1713 (L'.ECase ((L'.EField ((L'.ERel 0, loc), "1"), loc),
1718 [((L'.PPrim (Prim.String ""), loc), 1714 [((L'.PPrim (Prim.String (Prim.Normal, "")), loc),
1719 (L'.ERecord [("1", (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm1))), 1715 (L'.ERecord [("1", str (Settings.mangleSql (lowercaseFirst nm1)),
1720 loc), string), 1716 string),
1721 ("2", (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm2))), 1717 ("2", str (Settings.mangleSql (lowercaseFirst nm2)),
1722 loc), string)], loc)), 1718 string)], loc)),
1723 ((L'.PWild, loc), 1719 ((L'.PWild, loc),
1724 (L'.ERecord [("1", (L'.EStrcat ( 1720 (L'.ERecord [("1", (L'.EStrcat (
1725 (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm1) 1721 str (Settings.mangleSql (lowercaseFirst nm1)
1726 ^ ", ")), 1722 ^ ", "),
1727 loc),
1728 (L'.EField ((L'.ERel 0, loc), "1"), loc)), 1723 (L'.EField ((L'.ERel 0, loc), "1"), loc)),
1729 loc), string), 1724 loc), string),
1730 ("2", (L'.EStrcat ( 1725 ("2", (L'.EStrcat (
1731 (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm2) 1726 str (Settings.mangleSql (lowercaseFirst nm2)
1732 ^ ", ")), loc), 1727 ^ ", "),
1733 (L'.EField ((L'.ERel 0, loc), "2"), loc)), 1728 (L'.EField ((L'.ERel 0, loc), "2"), loc)),
1734 loc), string)], 1729 loc), string)],
1735 loc))], 1730 loc))],
1736 {disc = string, 1731 {disc = string,
1737 result = mat}), loc)), loc)), loc), 1732 result = mat}), loc)), loc)), loc),
1738 fm) 1733 fm)
1739 end 1734 end
1740 1735
1741 | L.ECApp ((L.EFfi ("Basis", "restrict"), _), _) => ((L'.EPrim (Prim.String "RESTRICT"), loc), fm) 1736 | L.ECApp ((L.EFfi ("Basis", "restrict"), _), _) => (str "RESTRICT", fm)
1742 | L.ECApp ((L.EFfi ("Basis", "cascade"), _), _) => ((L'.EPrim (Prim.String "CASCADE"), loc), fm) 1737 | L.ECApp ((L.EFfi ("Basis", "cascade"), _), _) => (str "CASCADE", fm)
1743 | L.ECApp ((L.EFfi ("Basis", "no_action"), _), _) => ((L'.EPrim (Prim.String "NO ACTION"), loc), fm) 1738 | L.ECApp ((L.EFfi ("Basis", "no_action"), _), _) => (str "NO ACTION", fm)
1744 | L.ECApp ((L.EFfi ("Basis", "set_null"), _), _) => ((L'.EPrim (Prim.String "SET NULL"), loc), fm) 1739 | L.ECApp ((L.EFfi ("Basis", "set_null"), _), _) => (str "SET NULL", fm)
1745 1740
1746 | L.ECApp ( 1741 | L.ECApp (
1747 (L.ECApp ( 1742 (L.ECApp (
1748 (L.ECApp ( 1743 (L.ECApp (
1749 (L.ECApp ( 1744 (L.ECApp (
1771 | strcat [e] = e 1766 | strcat [e] = e
1772 | strcat (e1 :: es) = (L'.EStrcat (e1, strcat es), loc) 1767 | strcat (e1 :: es) = (L'.EStrcat (e1, strcat es), loc)
1773 1768
1774 fun prop (fd, kw) = 1769 fun prop (fd, kw) =
1775 (L'.ECase ((L'.EField ((L'.ERel 0, loc), fd), loc), 1770 (L'.ECase ((L'.EField ((L'.ERel 0, loc), fd), loc),
1776 [((L'.PPrim (Prim.String "NO ACTION"), loc), 1771 [((L'.PPrim (Prim.String (Prim.Normal, "NO ACTION")), loc),
1777 (L'.EPrim (Prim.String ""), loc)), 1772 str ""),
1778 ((L'.PWild, loc), 1773 ((L'.PWild, loc),
1779 strcat [(L'.EPrim (Prim.String (" ON " ^ kw ^ " ")), loc), 1774 strcat [str (" ON " ^ kw ^ " "),
1780 (L'.EField ((L'.ERel 0, loc), fd), loc)])], 1775 (L'.EField ((L'.ERel 0, loc), fd), loc)])],
1781 {disc = string, 1776 {disc = string,
1782 result = string}), loc) 1777 result = string}), loc)
1783 in 1778 in
1784 ((L'.EAbs ("m", mat, (L'.TFun (string, (L'.TFun (recd, string), loc)), loc), 1779 ((L'.EAbs ("m", mat, (L'.TFun (string, (L'.TFun (recd, string), loc)), loc),
1785 (L'.EAbs ("tab", string, (L'.TFun (recd, string), loc), 1780 (L'.EAbs ("tab", string, (L'.TFun (recd, string), loc),
1786 (L'.EAbs ("pr", recd, string, 1781 (L'.EAbs ("pr", recd, string,
1787 strcat [(L'.EPrim (Prim.String "FOREIGN KEY ("), loc), 1782 strcat [str "FOREIGN KEY (",
1788 (L'.EField ((L'.ERel 2, loc), "1"), loc), 1783 (L'.EField ((L'.ERel 2, loc), "1"), loc),
1789 (L'.EPrim (Prim.String ") REFERENCES "), loc), 1784 str ") REFERENCES ",
1790 (L'.ERel 1, loc), 1785 (L'.ERel 1, loc),
1791 (L'.EPrim (Prim.String " ("), loc), 1786 str " (",
1792 (L'.EField ((L'.ERel 2, loc), "2"), loc), 1787 (L'.EField ((L'.ERel 2, loc), "2"), loc),
1793 (L'.EPrim (Prim.String ")"), loc), 1788 str ")",
1794 prop ("OnDelete", "DELETE"), 1789 prop ("OnDelete", "DELETE"),
1795 prop ("OnUpdate", "UPDATE")]), loc)), loc)), loc), 1790 prop ("OnUpdate", "UPDATE")]), loc)), loc)), loc),
1796 fm) 1791 fm)
1797 end 1792 end
1798 1793
1821 | L.ECApp ((L.EFfi ("Basis", "check"), _), _) => 1816 | L.ECApp ((L.EFfi ("Basis", "check"), _), _) =>
1822 let 1817 let
1823 val string = (L'.TFfi ("Basis", "string"), loc) 1818 val string = (L'.TFfi ("Basis", "string"), loc)
1824 in 1819 in
1825 ((L'.EAbs ("e", string, string, 1820 ((L'.EAbs ("e", string, string,
1826 (L'.EStrcat ((L'.EPrim (Prim.String "CHECK "), loc), 1821 (L'.EStrcat (str "CHECK ",
1827 (L'.EFfiApp ("Basis", "checkString", 1822 (L'.EFfiApp ("Basis", "checkString",
1828 [((L'.ERel 0, loc), string)]), loc)), loc)), loc), 1823 [((L'.ERel 0, loc), string)]), loc)), loc)), loc),
1829 fm) 1824 fm)
1830 end 1825 end
1831 1826
1850 (L'.TRecord fields, _) => 1845 (L'.TRecord fields, _) =>
1851 let 1846 let
1852 val s = (L'.TFfi ("Basis", "string"), loc) 1847 val s = (L'.TFfi ("Basis", "string"), loc)
1853 val fields = map (fn (x, _) => (x, s)) fields 1848 val fields = map (fn (x, _) => (x, s)) fields
1854 val rt = (L'.TRecord fields, loc) 1849 val rt = (L'.TRecord fields, loc)
1855 fun sc s = (L'.EPrim (Prim.String s), loc)
1856 in 1850 in
1857 ((L'.EAbs ("tab", s, (L'.TFun (rt, s), loc), 1851 ((L'.EAbs ("tab", s, (L'.TFun (rt, s), loc),
1858 (L'.EAbs ("fs", rt, s, 1852 (L'.EAbs ("fs", rt, s,
1859 strcat [sc "INSERT INTO ", 1853 strcat [str "INSERT INTO ",
1860 (L'.ERel 1, loc), 1854 (L'.ERel 1, loc),
1861 sc " (", 1855 str " (",
1862 strcatComma (map (fn (x, _) => sc (Settings.mangleSql x)) fields), 1856 strcatComma (map (fn (x, _) => str (Settings.mangleSql x)) fields),
1863 sc ") VALUES (", 1857 str ") VALUES (",
1864 strcatComma (map (fn (x, _) => 1858 strcatComma (map (fn (x, _) =>
1865 (L'.EField ((L'.ERel 0, loc), 1859 (L'.EField ((L'.ERel 0, loc),
1866 x), loc)) fields), 1860 x), loc)) fields),
1867 sc ")"]), loc)), loc), 1861 str ")"]), loc)), loc),
1868 fm) 1862 fm)
1869 end 1863 end
1870 | _ => poly ()) 1864 | _ => poly ())
1871 1865
1872 | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "update"), _), _), _), _), _), changed) => 1866 | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "update"), _), _), _), _), _), changed) =>
1874 (L'.TRecord changed, _) => 1868 (L'.TRecord changed, _) =>
1875 let 1869 let
1876 val s = (L'.TFfi ("Basis", "string"), loc) 1870 val s = (L'.TFfi ("Basis", "string"), loc)
1877 val changed = map (fn (x, _) => (x, s)) changed 1871 val changed = map (fn (x, _) => (x, s)) changed
1878 val rt = (L'.TRecord changed, loc) 1872 val rt = (L'.TRecord changed, loc)
1879 fun sc s = (L'.EPrim (Prim.String s), loc)
1880 in 1873 in
1881 ((L'.EAbs ("fs", rt, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), 1874 ((L'.EAbs ("fs", rt, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
1882 (L'.EAbs ("tab", s, (L'.TFun (s, s), loc), 1875 (L'.EAbs ("tab", s, (L'.TFun (s, s), loc),
1883 (L'.EAbs ("e", s, s, 1876 (L'.EAbs ("e", s, s,
1884 if #supportsUpdateAs (Settings.currentDbms ()) then 1877 if #supportsUpdateAs (Settings.currentDbms ()) then
1885 strcat [sc "UPDATE ", 1878 strcat [str "UPDATE ",
1886 (L'.ERel 1, loc), 1879 (L'.ERel 1, loc),
1887 sc " AS T_T SET ", 1880 str " AS T_T SET ",
1888 strcatComma (map (fn (x, _) => 1881 strcatComma (map (fn (x, _) =>
1889 strcat [sc (Settings.mangleSql x 1882 strcat [str (Settings.mangleSql x
1890 ^ " = "), 1883 ^ " = "),
1891 (L'.EField 1884 (L'.EField
1892 ((L'.ERel 2, 1885 ((L'.ERel 2,
1893 loc), 1886 loc),
1894 x), loc)]) 1887 x), loc)])
1895 changed), 1888 changed),
1896 sc " WHERE ", 1889 str " WHERE ",
1897 (L'.ERel 0, loc)] 1890 (L'.ERel 0, loc)]
1898 else 1891 else
1899 strcat [sc "UPDATE ", 1892 strcat [str "UPDATE ",
1900 (L'.ERel 1, loc), 1893 (L'.ERel 1, loc),
1901 sc " SET ", 1894 str " SET ",
1902 strcatComma (map (fn (x, _) => 1895 strcatComma (map (fn (x, _) =>
1903 strcat [sc (Settings.mangleSql x 1896 strcat [str (Settings.mangleSql x
1904 ^ " = "), 1897 ^ " = "),
1905 (L'.EFfiApp ("Basis", "unAs", 1898 (L'.EFfiApp ("Basis", "unAs",
1906 [((L'.EField 1899 [((L'.EField
1907 ((L'.ERel 2, 1900 ((L'.ERel 2,
1908 loc), 1901 loc),
1909 x), loc), 1902 x), loc),
1910 s)]), loc)]) 1903 s)]), loc)])
1911 changed), 1904 changed),
1912 sc " WHERE ", 1905 str " WHERE ",
1913 (L'.EFfiApp ("Basis", "unAs", [((L'.ERel 0, loc), s)]), loc)]), 1906 (L'.EFfiApp ("Basis", "unAs", [((L'.ERel 0, loc), s)]), loc)]),
1914 loc)), loc)), loc), 1907 loc)), loc)), loc),
1915 fm) 1908 fm)
1916 end 1909 end
1917 | _ => poly ()) 1910 | _ => poly ())
1918 1911
1919 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "delete"), _), _), _), _) => 1912 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "delete"), _), _), _), _) =>
1920 let 1913 let
1921 val s = (L'.TFfi ("Basis", "string"), loc) 1914 val s = (L'.TFfi ("Basis", "string"), loc)
1922 fun sc s = (L'.EPrim (Prim.String s), loc)
1923 in 1915 in
1924 ((L'.EAbs ("tab", s, (L'.TFun (s, s), loc), 1916 ((L'.EAbs ("tab", s, (L'.TFun (s, s), loc),
1925 (L'.EAbs ("e", s, s, 1917 (L'.EAbs ("e", s, s,
1926 if #supportsDeleteAs (Settings.currentDbms ()) then 1918 if #supportsDeleteAs (Settings.currentDbms ()) then
1927 strcat [sc "DELETE FROM ", 1919 strcat [str "DELETE FROM ",
1928 (L'.ERel 1, loc), 1920 (L'.ERel 1, loc),
1929 sc " AS T_T WHERE ", 1921 str " AS T_T WHERE ",
1930 (L'.ERel 0, loc)] 1922 (L'.ERel 0, loc)]
1931 else 1923 else
1932 strcat [sc "DELETE FROM ", 1924 strcat [str "DELETE FROM ",
1933 (L'.ERel 1, loc), 1925 (L'.ERel 1, loc),
1934 sc " WHERE ", 1926 str " WHERE ",
1935 (L'.EFfiApp ("Basis", "unAs", [((L'.ERel 0, loc), s)]), loc)]), loc)), loc), 1927 (L'.EFfiApp ("Basis", "unAs", [((L'.ERel 0, loc), s)]), loc)]), loc)), loc),
1936 fm) 1928 fm)
1937 end 1929 end
1938 1930
1939 | L.ECApp ( 1931 | L.ECApp (
1989 end 1981 end
1990 | _ => poly ()) 1982 | _ => poly ())
1991 1983
1992 | L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_query"), _), _), _), _), _), _), _), _), _), _) => 1984 | L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_query"), _), _), _), _), _), _), _), _), _), _) =>
1993 let 1985 let
1994 fun sc s = (L'.EPrim (Prim.String s), loc)
1995 val s = (L'.TFfi ("Basis", "string"), loc) 1986 val s = (L'.TFfi ("Basis", "string"), loc)
1996 fun gf s = (L'.EField ((L'.ERel 0, loc), s), loc) 1987 fun gf s = (L'.EField ((L'.ERel 0, loc), s), loc)
1997 in 1988 in
1998 ((L'.EAbs ("r", 1989 ((L'.EAbs ("r",
1999 (L'.TRecord [("Rows", s), ("OrderBy", s), ("Limit", s), ("Offset", s)], loc), 1990 (L'.TRecord [("Rows", s), ("OrderBy", s), ("Limit", s), ("Offset", s)], loc),
2000 s, 1991 s,
2001 strcat [gf "Rows", 1992 strcat [gf "Rows",
2002 (L'.ECase (gf "OrderBy", 1993 (L'.ECase (gf "OrderBy",
2003 [((L'.PPrim (Prim.String ""), loc), sc ""), 1994 [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), str ""),
2004 ((L'.PWild, loc), 1995 ((L'.PWild, loc),
2005 strcat [sc " ORDER BY ", 1996 strcat [str " ORDER BY ",
2006 gf "OrderBy"])], 1997 gf "OrderBy"])],
2007 {disc = s, result = s}), loc), 1998 {disc = s, result = s}), loc),
2008 gf "Limit", 1999 gf "Limit",
2009 gf "Offset"]), loc), fm) 2000 gf "Offset"]), loc), fm)
2010 end 2001 end
2023 (L.CRecord (_, grouped), _)), _), 2014 (L.CRecord (_, grouped), _)), _),
2024 (L.CRecord (_, stables), _)), _), 2015 (L.CRecord (_, stables), _)), _),
2025 sexps), _), 2016 sexps), _),
2026 _) => 2017 _) =>
2027 let 2018 let
2028 fun sc s = (L'.EPrim (Prim.String s), loc)
2029 val s = (L'.TFfi ("Basis", "string"), loc) 2019 val s = (L'.TFfi ("Basis", "string"), loc)
2030 val b = (L'.TFfi ("Basis", "bool"), loc) 2020 val b = (L'.TFfi ("Basis", "bool"), loc)
2031 val un = (L'.TRecord [], loc) 2021 val un = (L'.TRecord [], loc)
2032 fun gf s = (L'.EField ((L'.ERel 0, loc), s), loc) 2022 fun gf s = (L'.EField ((L'.ERel 0, loc), s), loc)
2033 2023
2070 ("Having", s), 2060 ("Having", s),
2071 ("SelectFields", un), 2061 ("SelectFields", un),
2072 ("SelectExps", (L'.TRecord (map (fn (x, _) => (x, s)) sexps), loc))], 2062 ("SelectExps", (L'.TRecord (map (fn (x, _) => (x, s)) sexps), loc))],
2073 loc), 2063 loc),
2074 s, 2064 s,
2075 strcat [sc "SELECT ", 2065 strcat [str "SELECT ",
2076 (L'.ECase (gf "Distinct", 2066 (L'.ECase (gf "Distinct",
2077 [((L'.PCon (L'.Enum, 2067 [((L'.PCon (L'.Enum,
2078 L'.PConFfi {mod = "Basis", 2068 L'.PConFfi {mod = "Basis",
2079 datatyp = "bool", 2069 datatyp = "bool",
2080 con = "True", 2070 con = "True",
2081 arg = NONE}, 2071 arg = NONE},
2082 NONE), loc), 2072 NONE), loc),
2083 (L'.EPrim (Prim.String "DISTINCT "), loc)), 2073 str "DISTINCT "),
2084 ((L'.PCon (L'.Enum, 2074 ((L'.PCon (L'.Enum,
2085 L'.PConFfi {mod = "Basis", 2075 L'.PConFfi {mod = "Basis",
2086 datatyp = "bool", 2076 datatyp = "bool",
2087 con = "False", 2077 con = "False",
2088 arg = NONE}, 2078 arg = NONE},
2089 NONE), loc), 2079 NONE), loc),
2090 (L'.EPrim (Prim.String ""), loc))], 2080 str "")],
2091 {disc = b, result = s}), loc), 2081 {disc = b, result = s}), loc),
2092 strcatComma (map (fn (x, t) => 2082 strcatComma (map (fn (x, t) =>
2093 strcat [ 2083 strcat [
2094 (L'.EField (gf "SelectExps", x), loc), 2084 (L'.EField (gf "SelectExps", x), loc),
2095 sc (" AS " ^ Settings.mangleSql x) 2085 str (" AS " ^ Settings.mangleSql x)
2096 ]) sexps 2086 ]) sexps
2097 @ map (fn (x, xts) => 2087 @ map (fn (x, xts) =>
2098 strcatComma 2088 strcatComma
2099 (map (fn (x', _) => 2089 (map (fn (x', _) =>
2100 sc ("T_" ^ x 2090 str ("T_" ^ x
2101 ^ "." 2091 ^ "."
2102 ^ Settings.mangleSql x')) 2092 ^ Settings.mangleSql x'))
2103 xts)) stables), 2093 xts)) stables),
2104 (L'.ECase (gf "From", 2094 (L'.ECase (gf "From",
2105 [((L'.PPrim (Prim.String ""), loc), 2095 [((L'.PPrim (Prim.String (Prim.Normal, "")), loc),
2106 sc ""), 2096 str ""),
2107 ((L'.PVar ("x", s), loc), 2097 ((L'.PVar ("x", s), loc),
2108 strcat [sc " FROM ", 2098 strcat [str " FROM ",
2109 (L'.ERel 0, loc)])], 2099 (L'.ERel 0, loc)])],
2110 {disc = s, 2100 {disc = s,
2111 result = s}), loc), 2101 result = s}), loc),
2112 (L'.ECase (gf "Where", 2102 (L'.ECase (gf "Where",
2113 [((L'.PPrim (Prim.String (#trueString (Settings.currentDbms ()))), 2103 [((L'.PPrim (Prim.String (Prim.Normal, #trueString (Settings.currentDbms ()))),
2114 loc), 2104 loc),
2115 sc ""), 2105 str ""),
2116 ((L'.PWild, loc), 2106 ((L'.PWild, loc),
2117 strcat [sc " WHERE ", gf "Where"])], 2107 strcat [str " WHERE ", gf "Where"])],
2118 {disc = s, 2108 {disc = s,
2119 result = s}), loc), 2109 result = s}), loc),
2120 2110
2121 if List.all (fn (x, xts) => 2111 if List.all (fn (x, xts) =>
2122 case List.find (fn (x', _) => x' = x) grouped of 2112 case List.find (fn (x', _) => x' = x) grouped of
2123 NONE => List.null xts 2113 NONE => List.null xts
2124 | SOME (_, xts') => 2114 | SOME (_, xts') =>
2125 List.all (fn (x, _) => 2115 List.all (fn (x, _) =>
2126 List.exists (fn (x', _) => x' = x) 2116 List.exists (fn (x', _) => x' = x)
2127 xts') xts) tables then 2117 xts') xts) tables then
2128 sc "" 2118 str ""
2129 else 2119 else
2130 strcat [ 2120 strcat [
2131 sc " GROUP BY ", 2121 str " GROUP BY ",
2132 strcatComma (map (fn (x, xts) => 2122 strcatComma (map (fn (x, xts) =>
2133 strcatComma 2123 strcatComma
2134 (map (fn (x', _) => 2124 (map (fn (x', _) =>
2135 sc ("T_" ^ x 2125 str ("T_" ^ x
2136 ^ "." 2126 ^ "."
2137 ^ Settings.mangleSql x')) 2127 ^ Settings.mangleSql x'))
2138 xts)) grouped) 2128 xts)) grouped)
2139 ], 2129 ],
2140 2130
2141 (L'.ECase (gf "Having", 2131 (L'.ECase (gf "Having",
2142 [((L'.PPrim (Prim.String 2132 [((L'.PPrim (Prim.String
2143 (#trueString (Settings.currentDbms ()))), loc), 2133 (Prim.Normal, #trueString (Settings.currentDbms ()))), loc),
2144 sc ""), 2134 str ""),
2145 ((L'.PWild, loc), 2135 ((L'.PWild, loc),
2146 strcat [sc " HAVING ", gf "Having"])], 2136 strcat [str " HAVING ", gf "Having"])],
2147 {disc = s, 2137 {disc = s,
2148 result = s}), loc) 2138 result = s}), loc)
2149 ]), loc), 2139 ]), loc),
2150 fm) 2140 fm)
2151 end 2141 end
2232 (L'.EAbs ("x", 2222 (L'.EAbs ("x",
2233 (L'.TOption t, loc), 2223 (L'.TOption t, loc),
2234 s, 2224 s,
2235 (L'.ECase ((L'.ERel 0, loc), 2225 (L'.ECase ((L'.ERel 0, loc),
2236 [((L'.PNone t, loc), 2226 [((L'.PNone t, loc),
2237 (L'.EPrim (Prim.String "NULL"), loc)), 2227 str "NULL"),
2238 ((L'.PSome (t, (L'.PVar ("y", t), loc)), loc), 2228 ((L'.PSome (t, (L'.PVar ("y", t), loc)), loc),
2239 (L'.EApp ((L'.ERel 2, loc), (L'.ERel 0, loc)), loc))], 2229 (L'.EApp ((L'.ERel 2, loc), (L'.ERel 0, loc)), loc))],
2240 {disc = (L'.TOption t, loc), 2230 {disc = (L'.TOption t, loc),
2241 result = s}), loc)), loc)), loc), 2231 result = s}), loc)), loc)), loc),
2242 fm) 2232 fm)
2268 ((L'.ERecord [], loc), fm) 2258 ((L'.ERecord [], loc), fm)
2269 | L.ECApp ((L.EFfi ("Basis", "fieldsOf_view"), _), _) => 2259 | L.ECApp ((L.EFfi ("Basis", "fieldsOf_view"), _), _) =>
2270 ((L'.ERecord [], loc), fm) 2260 ((L'.ERecord [], loc), fm)
2271 2261
2272 | L.ECApp ((L.EFfi ("Basis", "sql_from_nil"), _), _) => 2262 | L.ECApp ((L.EFfi ("Basis", "sql_from_nil"), _), _) =>
2273 ((L'.EPrim (Prim.String ""), loc), fm) 2263 (str "", fm)
2274 | L.ECApp ((L.EApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_from_table"), _), _), 2264 | L.ECApp ((L.EApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_from_table"), _), _),
2275 _), _), _), _), _), _), _), 2265 _), _), _), _), _), _), _),
2276 (L.CName name, _)) => 2266 (L.CName name, _)) =>
2277 let 2267 let
2278 val s = (L'.TFfi ("Basis", "string"), loc) 2268 val s = (L'.TFfi ("Basis", "string"), loc)
2279 in 2269 in
2280 ((L'.EAbs ("tab", s, s, 2270 ((L'.EAbs ("tab", s, s,
2281 strcat [(L'.ERel 0, loc), 2271 strcat [(L'.ERel 0, loc),
2282 (L'.EPrim (Prim.String (" AS T_" ^ name)), loc)]), loc), 2272 str (" AS T_" ^ name)]), loc),
2283 fm) 2273 fm)
2284 end 2274 end
2285 | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_from_query"), _), _), 2275 | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_from_query"), _), _),
2286 _), _), _), 2276 _), _), _),
2287 (L.CName name, _)) => 2277 (L.CName name, _)) =>
2288 let 2278 let
2289 val s = (L'.TFfi ("Basis", "string"), loc) 2279 val s = (L'.TFfi ("Basis", "string"), loc)
2290 fun sc s = (L'.EPrim (Prim.String s), loc)
2291 in 2280 in
2292 ((L'.EAbs ("q", s, s, 2281 ((L'.EAbs ("q", s, s,
2293 strcat [sc "(", 2282 strcat [str "(",
2294 (L'.ERel 0, loc), 2283 (L'.ERel 0, loc),
2295 sc (") AS T_" ^ name)]), loc), 2284 str (") AS T_" ^ name)]), loc),
2296 fm) 2285 fm)
2297 end 2286 end
2298 | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_from_comma"), _), _), _), _), _), _) => 2287 | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_from_comma"), _), _), _), _), _), _) =>
2299 let 2288 let
2300 val s = (L'.TFfi ("Basis", "string"), loc) 2289 val s = (L'.TFfi ("Basis", "string"), loc)
2301 in 2290 in
2302 ((L'.EAbs ("tab1", s, (L'.TFun (s, s), loc), 2291 ((L'.EAbs ("tab1", s, (L'.TFun (s, s), loc),
2303 (L'.EAbs ("tab2", s, s, 2292 (L'.EAbs ("tab2", s, s,
2304 (L'.ECase ((L'.ERecord [("1", (L'.ERel 1, loc), s), 2293 (L'.ECase ((L'.ERecord [("1", (L'.ERel 1, loc), s),
2305 ("2", (L'.ERel 0, loc), s)], loc), 2294 ("2", (L'.ERel 0, loc), s)], loc),
2306 [((L'.PRecord [("1", (L'.PPrim (Prim.String ""), loc), s)], loc), 2295 [((L'.PRecord [("1", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc),
2307 (L'.ERel 0, loc)), 2296 (L'.ERel 0, loc)),
2308 ((L'.PRecord [("2", (L'.PPrim (Prim.String ""), loc), s)], loc), 2297 ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc),
2309 (L'.ERel 1, loc)), 2298 (L'.ERel 1, loc)),
2310 ((L'.PWild, loc), 2299 ((L'.PWild, loc),
2311 strcat [(L'.ERel 1, loc), 2300 strcat [(L'.ERel 1, loc),
2312 (L'.EPrim (Prim.String ", "), loc), 2301 str ", ",
2313 (L'.ERel 0, loc)])], 2302 (L'.ERel 0, loc)])],
2314 {disc = (L'.TRecord [("1", s), ("2", s)], loc), 2303 {disc = (L'.TRecord [("1", s), ("2", s)], loc),
2315 result = s}), loc)), loc)), loc), 2304 result = s}), loc)), loc)), loc),
2316 fm) 2305 fm)
2317 end 2306 end
2322 ((L'.EAbs ("tab1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), 2311 ((L'.EAbs ("tab1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
2323 (L'.EAbs ("tab2", s, (L'.TFun (s, s), loc), 2312 (L'.EAbs ("tab2", s, (L'.TFun (s, s), loc),
2324 (L'.EAbs ("on", s, s, 2313 (L'.EAbs ("on", s, s,
2325 (L'.ECase ((L'.ERecord [("1", (L'.ERel 2, loc), s), 2314 (L'.ECase ((L'.ERecord [("1", (L'.ERel 2, loc), s),
2326 ("2", (L'.ERel 1, loc), s)], loc), 2315 ("2", (L'.ERel 1, loc), s)], loc),
2327 [((L'.PRecord [("1", (L'.PPrim (Prim.String ""), loc), s)], loc), 2316 [((L'.PRecord [("1", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc),
2328 (L'.ERel 1, loc)), 2317 (L'.ERel 1, loc)),
2329 ((L'.PRecord [("2", (L'.PPrim (Prim.String ""), loc), s)], loc), 2318 ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc),
2330 (L'.ERel 2, loc)), 2319 (L'.ERel 2, loc)),
2331 ((L'.PWild, loc), 2320 ((L'.PWild, loc),
2332 strcat ((if #nestedRelops 2321 strcat ((if #nestedRelops
2333 (Settings.currentDbms ()) then 2322 (Settings.currentDbms ()) then
2334 [(L'.EPrim (Prim.String "("), loc)] 2323 [str "("]
2335 else 2324 else
2336 []) 2325 [])
2337 @ [(L'.ERel 2, loc), 2326 @ [(L'.ERel 2, loc),
2338 (L'.EPrim (Prim.String " JOIN "), loc), 2327 str " JOIN ",
2339 (L'.ERel 1, loc), 2328 (L'.ERel 1, loc),
2340 (L'.EPrim (Prim.String " ON "), loc), 2329 str " ON ",
2341 (L'.ERel 0, loc)] 2330 (L'.ERel 0, loc)]
2342 @ (if #nestedRelops 2331 @ (if #nestedRelops
2343 (Settings.currentDbms ()) then 2332 (Settings.currentDbms ()) then
2344 [(L'.EPrim (Prim.String ")"), loc)] 2333 [str ")"]
2345 else 2334 else
2346 [])))], 2335 [])))],
2347 {disc = (L'.TRecord [("1", s), ("2", s)], loc), 2336 {disc = (L'.TRecord [("1", s), ("2", s)], loc),
2348 result = s}), loc)), loc)), loc)), loc), 2337 result = s}), loc)), loc)), loc)), loc),
2349 fm) 2338 fm)
2358 (L'.EAbs ("tab1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), 2347 (L'.EAbs ("tab1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
2359 (L'.EAbs ("tab2", s, (L'.TFun (s, s), loc), 2348 (L'.EAbs ("tab2", s, (L'.TFun (s, s), loc),
2360 (L'.EAbs ("on", s, s, 2349 (L'.EAbs ("on", s, s,
2361 (L'.ECase ((L'.ERecord [("1", (L'.ERel 2, loc), s), 2350 (L'.ECase ((L'.ERecord [("1", (L'.ERel 2, loc), s),
2362 ("2", (L'.ERel 1, loc), s)], loc), 2351 ("2", (L'.ERel 1, loc), s)], loc),
2363 [((L'.PRecord [("1", (L'.PPrim (Prim.String ""), 2352 [((L'.PRecord [("1", (L'.PPrim (Prim.String (Prim.Normal, "")),
2364 loc), s)], loc), 2353 loc), s)], loc),
2365 (L'.ERel 1, loc)), 2354 (L'.ERel 1, loc)),
2366 ((L'.PRecord [("2", (L'.PPrim (Prim.String ""), 2355 ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")),
2367 loc), s)], loc), 2356 loc), s)], loc),
2368 (L'.ERel 2, loc)), 2357 (L'.ERel 2, loc)),
2369 ((L'.PWild, loc), 2358 ((L'.PWild, loc),
2370 strcat ((if #nestedRelops 2359 strcat ((if #nestedRelops
2371 (Settings.currentDbms ()) then 2360 (Settings.currentDbms ()) then
2372 [(L'.EPrim (Prim.String "("), loc)] 2361 [str "("]
2373 else 2362 else
2374 []) 2363 [])
2375 @ [(L'.ERel 2, loc), 2364 @ [(L'.ERel 2, loc),
2376 (L'.EPrim (Prim.String " LEFT JOIN "), 2365 str " LEFT JOIN ",
2377 loc),
2378 (L'.ERel 1, loc), 2366 (L'.ERel 1, loc),
2379 (L'.EPrim (Prim.String " ON "), loc), 2367 str " ON ",
2380 (L'.ERel 0, loc)] 2368 (L'.ERel 0, loc)]
2381 @ (if #nestedRelops 2369 @ (if #nestedRelops
2382 (Settings.currentDbms ()) then 2370 (Settings.currentDbms ()) then
2383 [(L'.EPrim (Prim.String ")"), loc)] 2371 [str ")"]
2384 else 2372 else
2385 [])))], 2373 [])))],
2386 {disc = (L'.TRecord [("1", s), ("2", s)], loc), 2374 {disc = (L'.TRecord [("1", s), ("2", s)], loc),
2387 result = s}), loc)), loc)), loc)), loc)), loc), 2375 result = s}), loc)), loc)), loc)), loc)), loc),
2388 fm) 2376 fm)
2397 (L'.EAbs ("tab1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), 2385 (L'.EAbs ("tab1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
2398 (L'.EAbs ("tab2", s, (L'.TFun (s, s), loc), 2386 (L'.EAbs ("tab2", s, (L'.TFun (s, s), loc),
2399 (L'.EAbs ("on", s, s, 2387 (L'.EAbs ("on", s, s,
2400 (L'.ECase ((L'.ERecord [("1", (L'.ERel 2, loc), s), 2388 (L'.ECase ((L'.ERecord [("1", (L'.ERel 2, loc), s),
2401 ("2", (L'.ERel 1, loc), s)], loc), 2389 ("2", (L'.ERel 1, loc), s)], loc),
2402 [((L'.PRecord [("1", (L'.PPrim (Prim.String ""), 2390 [((L'.PRecord [("1", (L'.PPrim (Prim.String (Prim.Normal, "")),
2403 loc), s)], loc), 2391 loc), s)], loc),
2404 (L'.ERel 1, loc)), 2392 (L'.ERel 1, loc)),
2405 ((L'.PRecord [("2", (L'.PPrim (Prim.String ""), 2393 ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")),
2406 loc), s)], loc), 2394 loc), s)], loc),
2407 (L'.ERel 2, loc)), 2395 (L'.ERel 2, loc)),
2408 ((L'.PWild, loc), 2396 ((L'.PWild, loc),
2409 strcat ((if #nestedRelops 2397 strcat ((if #nestedRelops
2410 (Settings.currentDbms ()) then 2398 (Settings.currentDbms ()) then
2411 [(L'.EPrim (Prim.String "("), loc)] 2399 [str "("]
2412 else 2400 else
2413 []) 2401 [])
2414 @ [(L'.ERel 2, loc), 2402 @ [(L'.ERel 2, loc),
2415 (L'.EPrim (Prim.String " RIGHT JOIN "), 2403 str " RIGHT JOIN ",
2416 loc),
2417 (L'.ERel 1, loc), 2404 (L'.ERel 1, loc),
2418 (L'.EPrim (Prim.String " ON "), loc), 2405 str " ON ",
2419 (L'.ERel 0, loc)] 2406 (L'.ERel 0, loc)]
2420 @ (if #nestedRelops 2407 @ (if #nestedRelops
2421 (Settings.currentDbms ()) then 2408 (Settings.currentDbms ()) then
2422 [(L'.EPrim (Prim.String ")"), loc)] 2409 [str ")"]
2423 else 2410 else
2424 [])))], 2411 [])))],
2425 {disc = (L'.TRecord [("1", s), ("2", s)], loc), 2412 {disc = (L'.TRecord [("1", s), ("2", s)], loc),
2426 result = s}), loc)), loc)), loc)), loc)), loc), 2413 result = s}), loc)), loc)), loc)), loc)), loc),
2427 fm) 2414 fm)
2436 (L'.EAbs ("tab1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), 2423 (L'.EAbs ("tab1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
2437 (L'.EAbs ("tab2", s, (L'.TFun (s, s), loc), 2424 (L'.EAbs ("tab2", s, (L'.TFun (s, s), loc),
2438 (L'.EAbs ("on", s, s, 2425 (L'.EAbs ("on", s, s,
2439 (L'.ECase ((L'.ERecord [("1", (L'.ERel 2, loc), s), 2426 (L'.ECase ((L'.ERecord [("1", (L'.ERel 2, loc), s),
2440 ("2", (L'.ERel 1, loc), s)], loc), 2427 ("2", (L'.ERel 1, loc), s)], loc),
2441 [((L'.PRecord [("1", (L'.PPrim (Prim.String ""), 2428 [((L'.PRecord [("1", (L'.PPrim (Prim.String (Prim.Normal, "")),
2442 loc), s)], loc), 2429 loc), s)], loc),
2443 (L'.ERel 1, loc)), 2430 (L'.ERel 1, loc)),
2444 ((L'.PRecord [("2", (L'.PPrim (Prim.String ""), 2431 ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")),
2445 loc), s)], loc), 2432 loc), s)], loc),
2446 (L'.ERel 2, loc)), 2433 (L'.ERel 2, loc)),
2447 ((L'.PWild, loc), 2434 ((L'.PWild, loc),
2448 strcat ((if #nestedRelops 2435 strcat ((if #nestedRelops
2449 (Settings.currentDbms ()) then 2436 (Settings.currentDbms ()) then
2450 [(L'.EPrim (Prim.String "("), loc)] 2437 [str "("]
2451 else 2438 else
2452 []) 2439 [])
2453 @ [(L'.ERel 2, loc), 2440 @ [(L'.ERel 2, loc),
2454 (L'.EPrim (Prim.String " FULL JOIN "), 2441 str " FULL JOIN ",
2455 loc),
2456 (L'.ERel 1, loc), 2442 (L'.ERel 1, loc),
2457 (L'.EPrim (Prim.String " ON "), loc), 2443 str " ON ",
2458 (L'.ERel 0, loc)] 2444 (L'.ERel 0, loc)]
2459 @ (if #nestedRelops 2445 @ (if #nestedRelops
2460 (Settings.currentDbms ()) then 2446 (Settings.currentDbms ()) then
2461 [(L'.EPrim (Prim.String ")"), loc)] 2447 [str ")"]
2462 else 2448 else
2463 [])))], 2449 [])))],
2464 {disc = (L'.TRecord [("1", s), ("2", s)], loc), 2450 {disc = (L'.TRecord [("1", s), ("2", s)], loc),
2465 result = s}), loc)), loc)), loc)), loc)), loc), 2451 result = s}), loc)), loc)), loc)), loc)), loc),
2466 fm) 2452 fm)
2467 end 2453 end
2468 2454
2469 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_order_by_Nil"), _), _), _), _) => 2455 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_order_by_Nil"), _), _), _), _) =>
2470 ((L'.EPrim (Prim.String ""), loc), fm) 2456 (str "", fm)
2471 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_order_by_random"), _), _), _), _) => 2457 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_order_by_random"), _), _), _), _) =>
2472 ((L'.EPrim (Prim.String (#randomFunction (Settings.currentDbms ()) ^ "()")), loc), fm) 2458 (str (#randomFunction (Settings.currentDbms ()) ^ "()"), fm)
2473 | L.ECApp ( 2459 | L.ECApp (
2474 (L.ECApp ( 2460 (L.ECApp (
2475 (L.ECApp ( 2461 (L.ECApp (
2476 (L.ECApp ( 2462 (L.ECApp (
2477 (L.EFfi ("Basis", "sql_order_by_Cons"), _), 2463 (L.EFfi ("Basis", "sql_order_by_Cons"), _),
2479 _), _), 2465 _), _),
2480 _), _), 2466 _), _),
2481 _) => 2467 _) =>
2482 let 2468 let
2483 val s = (L'.TFfi ("Basis", "string"), loc) 2469 val s = (L'.TFfi ("Basis", "string"), loc)
2484 fun sc s = (L'.EPrim (Prim.String s), loc)
2485 in 2470 in
2486 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc), 2471 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc),
2487 (L'.EAbs ("e1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), 2472 (L'.EAbs ("e1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
2488 (L'.EAbs ("d", s, (L'.TFun (s, s), loc), 2473 (L'.EAbs ("d", s, (L'.TFun (s, s), loc),
2489 (L'.EAbs ("e2", s, s, 2474 (L'.EAbs ("e2", s, s,
2490 (L'.ECase ((L'.ERel 0, loc), 2475 (L'.ECase ((L'.ERel 0, loc),
2491 [((L'.PPrim (Prim.String ""), loc), 2476 [((L'.PPrim (Prim.String (Prim.Normal, "")), loc),
2492 strcat [(L'.ERel 2, loc), 2477 strcat [(L'.ERel 2, loc),
2493 (L'.ERel 1, loc)]), 2478 (L'.ERel 1, loc)]),
2494 ((L'.PWild, loc), 2479 ((L'.PWild, loc),
2495 strcat [(L'.ERel 2, loc), 2480 strcat [(L'.ERel 2, loc),
2496 (L'.ERel 1, loc), 2481 (L'.ERel 1, loc),
2497 sc ", ", 2482 str ", ",
2498 (L'.ERel 0, loc)])], 2483 (L'.ERel 0, loc)])],
2499 {disc = s, result = s}), loc)), loc)), loc)), loc)), loc), 2484 {disc = s, result = s}), loc)), loc)), loc)), loc)), loc),
2500 fm) 2485 fm)
2501 end 2486 end
2502 2487
2503 | L.EFfi ("Basis", "sql_no_limit") => 2488 | L.EFfi ("Basis", "sql_no_limit") =>
2504 ((L'.EPrim (Prim.String ""), loc), fm) 2489 (str "", fm)
2505 | L.EFfiApp ("Basis", "sql_limit", [(e, t)]) => 2490 | L.EFfiApp ("Basis", "sql_limit", [(e, t)]) =>
2506 let 2491 let
2507 val (e, fm) = monoExp (env, st, fm) e 2492 val (e, fm) = monoExp (env, st, fm) e
2508 in 2493 in
2509 (strcat [ 2494 (strcat [
2510 (L'.EPrim (Prim.String " LIMIT "), loc), 2495 str " LIMIT ",
2511 (L'.EFfiApp ("Basis", "sqlifyInt", [(e, monoType env t)]), loc) 2496 (L'.EFfiApp ("Basis", "sqlifyInt", [(e, monoType env t)]), loc)
2512 ], 2497 ],
2513 fm) 2498 fm)
2514 end 2499 end
2515 2500
2516 | L.EFfi ("Basis", "sql_no_offset") => 2501 | L.EFfi ("Basis", "sql_no_offset") =>
2517 ((L'.EPrim (Prim.String ""), loc), fm) 2502 (str "", fm)
2518 | L.EFfiApp ("Basis", "sql_offset", [(e, t)]) => 2503 | L.EFfiApp ("Basis", "sql_offset", [(e, t)]) =>
2519 let 2504 let
2520 val (e, fm) = monoExp (env, st, fm) e 2505 val (e, fm) = monoExp (env, st, fm) e
2521 in 2506 in
2522 (strcat [ 2507 (strcat [
2523 (L'.EPrim (Prim.String " OFFSET "), loc), 2508 str " OFFSET ",
2524 (L'.EFfiApp ("Basis", "sqlifyInt", [(e, monoType env t)]), loc) 2509 (L'.EFfiApp ("Basis", "sqlifyInt", [(e, monoType env t)]), loc)
2525 ], 2510 ],
2526 fm) 2511 fm)
2527 end 2512 end
2528 2513
2529 | L.ECApp ((L.EFfi ("Basis", "sql_eq"), _), _) => 2514 | L.ECApp ((L.EFfi ("Basis", "sql_eq"), _), _) =>
2530 ((L'.EPrim (Prim.String "="), loc), fm) 2515 (str "=", fm)
2531 | L.ECApp ((L.EFfi ("Basis", "sql_ne"), _), _) => 2516 | L.ECApp ((L.EFfi ("Basis", "sql_ne"), _), _) =>
2532 ((L'.EPrim (Prim.String "<>"), loc), fm) 2517 (str "<>", fm)
2533 | L.ECApp ((L.EFfi ("Basis", "sql_lt"), _), _) => 2518 | L.ECApp ((L.EFfi ("Basis", "sql_lt"), _), _) =>
2534 ((L'.EPrim (Prim.String "<"), loc), fm) 2519 (str "<", fm)
2535 | L.ECApp ((L.EFfi ("Basis", "sql_le"), _), _) => 2520 | L.ECApp ((L.EFfi ("Basis", "sql_le"), _), _) =>
2536 ((L'.EPrim (Prim.String "<="), loc), fm) 2521 (str "<=", fm)
2537 | L.ECApp ((L.EFfi ("Basis", "sql_gt"), _), _) => 2522 | L.ECApp ((L.EFfi ("Basis", "sql_gt"), _), _) =>
2538 ((L'.EPrim (Prim.String ">"), loc), fm) 2523 (str ">", fm)
2539 | L.ECApp ((L.EFfi ("Basis", "sql_ge"), _), _) => 2524 | L.ECApp ((L.EFfi ("Basis", "sql_ge"), _), _) =>
2540 ((L'.EPrim (Prim.String ">="), loc), fm) 2525 (str ">=", fm)
2541 2526
2542 | L.ECApp ((L.EFfi ("Basis", "sql_plus"), _), _) => 2527 | L.ECApp ((L.EFfi ("Basis", "sql_plus"), _), _) =>
2543 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), 2528 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
2544 (L'.EPrim (Prim.String "+"), loc)), loc), fm) 2529 str "+"), loc), fm)
2545 | L.ECApp ((L.EFfi ("Basis", "sql_minus"), _), _) => 2530 | L.ECApp ((L.EFfi ("Basis", "sql_minus"), _), _) =>
2546 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), 2531 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
2547 (L'.EPrim (Prim.String "-"), loc)), loc), fm) 2532 str "-"), loc), fm)
2548 | L.ECApp ((L.EFfi ("Basis", "sql_times"), _), _) => 2533 | L.ECApp ((L.EFfi ("Basis", "sql_times"), _), _) =>
2549 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), 2534 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
2550 (L'.EPrim (Prim.String "*"), loc)), loc), fm) 2535 str "*"), loc), fm)
2551 | L.ECApp ((L.EFfi ("Basis", "sql_div"), _), _) => 2536 | L.ECApp ((L.EFfi ("Basis", "sql_div"), _), _) =>
2552 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), 2537 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
2553 (L'.EPrim (Prim.String "/"), loc)), loc), fm) 2538 str "/"), loc), fm)
2554 | L.EFfi ("Basis", "sql_mod") => 2539 | L.EFfi ("Basis", "sql_mod") =>
2555 ((L'.EPrim (Prim.String "%"), loc), fm) 2540 (str "%", fm)
2556 2541
2557 | L.EFfi ("Basis", "sql_like") => 2542 | L.EFfi ("Basis", "sql_like") =>
2558 ((L'.EPrim (Prim.String "LIKE"), loc), fm) 2543 (str "LIKE", fm)
2559 2544
2560 | L.ECApp ( 2545 | L.ECApp (
2561 (L.ECApp ( 2546 (L.ECApp (
2562 (L.ECApp ( 2547 (L.ECApp (
2563 (L.ECApp ( 2548 (L.ECApp (
2568 _), _), 2553 _), _),
2569 _), _), 2554 _), _),
2570 _) => 2555 _) =>
2571 let 2556 let
2572 val s = (L'.TFfi ("Basis", "string"), loc) 2557 val s = (L'.TFfi ("Basis", "string"), loc)
2573 fun sc s = (L'.EPrim (Prim.String s), loc)
2574 in 2558 in
2575 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), 2559 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
2576 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), 2560 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
2577 strcat [sc "(", 2561 strcat [str "(",
2578 (L'.ERel 1, loc), 2562 (L'.ERel 1, loc),
2579 sc " ", 2563 str " ",
2580 (L'.ERel 0, loc), 2564 (L'.ERel 0, loc),
2581 sc ")"]), loc)), loc), 2565 str ")"]), loc)), loc),
2582 fm) 2566 fm)
2583 end 2567 end
2584 | L.EFfi ("Basis", "sql_not") => ((L'.EPrim (Prim.String "NOT"), loc), fm) 2568 | L.EFfi ("Basis", "sql_not") => (str "NOT", fm)
2585 | L.ECApp ((L.EFfi ("Basis", "sql_neg"), _), _) => 2569 | L.ECApp ((L.EFfi ("Basis", "sql_neg"), _), _) =>
2586 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), 2570 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
2587 (L'.EPrim (Prim.String "-"), loc)), loc), fm) 2571 str "-"), loc), fm)
2588 2572
2589 | L.ECApp ( 2573 | L.ECApp (
2590 (L.ECApp ( 2574 (L.ECApp (
2591 (L.ECApp ( 2575 (L.ECApp (
2592 (L.ECApp ( 2576 (L.ECApp (
2599 _), _), 2583 _), _),
2600 _), _), 2584 _), _),
2601 _) => 2585 _) =>
2602 let 2586 let
2603 val s = (L'.TFfi ("Basis", "string"), loc) 2587 val s = (L'.TFfi ("Basis", "string"), loc)
2604 fun sc s = (L'.EPrim (Prim.String s), loc)
2605 in 2588 in
2606 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), 2589 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
2607 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), 2590 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
2608 (L'.EAbs ("e2", s, s, 2591 (L'.EAbs ("e2", s, s,
2609 strcat [sc "(", 2592 strcat [str "(",
2610 (L'.ERel 1, loc), 2593 (L'.ERel 1, loc),
2611 sc " ", 2594 str " ",
2612 (L'.ERel 2, loc), 2595 (L'.ERel 2, loc),
2613 sc " ", 2596 str " ",
2614 (L'.ERel 0, loc), 2597 (L'.ERel 0, loc),
2615 sc ")"]), loc)), loc)), loc), 2598 str ")"]), loc)), loc)), loc),
2616 fm) 2599 fm)
2617 end 2600 end
2618 | L.EFfi ("Basis", "sql_and") => ((L'.EPrim (Prim.String "AND"), loc), fm) 2601 | L.EFfi ("Basis", "sql_and") => (str "AND", fm)
2619 | L.EFfi ("Basis", "sql_or") => ((L'.EPrim (Prim.String "OR"), loc), fm) 2602 | L.EFfi ("Basis", "sql_or") => (str "OR", fm)
2620 2603
2621 | L.ECApp ( 2604 | L.ECApp (
2622 (L.ECApp ( 2605 (L.ECApp (
2623 (L.ECApp ( 2606 (L.ECApp (
2624 (L.ECApp ( 2607 (L.ECApp (
2630 _), _), 2613 _), _),
2631 _), _), 2614 _), _),
2632 _), _), 2615 _), _),
2633 _), _), 2616 _), _),
2634 (L.CName tab, _)), _), 2617 (L.CName tab, _)), _),
2635 (L.CName field, _)) => ((L'.EPrim (Prim.String ("T_" ^ tab ^ "." ^ Settings.mangleSql (lowercaseFirst field))), loc), fm) 2618 (L.CName field, _)) => (str ("T_" ^ tab ^ "." ^ Settings.mangleSql (lowercaseFirst field)), fm)
2636 2619
2637 | L.ECApp ( 2620 | L.ECApp (
2638 (L.ECApp ( 2621 (L.ECApp (
2639 (L.ECApp ( 2622 (L.ECApp (
2640 (L.ECApp ( 2623 (L.ECApp (
2642 (L.EFfi ("Basis", "sql_exp"), _), 2625 (L.EFfi ("Basis", "sql_exp"), _),
2643 _), _), 2626 _), _),
2644 _), _), 2627 _), _),
2645 _), _), 2628 _), _),
2646 _), _), 2629 _), _),
2647 (L.CName nm, _)) => ((L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm))), loc), fm) 2630 (L.CName nm, _)) => (str (Settings.mangleSql (lowercaseFirst nm)), fm)
2648 2631
2649 | L.ECApp ( 2632 | L.ECApp (
2650 (L.ECApp ( 2633 (L.ECApp (
2651 (L.ECApp ( 2634 (L.ECApp (
2652 (L.ECApp ( 2635 (L.ECApp (
2659 _), _), 2642 _), _),
2660 _), _), 2643 _), _),
2661 _) => 2644 _) =>
2662 let 2645 let
2663 val s = (L'.TFfi ("Basis", "string"), loc) 2646 val s = (L'.TFfi ("Basis", "string"), loc)
2664 fun sc s = (L'.EPrim (Prim.String s), loc)
2665 in 2647 in
2666 (if #nestedRelops (Settings.currentDbms ()) then 2648 (if #nestedRelops (Settings.currentDbms ()) then
2667 (L'.EAbs ("c", s, (L'.TFun ((L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc), 2649 (L'.EAbs ("c", s, (L'.TFun ((L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc),
2668 (L'.EAbs ("all", (L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc), 2650 (L'.EAbs ("all", (L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
2669 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), 2651 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
2670 (L'.EAbs ("e2", s, s, 2652 (L'.EAbs ("e2", s, s,
2671 strcat [sc "((", 2653 strcat [str "((",
2672 (L'.ERel 1, loc), 2654 (L'.ERel 1, loc),
2673 sc ") ", 2655 str ") ",
2674 (L'.ERel 3, loc), 2656 (L'.ERel 3, loc),
2675 (L'.ECase ((L'.ERel 2, loc), 2657 (L'.ECase ((L'.ERel 2, loc),
2676 [((L'.PCon (L'.Enum, L'.PConFfi {mod = "Basis", 2658 [((L'.PCon (L'.Enum, L'.PConFfi {mod = "Basis",
2677 datatyp = "bool", 2659 datatyp = "bool",
2678 con = "True", 2660 con = "True",
2679 arg = NONE}, NONE), loc), 2661 arg = NONE}, NONE), loc),
2680 sc " ALL"), 2662 str " ALL"),
2681 ((L'.PWild, loc), 2663 ((L'.PWild, loc),
2682 sc "")], 2664 str "")],
2683 {disc = (L'.TFfi ("Basis", "bool"), loc), 2665 {disc = (L'.TFfi ("Basis", "bool"), loc),
2684 result = s}), loc), 2666 result = s}), loc),
2685 sc " (", 2667 str " (",
2686 (L'.ERel 0, loc), 2668 (L'.ERel 0, loc),
2687 sc "))"]), loc)), loc)), loc)), loc) 2669 str "))"]), loc)), loc)), loc)), loc)
2688 else 2670 else
2689 (L'.EAbs ("c", s, (L'.TFun ((L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc), 2671 (L'.EAbs ("c", s, (L'.TFun ((L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc),
2690 (L'.EAbs ("all", (L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc), 2672 (L'.EAbs ("all", (L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
2691 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), 2673 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
2692 (L'.EAbs ("e2", s, s, 2674 (L'.EAbs ("e2", s, s,
2693 strcat [(L'.ERel 1, loc), 2675 strcat [(L'.ERel 1, loc),
2694 sc " ", 2676 str " ",
2695 (L'.ERel 3, loc), 2677 (L'.ERel 3, loc),
2696 (L'.ECase ((L'.ERel 2, loc), 2678 (L'.ECase ((L'.ERel 2, loc),
2697 [((L'.PCon (L'.Enum, L'.PConFfi {mod = "Basis", 2679 [((L'.PCon (L'.Enum, L'.PConFfi {mod = "Basis",
2698 datatyp = "bool", 2680 datatyp = "bool",
2699 con = "True", 2681 con = "True",
2700 arg = NONE}, NONE), loc), 2682 arg = NONE}, NONE), loc),
2701 sc " ALL"), 2683 str " ALL"),
2702 ((L'.PWild, loc), 2684 ((L'.PWild, loc),
2703 sc "")], 2685 str "")],
2704 {disc = (L'.TFfi ("Basis", "bool"), loc), 2686 {disc = (L'.TFfi ("Basis", "bool"), loc),
2705 result = s}), loc), 2687 result = s}), loc),
2706 sc " ", 2688 str " ",
2707 (L'.ERel 0, loc)]), loc)), loc)), loc)), loc), 2689 (L'.ERel 0, loc)]), loc)), loc)), loc)), loc),
2708 fm) 2690 fm)
2709 end 2691 end
2710 | L.ECApp ( 2692 | L.ECApp (
2711 (L.ECApp ( 2693 (L.ECApp (
2718 _), _), 2700 _), _),
2719 _), _), 2701 _), _),
2720 _) => 2702 _) =>
2721 let 2703 let
2722 val s = (L'.TFfi ("Basis", "string"), loc) 2704 val s = (L'.TFfi ("Basis", "string"), loc)
2723 fun sc s = (L'.EPrim (Prim.String s), loc)
2724 in 2705 in
2725 ((L'.EAbs ("x", s, s, (L'.ERel 0, loc)), loc), 2706 ((L'.EAbs ("x", s, s, (L'.ERel 0, loc)), loc),
2726 fm) 2707 fm)
2727 end 2708 end
2728 2709
2729 | L.EFfi ("Basis", "sql_union") => ((L'.EPrim (Prim.String "UNION"), loc), fm) 2710 | L.EFfi ("Basis", "sql_union") => (str "UNION", fm)
2730 | L.EFfi ("Basis", "sql_intersect") => 2711 | L.EFfi ("Basis", "sql_intersect") =>
2731 (if #onlyUnion (Settings.currentDbms ()) then 2712 (if #onlyUnion (Settings.currentDbms ()) then
2732 ErrorMsg.errorAt loc "The DBMS you've selected doesn't support INTERSECT." 2713 ErrorMsg.errorAt loc "The DBMS you've selected doesn't support INTERSECT."
2733 else 2714 else
2734 (); 2715 ();
2735 ((L'.EPrim (Prim.String "INTERSECT"), loc), fm)) 2716 (str "INTERSECT", fm))
2736 | L.EFfi ("Basis", "sql_except") => 2717 | L.EFfi ("Basis", "sql_except") =>
2737 (if #onlyUnion (Settings.currentDbms ()) then 2718 (if #onlyUnion (Settings.currentDbms ()) then
2738 ErrorMsg.errorAt loc "The DBMS you've selected doesn't support EXCEPT." 2719 ErrorMsg.errorAt loc "The DBMS you've selected doesn't support EXCEPT."
2739 else 2720 else
2740 (); 2721 ();
2741 ((L'.EPrim (Prim.String "EXCEPT"), loc), fm)) 2722 (str "EXCEPT", fm))
2742 2723
2743 | L.ECApp ( 2724 | L.ECApp (
2744 (L.ECApp ( 2725 (L.ECApp (
2745 (L.ECApp ( 2726 (L.ECApp (
2746 (L.EFfi ("Basis", "sql_count"), _), 2727 (L.EFfi ("Basis", "sql_count"), _),
2747 _), _), 2728 _), _),
2748 _), _), 2729 _), _),
2749 _) => ((L'.EPrim (Prim.String "COUNT(*)"), loc), 2730 _) => (str "COUNT(*)", fm)
2750 fm)
2751 2731
2752 | L.ECApp ( 2732 | L.ECApp (
2753 (L.ECApp ( 2733 (L.ECApp (
2754 (L.ECApp ( 2734 (L.ECApp (
2755 (L.ECApp ( 2735 (L.ECApp (
2760 _), _), 2740 _), _),
2761 _), _), 2741 _), _),
2762 t) => 2742 t) =>
2763 let 2743 let
2764 val s = (L'.TFfi ("Basis", "string"), loc) 2744 val s = (L'.TFfi ("Basis", "string"), loc)
2765 fun sc s = (L'.EPrim (Prim.String s), loc)
2766 2745
2767 val main = strcat [(L'.ERel 1, loc), 2746 val main = strcat [(L'.ERel 1, loc),
2768 sc "(", 2747 str "(",
2769 (L'.ERel 0, loc), 2748 (L'.ERel 0, loc),
2770 sc ")"] 2749 str ")"]
2771 in 2750 in
2772 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), 2751 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
2773 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), main), loc)), loc), 2752 (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), main), loc)), loc),
2774 fm) 2753 fm)
2775 end 2754 end
2776 2755
2777 | L.ECApp ((L.EFfi ("Basis", "sql_count_col"), _), _) => 2756 | L.ECApp ((L.EFfi ("Basis", "sql_count_col"), _), _) =>
2778 ((L'.EPrim (Prim.String "COUNT"), loc), 2757 (str "COUNT", fm)
2779 fm)
2780 2758
2781 | L.EFfi ("Basis", "sql_summable_int") => ((L'.ERecord [], loc), fm) 2759 | L.EFfi ("Basis", "sql_summable_int") => ((L'.ERecord [], loc), fm)
2782 | L.EFfi ("Basis", "sql_summable_float") => ((L'.ERecord [], loc), fm) 2760 | L.EFfi ("Basis", "sql_summable_float") => ((L'.ERecord [], loc), fm)
2783 | L.ECApp ((L.EFfi ("Basis", "sql_summable_option"), _), _) => 2761 | L.ECApp ((L.EFfi ("Basis", "sql_summable_option"), _), _) =>
2784 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc), 2762 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
2785 (L'.ERecord [], loc)), loc), 2763 (L'.ERecord [], loc)), loc),
2786 fm) 2764 fm)
2787 | L.ECApp ((L.EFfi ("Basis", "sql_avg"), _), _) => 2765 | L.ECApp ((L.EFfi ("Basis", "sql_avg"), _), _) =>
2788 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), 2766 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
2789 (L'.EPrim (Prim.String "AVG"), loc)), loc), 2767 str "AVG"), loc),
2790 fm) 2768 fm)
2791 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_sum"), _), _), _), _) => 2769 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_sum"), _), _), _), _) =>
2792 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc)), loc), 2770 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc)), loc),
2793 (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), 2771 (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
2794 (L'.EPrim (Prim.String "SUM"), loc)), loc)), loc), 2772 str "SUM"), loc)), loc),
2795 fm) 2773 fm)
2796 2774
2797 | L.EFfi ("Basis", "sql_arith_int") => ((L'.ERecord [], loc), fm) 2775 | L.EFfi ("Basis", "sql_arith_int") => ((L'.ERecord [], loc), fm)
2798 | L.EFfi ("Basis", "sql_arith_float") => ((L'.ERecord [], loc), fm) 2776 | L.EFfi ("Basis", "sql_arith_float") => ((L'.ERecord [], loc), fm)
2799 | L.ECApp ((L.EFfi ("Basis", "sql_arith_option"), _), _) => 2777 | L.ECApp ((L.EFfi ("Basis", "sql_arith_option"), _), _) =>
2809 (L'.ERecord [], loc)), loc), 2787 (L'.ERecord [], loc)), loc),
2810 fm) 2788 fm)
2811 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_max"), _), _), _), _) => 2789 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_max"), _), _), _), _) =>
2812 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc)), loc), 2790 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc)), loc),
2813 (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), 2791 (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
2814 (L'.EPrim (Prim.String "MAX"), loc)), loc)), loc), 2792 str "MAX"), loc)), loc),
2815 fm) 2793 fm)
2816 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_min"), _), _), _), _) => 2794 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_min"), _), _), _), _) =>
2817 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc)), loc), 2795 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc)), loc),
2818 (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), 2796 (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
2819 (L'.EPrim (Prim.String "MIN"), loc)), loc)), loc), 2797 str "MIN"), loc)), loc),
2820 fm) 2798 fm)
2821 2799
2822 | L.EFfi ("Basis", "sql_asc") => ((L'.EPrim (Prim.String ""), loc), fm) 2800 | L.EFfi ("Basis", "sql_asc") => (str "", fm)
2823 | L.EFfi ("Basis", "sql_desc") => ((L'.EPrim (Prim.String " DESC"), loc), fm) 2801 | L.EFfi ("Basis", "sql_desc") => (str " DESC", fm)
2824 | L.ECApp ( 2802 | L.ECApp (
2825 (L.ECApp ( 2803 (L.ECApp (
2826 (L.ECApp ( 2804 (L.ECApp (
2827 (L.ECApp ( 2805 (L.ECApp (
2828 (L.EFfi ("Basis", "sql_nfunc"), _), 2806 (L.EFfi ("Basis", "sql_nfunc"), _),
2830 _), _), 2808 _), _),
2831 _), _), 2809 _), _),
2832 _) => 2810 _) =>
2833 let 2811 let
2834 val s = (L'.TFfi ("Basis", "string"), loc) 2812 val s = (L'.TFfi ("Basis", "string"), loc)
2835 fun sc s = (L'.EPrim (Prim.String s), loc)
2836 in 2813 in
2837 ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), 2814 ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc),
2838 fm) 2815 fm)
2839 end 2816 end
2840 2817
2858 (L'.EAbs ("e", s, s, 2835 (L'.EAbs ("e", s, s,
2859 (L'.ERel 0, loc)), loc)), loc), 2836 (L'.ERel 0, loc)), loc)), loc),
2860 fm) 2837 fm)
2861 end 2838 end
2862 2839
2863 | L.EFfi ("Basis", "sql_current_timestamp") => ((L'.EPrim (Prim.String "CURRENT_TIMESTAMP"), loc), fm) 2840 | L.EFfi ("Basis", "sql_current_timestamp") => (str "CURRENT_TIMESTAMP", fm)
2864 2841
2865 | L.ECApp ( 2842 | L.ECApp (
2866 (L.ECApp ( 2843 (L.ECApp (
2867 (L.ECApp ( 2844 (L.ECApp (
2868 (L.ECApp ( 2845 (L.ECApp (
2873 _), _), 2850 _), _),
2874 _), _), 2851 _), _),
2875 _) => 2852 _) =>
2876 let 2853 let
2877 val s = (L'.TFfi ("Basis", "string"), loc) 2854 val s = (L'.TFfi ("Basis", "string"), loc)
2878 fun sc s = (L'.EPrim (Prim.String s), loc)
2879 in 2855 in
2880 ((L'.EAbs ("f", s, (L'.TFun (s, s), loc), 2856 ((L'.EAbs ("f", s, (L'.TFun (s, s), loc),
2881 (L'.EAbs ("x", s, s, 2857 (L'.EAbs ("x", s, s,
2882 strcat [(L'.ERel 1, loc), 2858 strcat [(L'.ERel 1, loc),
2883 sc "(", 2859 str "(",
2884 (L'.ERel 0, loc), 2860 (L'.ERel 0, loc),
2885 sc ")"]), loc)), loc), 2861 str ")"]), loc)), loc),
2886 fm) 2862 fm)
2887 end 2863 end
2888 | L.EFfi ("Basis", "sql_octet_length") => 2864 | L.EFfi ("Basis", "sql_octet_length") =>
2889 ((L'.EPrim (Prim.String (if #supportsOctetLength (Settings.currentDbms ()) then 2865 (str (if #supportsOctetLength (Settings.currentDbms ()) then
2890 "octet_length" 2866 "octet_length"
2891 else 2867 else
2892 "length")), loc), fm) 2868 "length"), fm)
2893 | L.EFfi ("Basis", "sql_lower") => 2869 | L.EFfi ("Basis", "sql_lower") =>
2894 ((L'.EPrim (Prim.String "lower"), loc), fm) 2870 (str "lower", fm)
2895 | L.EFfi ("Basis", "sql_upper") => 2871 | L.EFfi ("Basis", "sql_upper") =>
2896 ((L'.EPrim (Prim.String "upper"), loc), fm) 2872 (str "upper", fm)
2897 | L.ECApp ((L.EFfi ("Basis", "sql_known"), _), _) => 2873 | L.ECApp ((L.EFfi ("Basis", "sql_known"), _), _) =>
2898 ((L'.EFfi ("Basis", "sql_known"), loc), fm) 2874 ((L'.EFfi ("Basis", "sql_known"), loc), fm)
2899 2875
2900 | (L.ECApp ( 2876 | (L.ECApp (
2901 (L.ECApp ( 2877 (L.ECApp (
2905 _), _), 2881 _), _),
2906 _), _), 2882 _), _),
2907 _), _)) => 2883 _), _)) =>
2908 let 2884 let
2909 val s = (L'.TFfi ("Basis", "string"), loc) 2885 val s = (L'.TFfi ("Basis", "string"), loc)
2910 fun sc s = (L'.EPrim (Prim.String s), loc)
2911 in 2886 in
2912 ((L'.EAbs ("s", s, s, 2887 ((L'.EAbs ("s", s, s,
2913 strcat [sc "(", 2888 strcat [str "(",
2914 (L'.ERel 0, loc), 2889 (L'.ERel 0, loc),
2915 sc " IS NULL)"]), loc), 2890 str " IS NULL)"]), loc),
2916 fm) 2891 fm)
2917 end 2892 end
2918 2893
2919 | (L.ECApp ( 2894 | (L.ECApp (
2920 (L.ECApp ( 2895 (L.ECApp (
2924 _), _), 2899 _), _),
2925 _), _), 2900 _), _),
2926 _), _)) => 2901 _), _)) =>
2927 let 2902 let
2928 val s = (L'.TFfi ("Basis", "string"), loc) 2903 val s = (L'.TFfi ("Basis", "string"), loc)
2929 fun sc s = (L'.EPrim (Prim.String s), loc)
2930 in 2904 in
2931 ((L'.EAbs ("x1", s, (L'.TFun (s, s), loc), 2905 ((L'.EAbs ("x1", s, (L'.TFun (s, s), loc),
2932 (L'.EAbs ("x1", s, s, 2906 (L'.EAbs ("x1", s, s,
2933 strcat [sc "COALESCE(", 2907 strcat [str "COALESCE(",
2934 (L'.ERel 1, loc), 2908 (L'.ERel 1, loc),
2935 sc ",", 2909 str ",",
2936 (L'.ERel 0, loc), 2910 (L'.ERel 0, loc),
2937 sc ")"]), loc)), loc), 2911 str ")"]), loc)), loc),
2938 fm) 2912 fm)
2939 end 2913 end
2940 2914
2941 | (L.ECApp ( 2915 | (L.ECApp (
2942 (L.ECApp ( 2916 (L.ECApp (
2946 _), _), 2920 _), _),
2947 _), _), 2921 _), _),
2948 _), _)) => 2922 _), _)) =>
2949 let 2923 let
2950 val s = (L'.TFfi ("Basis", "string"), loc) 2924 val s = (L'.TFfi ("Basis", "string"), loc)
2951 fun sc s = (L'.EPrim (Prim.String s), loc)
2952 in 2925 in
2953 ((L'.EAbs ("if", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), 2926 ((L'.EAbs ("if", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
2954 (L'.EAbs ("then", s, (L'.TFun (s, s), loc), 2927 (L'.EAbs ("then", s, (L'.TFun (s, s), loc),
2955 (L'.EAbs ("else", s, s, 2928 (L'.EAbs ("else", s, s,
2956 strcat [sc "(CASE WHEN (", 2929 strcat [str "(CASE WHEN (",
2957 (L'.ERel 2, loc), 2930 (L'.ERel 2, loc),
2958 sc ") THEN (", 2931 str ") THEN (",
2959 (L'.ERel 1, loc), 2932 (L'.ERel 1, loc),
2960 sc ") ELSE (", 2933 str ") ELSE (",
2961 (L'.ERel 0, loc), 2934 (L'.ERel 0, loc),
2962 sc ") END)"]), loc)), loc)), loc), 2935 str ") END)"]), loc)), loc)), loc),
2963 fm) 2936 fm)
2964 end 2937 end
2965 2938
2966 | L.ECApp ( 2939 | L.ECApp (
2967 (L.ECApp ( 2940 (L.ECApp (
2972 _), _), 2945 _), _),
2973 _), _), 2946 _), _),
2974 _) => 2947 _) =>
2975 let 2948 let
2976 val s = (L'.TFfi ("Basis", "string"), loc) 2949 val s = (L'.TFfi ("Basis", "string"), loc)
2977 fun sc s = (L'.EPrim (Prim.String s), loc)
2978 in 2950 in
2979 ((L'.EAbs ("u", (L'.TRecord [], loc), (L'.TFun (s, s), loc), 2951 ((L'.EAbs ("u", (L'.TRecord [], loc), (L'.TFun (s, s), loc),
2980 (L'.EAbs ("x", s, s, 2952 (L'.EAbs ("x", s, s,
2981 (L'.ERel 0, loc)), loc)), loc), 2953 (L'.ERel 0, loc)), loc)), loc),
2982 fm) 2954 fm)
2995 _), _), 2967 _), _),
2996 _), _), 2968 _), _),
2997 _) => 2969 _) =>
2998 let 2970 let
2999 val s = (L'.TFfi ("Basis", "string"), loc) 2971 val s = (L'.TFfi ("Basis", "string"), loc)
3000 fun sc s = (L'.EPrim (Prim.String s), loc)
3001 in 2972 in
3002 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (s, s), loc), 2973 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (s, s), loc),
3003 (L'.EAbs ("x", s, s, 2974 (L'.EAbs ("x", s, s,
3004 strcat [sc "(", 2975 strcat [str "(",
3005 (L'.ERel 0, loc), 2976 (L'.ERel 0, loc),
3006 sc ")"]), loc)), loc), 2977 str ")"]), loc)), loc),
3007 fm) 2978 fm)
3008 end 2979 end
3009 2980
3010 | L.ECApp ( 2981 | L.ECApp (
3011 (L.ECApp ( 2982 (L.ECApp (
3012 (L.ECApp ( 2983 (L.ECApp (
3013 (L.EFfi ("Basis", "sql_no_partition"), _), 2984 (L.EFfi ("Basis", "sql_no_partition"), _),
3014 _), _), 2985 _), _),
3015 _), _), 2986 _), _),
3016 _) => ((L'.EPrim (Prim.String ""), loc), fm) 2987 _) => (str "", fm)
3017 | L.ECApp ( 2988 | L.ECApp (
3018 (L.ECApp ( 2989 (L.ECApp (
3019 (L.ECApp ( 2990 (L.ECApp (
3020 (L.ECApp ( 2991 (L.ECApp (
3021 (L.EFfi ("Basis", "sql_partition"), _), 2992 (L.EFfi ("Basis", "sql_partition"), _),
3024 _), _), 2995 _), _),
3025 _) => 2996 _) =>
3026 let 2997 let
3027 val s = (L'.TFfi ("Basis", "string"), loc) 2998 val s = (L'.TFfi ("Basis", "string"), loc)
3028 in 2999 in
3029 ((L'.EAbs ("e", s, s, strcat [(L'.EPrim (Prim.String "PARTITION BY "), loc), (L'.ERel 0, loc)]), loc), 3000 ((L'.EAbs ("e", s, s, strcat [str "PARTITION BY ", (L'.ERel 0, loc)]), loc),
3030 fm) 3001 fm)
3031 end 3002 end
3032 3003
3033 | L.ECApp ( 3004 | L.ECApp (
3034 (L.ECApp ( 3005 (L.ECApp (
3044 () 3015 ()
3045 else 3016 else
3046 ErrorMsg.errorAt loc "The DBMS you've selected doesn't support window functions." 3017 ErrorMsg.errorAt loc "The DBMS you've selected doesn't support window functions."
3047 3018
3048 val s = (L'.TFfi ("Basis", "string"), loc) 3019 val s = (L'.TFfi ("Basis", "string"), loc)
3049 fun sc s = (L'.EPrim (Prim.String s), loc)
3050 3020
3051 val main = strcat [(L'.ERel 2, loc), 3021 val main = strcat [(L'.ERel 2, loc),
3052 sc " OVER (", 3022 str " OVER (",
3053 (L'.ERel 1, loc), 3023 (L'.ERel 1, loc),
3054 (L'.ECase ((L'.ERel 0, loc), 3024 (L'.ECase ((L'.ERel 0, loc),
3055 [((L'.PPrim (Prim.String ""), loc), 3025 [((L'.PPrim (Prim.String (Prim.Normal, "")), loc),
3056 sc ""), 3026 str ""),
3057 ((L'.PWild, loc), 3027 ((L'.PWild, loc),
3058 strcat [sc " ORDER BY ", 3028 strcat [str " ORDER BY ",
3059 (L'.ERel 0, loc)])], 3029 (L'.ERel 0, loc)])],
3060 {disc = s, 3030 {disc = s,
3061 result = s}), loc), 3031 result = s}), loc),
3062 sc ")"] 3032 str ")"]
3063 in 3033 in
3064 ((L'.EAbs ("w", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), 3034 ((L'.EAbs ("w", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
3065 (L'.EAbs ("p", s, (L'.TFun (s, s), loc), 3035 (L'.EAbs ("p", s, (L'.TFun (s, s), loc),
3066 (L'.EAbs ("o", s, s, 3036 (L'.EAbs ("o", s, s,
3067 main), loc)), loc)), loc), 3037 main), loc)), loc)), loc),
3079 _), _), 3049 _), _),
3080 _), _), 3050 _), _),
3081 _) => 3051 _) =>
3082 let 3052 let
3083 val s = (L'.TFfi ("Basis", "string"), loc) 3053 val s = (L'.TFfi ("Basis", "string"), loc)
3084 fun sc s = (L'.EPrim (Prim.String s), loc)
3085 3054
3086 val main = strcat [(L'.ERel 1, loc), 3055 val main = strcat [(L'.ERel 1, loc),
3087 sc "(", 3056 str "(",
3088 (L'.ERel 0, loc), 3057 (L'.ERel 0, loc),
3089 sc ")"] 3058 str ")"]
3090 in 3059 in
3091 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), 3060 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
3092 (L'.EAbs ("e1", s, s, main), loc)), loc), 3061 (L'.EAbs ("e1", s, s, main), loc)), loc),
3093 fm) 3062 fm)
3094 end 3063 end
3095 3064
3096 | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_window_count"), _), _), _), _), _), _) => 3065 | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_window_count"), _), _), _), _), _), _) =>
3097 ((L'.EPrim (Prim.String "COUNT(*)"), loc), fm) 3066 (str "COUNT(*)", fm)
3098 | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_rank"), _), _), _), _), _), _) => 3067 | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_rank"), _), _), _), _), _), _) =>
3099 ((L'.EPrim (Prim.String "RANK()"), loc), fm) 3068 (str "RANK()", fm)
3100 3069
3101 | L.EFfiApp ("Basis", "nextval", [(e, _)]) => 3070 | L.EFfiApp ("Basis", "nextval", [(e, _)]) =>
3102 let 3071 let
3103 val (e, fm) = monoExp (env, st, fm) e 3072 val (e, fm) = monoExp (env, st, fm) e
3104 in 3073 in
3110 val (e2, fm) = monoExp (env, st, fm) e2 3079 val (e2, fm) = monoExp (env, st, fm) e2
3111 in 3080 in
3112 ((L'.ESetval (e1, e2), loc), fm) 3081 ((L'.ESetval (e1, e2), loc), fm)
3113 end 3082 end
3114 3083
3115 | L.EFfi ("Basis", "null") => ((L'.EPrim (Prim.String ""), loc), fm) 3084 | L.EFfi ("Basis", "null") => (str "", fm)
3116 3085
3117 | L.EFfiApp ("Basis", "classes", [(s1, _), (s2, _)]) => 3086 | L.EFfiApp ("Basis", "classes", [(s1, _), (s2, _)]) =>
3118 let 3087 let
3119 val (s1, fm) = monoExp (env, st, fm) s1 3088 val (s1, fm) = monoExp (env, st, fm) s1
3120 val (s2, fm) = monoExp (env, st, fm) s2 3089 val (s2, fm) = monoExp (env, st, fm) s2
3121 in 3090 in
3122 ((L'.EStrcat (s1, (L'.EStrcat ((L'.EPrim (Prim.String " "), loc), s2), loc)), loc), 3091 ((L'.EStrcat (s1, (L'.EStrcat (str " ", s2), loc)), loc),
3123 fm) 3092 fm)
3124 end 3093 end
3125 3094
3126 | L.EFfi ("Basis", "data_kind") => ((L'.EPrim (Prim.String "data-"), loc), fm) 3095 | L.EFfi ("Basis", "data_kind") => (str "data-", fm)
3127 | L.EFfi ("Basis", "aria_kind") => ((L'.EPrim (Prim.String "aria-"), loc), fm) 3096 | L.EFfi ("Basis", "aria_kind") => (str "aria-", fm)
3128 3097
3129 | L.EFfiApp ("Basis", "data_attr", [(sk, _), (s1, _), (s2, _)]) => 3098 | L.EFfiApp ("Basis", "data_attr", [(sk, _), (s1, _), (s2, _)]) =>
3130 let 3099 let
3131 val (sk, fm) = monoExp (env, st, fm) sk 3100 val (sk, fm) = monoExp (env, st, fm) sk
3132 val (s1, fm) = monoExp (env, st, fm) s1 3101 val (s1, fm) = monoExp (env, st, fm) s1
3133 val (s2, fm) = monoExp (env, st, fm) s2 3102 val (s2, fm) = monoExp (env, st, fm) s2
3134 in 3103 in
3135 ((L'.EStrcat (sk, 3104 ((L'.EStrcat (sk,
3136 (L'.EStrcat ((L'.EFfiApp ("Basis", "blessData", [(s1, (L'.TFfi ("Basis", "string"), loc))]), loc), 3105 (L'.EStrcat ((L'.EFfiApp ("Basis", "blessData", [(s1, (L'.TFfi ("Basis", "string"), loc))]), loc),
3137 (L'.EStrcat ((L'.EPrim (Prim.String "=\""), loc), 3106 (L'.EStrcat (str "=\"",
3138 (L'.EStrcat ((L'.EFfiApp ("Basis", "attrifyString", [(s2, (L'.TFfi ("Basis", "string"), loc))]), loc), 3107 (L'.EStrcat ((L'.EFfiApp ("Basis", "attrifyString", [(s2, (L'.TFfi ("Basis", "string"), loc))]), loc),
3139 (L'.EPrim (Prim.String "\""), loc)), loc)), 3108 str "\""), loc)),
3140 loc)), loc)), loc), 3109 loc)), loc)), loc),
3141 fm) 3110 fm)
3142 end 3111 end
3143 3112
3144 | L.EFfiApp ("Basis", "data_attrs", [(s1, _), (s2, _)]) => 3113 | L.EFfiApp ("Basis", "data_attrs", [(s1, _), (s2, _)]) =>
3145 let 3114 let
3146 val (s1, fm) = monoExp (env, st, fm) s1 3115 val (s1, fm) = monoExp (env, st, fm) s1
3147 val (s2, fm) = monoExp (env, st, fm) s2 3116 val (s2, fm) = monoExp (env, st, fm) s2
3148 in 3117 in
3149 ((L'.EStrcat (s1, (L'.EStrcat ((L'.EPrim (Prim.String " "), loc), s2), loc)), loc), 3118 ((L'.EStrcat (s1, (L'.EStrcat (str " ", s2), loc)), loc),
3150 fm) 3119 fm)
3151 end 3120 end
3152 3121
3153 | L.EFfiApp ("Basis", "css_url", [(s, _)]) => 3122 | L.EFfiApp ("Basis", "css_url", [(s, _)]) =>
3154 let 3123 let
3155 val (s, fm) = monoExp (env, st, fm) s 3124 val (s, fm) = monoExp (env, st, fm) s
3156 in 3125 in
3157 ((L'.EStrcat ((L'.EPrim (Prim.String "url("), loc), 3126 ((L'.EStrcat (str "url(",
3158 (L'.EStrcat ((L'.EFfiApp ("Basis", "css_url", [(s, (L'.TFfi ("Basis", "string"), loc))]), loc), 3127 (L'.EStrcat ((L'.EFfiApp ("Basis", "css_url", [(s, (L'.TFfi ("Basis", "string"), loc))]), loc),
3159 (L'.EPrim (Prim.String ")"), loc)), loc)), loc), 3128 str ")"), loc)), loc),
3160 fm) 3129 fm)
3161 end 3130 end
3162 3131
3163 | L.EFfiApp ("Basis", "property", [(s, _)]) => 3132 | L.EFfiApp ("Basis", "property", [(s, _)]) =>
3164 let 3133 let
3165 val (s, fm) = monoExp (env, st, fm) s 3134 val (s, fm) = monoExp (env, st, fm) s
3166 in 3135 in
3167 ((L'.EStrcat ((L'.EFfiApp ("Basis", "property", [(s, (L'.TFfi ("Basis", "string"), loc))]), loc), 3136 ((L'.EStrcat ((L'.EFfiApp ("Basis", "property", [(s, (L'.TFfi ("Basis", "string"), loc))]), loc),
3168 (L'.EPrim (Prim.String ":"), loc)), loc), 3137 str ":"), loc),
3169 fm) 3138 fm)
3170 end 3139 end
3171 | L.EFfiApp ("Basis", "value", [(s1, _), (s2, _)]) => 3140 | L.EFfiApp ("Basis", "value", [(s1, _), (s2, _)]) =>
3172 let 3141 let
3173 val (s1, fm) = monoExp (env, st, fm) s1 3142 val (s1, fm) = monoExp (env, st, fm) s1
3174 val (s2, fm) = monoExp (env, st, fm) s2 3143 val (s2, fm) = monoExp (env, st, fm) s2
3175 in 3144 in
3176 ((L'.EStrcat (s1, (L'.EStrcat ((L'.EPrim (Prim.String " "), loc), s2), loc)), loc), 3145 ((L'.EStrcat (s1, (L'.EStrcat (str " ", s2), loc)), loc),
3177 fm) 3146 fm)
3178 end 3147 end
3179 3148
3180 | L.EFfi ("Basis", "noStyle") => ((L'.EPrim (Prim.String ""), loc), fm) 3149 | L.EFfi ("Basis", "noStyle") => (str "", fm)
3181 | L.EFfiApp ("Basis", "oneProperty", [(s1, _), (s2, _)]) => 3150 | L.EFfiApp ("Basis", "oneProperty", [(s1, _), (s2, _)]) =>
3182 let 3151 let
3183 val (s1, fm) = monoExp (env, st, fm) s1 3152 val (s1, fm) = monoExp (env, st, fm) s1
3184 val (s2, fm) = monoExp (env, st, fm) s2 3153 val (s2, fm) = monoExp (env, st, fm) s2
3185 in 3154 in
3186 ((L'.EStrcat (s1, (L'.EStrcat (s2, (L'.EPrim (Prim.String ";"), loc)), loc)), loc), 3155 ((L'.EStrcat (s1, (L'.EStrcat (s2, str ";"), loc)), loc),
3187 fm) 3156 fm)
3188 end 3157 end
3189 3158
3190 | L.EApp ( 3159 | L.EApp (
3191 (L.ECApp ( 3160 (L.ECApp (
3330 () 3299 ()
3331 3300
3332 fun tagStart tag' = 3301 fun tagStart tag' =
3333 let 3302 let
3334 val t = (L'.TFfi ("Basis", "string"), loc) 3303 val t = (L'.TFfi ("Basis", "string"), loc)
3335 val s = (L'.EPrim (Prim.String (String.concat ["<", tag'])), loc) 3304 val s = strH (String.concat ["<", tag'])
3336 3305
3337 val s = (L'.EStrcat (s, 3306 val s = (L'.EStrcat (s,
3338 (L'.ECase (class, 3307 (L'.ECase (class,
3339 [((L'.PPrim (Prim.String ""), loc), 3308 [((L'.PPrim (Prim.String (Prim.Normal, "")), loc),
3340 (L'.EPrim (Prim.String ""), loc)), 3309 strH ""),
3341 ((L'.PVar ("x", t), loc), 3310 ((L'.PVar ("x", t), loc),
3342 (L'.EStrcat ((L'.EPrim (Prim.String " class=\""), loc), 3311 (L'.EStrcat (strH " class=\"",
3343 (L'.EStrcat ((L'.ERel 0, loc), 3312 (L'.EStrcat ((L'.ERel 0, loc),
3344 (L'.EPrim (Prim.String "\""), loc)), 3313 strH "\""),
3345 loc)), loc))], 3314 loc)), loc))],
3346 {disc = t, 3315 {disc = t,
3347 result = t}), loc)), loc) 3316 result = t}), loc)), loc)
3348 3317
3349 val s = (L'.EStrcat (s, 3318 val s = (L'.EStrcat (s,
3350 (L'.ECase (style, 3319 (L'.ECase (style,
3351 [((L'.PPrim (Prim.String ""), loc), 3320 [((L'.PPrim (Prim.String (Prim.Normal, "")), loc),
3352 (L'.EPrim (Prim.String ""), loc)), 3321 strH ""),
3353 ((L'.PVar ("x", t), loc), 3322 ((L'.PVar ("x", t), loc),
3354 (L'.EStrcat ((L'.EPrim (Prim.String " style=\""), loc), 3323 (L'.EStrcat (strH " style=\"",
3355 (L'.EStrcat ((L'.ERel 0, loc), 3324 (L'.EStrcat ((L'.ERel 0, loc),
3356 (L'.EPrim (Prim.String "\""), loc)), 3325 strH "\""),
3357 loc)), loc))], 3326 loc)), loc))],
3358 {disc = t, 3327 {disc = t,
3359 result = t}), loc)), loc) 3328 result = t}), loc)), loc)
3360 3329
3361 val (s, fm) = foldl (fn (("Action", _, _), acc) => acc 3330 val (s, fm) = foldl (fn (("Action", _, _), acc) => acc
3362 | (("Source", _, _), acc) => acc 3331 | (("Source", _, _), acc) => acc
3363 | (("Data", e, _), (s, fm)) => 3332 | (("Data", e, _), (s, fm)) =>
3364 ((L'.EStrcat (s, 3333 ((L'.EStrcat (s,
3365 (L'.EStrcat ( 3334 (L'.EStrcat (
3366 (L'.EPrim (Prim.String " "), loc), 3335 strH " ",
3367 e), loc)), loc), 3336 e), loc)), loc),
3368 fm) 3337 fm)
3369 | ((x, e, t), (s, fm)) => 3338 | ((x, e, t), (s, fm)) =>
3370 case t of 3339 case t of
3371 (L'.TFfi ("Basis", "bool"), _) => 3340 (L'.TFfi ("Basis", "bool"), _) =>
3378 datatyp = "bool", 3347 datatyp = "bool",
3379 con = "True", 3348 con = "True",
3380 arg = NONE}, 3349 arg = NONE},
3381 NONE), loc), 3350 NONE), loc),
3382 (L'.EStrcat (s, 3351 (L'.EStrcat (s,
3383 (L'.EPrim (Prim.String s'), loc)), loc)), 3352 strH s'), loc)),
3384 ((L'.PCon (L'.Enum, 3353 ((L'.PCon (L'.Enum,
3385 L'.PConFfi {mod = "Basis", 3354 L'.PConFfi {mod = "Basis",
3386 datatyp = "bool", 3355 datatyp = "bool",
3387 con = "False", 3356 con = "False",
3388 arg = NONE}, 3357 arg = NONE},
3407 3376
3408 val s' = " " ^ lowercaseFirst x ^ "='uw_event=event;exec(" 3377 val s' = " " ^ lowercaseFirst x ^ "='uw_event=event;exec("
3409 in 3378 in
3410 ((L'.EStrcat (s, 3379 ((L'.EStrcat (s,
3411 (L'.EStrcat ( 3380 (L'.EStrcat (
3412 (L'.EPrim (Prim.String s'), loc), 3381 strH s',
3413 (L'.EStrcat ( 3382 (L'.EStrcat (
3414 (L'.EJavaScript (L'.Attribute, e), loc), 3383 (L'.EJavaScript (L'.Attribute, e), loc),
3415 (L'.EPrim (Prim.String ");return false'"), loc)), loc)), 3384 strH ");return false'"), loc)),
3416 loc)), loc), 3385 loc)), loc),
3417 fm) 3386 fm)
3418 end 3387 end
3419 | _ => 3388 | _ =>
3420 let 3389 let
3436 3405
3437 val xp = " " ^ lowercaseFirst x ^ "=\"" 3406 val xp = " " ^ lowercaseFirst x ^ "=\""
3438 3407
3439 val (e, fm) = fooify env fm (e, t) 3408 val (e, fm) = fooify env fm (e, t)
3440 val e = case (tag, x) of 3409 val e = case (tag, x) of
3441 ("coption", "Value") => (L'.EStrcat ((L'.EPrim (Prim.String "x"), loc), e), loc) 3410 ("coption", "Value") => (L'.EStrcat (strH "x", e), loc)
3442 | _ => e 3411 | _ => e
3443 in 3412 in
3444 ((L'.EStrcat (s, 3413 ((L'.EStrcat (s,
3445 (L'.EStrcat ((L'.EPrim (Prim.String xp), loc), 3414 (L'.EStrcat (strH xp,
3446 (L'.EStrcat (e, 3415 (L'.EStrcat (e,
3447 (L'.EPrim (Prim.String "\""), 3416 strH "\""),
3448 loc)),
3449 loc)), 3417 loc)),
3450 loc)), loc), 3418 loc)), loc),
3451 fm) 3419 fm)
3452 end) 3420 end)
3453 (s, fm) attrs 3421 (s, fm) attrs
3454 in 3422 in
3455 (if tag = "coption" andalso List.all (fn ("Value", _, _) => false | _ => true) attrs then 3423 (if tag = "coption" andalso List.all (fn ("Value", _, _) => false | _ => true) attrs then
3456 (L'.EStrcat (s, 3424 (L'.EStrcat (s,
3457 (L'.EPrim (Prim.String " value=\"\""), loc)), loc) 3425 strH " value=\"\""), loc)
3458 else 3426 else
3459 s, 3427 s,
3460 fm) 3428 fm)
3461 end 3429 end
3462 3430
3465 [_, (L.CName name, _)] => 3433 [_, (L.CName name, _)] =>
3466 let 3434 let
3467 val (ts, fm) = tagStart "input" 3435 val (ts, fm) = tagStart "input"
3468 in 3436 in
3469 ((L'.EStrcat (ts, 3437 ((L'.EStrcat (ts,
3470 (L'.EPrim (Prim.String (" type=\"" ^ typ ^ "\" name=\"" ^ name ^ "\" />")), 3438 strH (" type=\"" ^ typ ^ "\" name=\"" ^ name ^ "\" />")), loc), fm)
3471 loc)), loc), fm)
3472 end 3439 end
3473 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); 3440 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
3474 raise Fail "No name passed to input tag") 3441 raise Fail "No name passed to input tag")
3475 3442
3476 fun normal (tag, extra) = 3443 fun normal (tag, extra) =
3486 3453
3487 val xml = case extraString of 3454 val xml = case extraString of
3488 NONE => xml 3455 NONE => xml
3489 | SOME extra => (L'.EStrcat (extra, xml), loc) 3456 | SOME extra => (L'.EStrcat (extra, xml), loc)
3490 in 3457 in
3491 ((L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc), 3458 ((L'.EStrcat ((L'.EStrcat (tagStart, strH ">"), loc),
3492 (L'.EStrcat (xml, 3459 (L'.EStrcat (xml,
3493 (L'.EPrim (Prim.String (String.concat ["</", tag, ">"])), 3460 strH (String.concat ["</", tag, ">"])), loc)),
3494 loc)), loc)),
3495 loc), 3461 loc),
3496 fm) 3462 fm)
3497 end 3463 end
3498 3464
3499 fun isSingleton () = 3465 fun isSingleton () =
3509 case (xml, extraString) of 3475 case (xml, extraString) of
3510 ((L.EApp ((L.ECApp ( 3476 ((L.EApp ((L.ECApp (
3511 (L.ECApp ((L.EFfi ("Basis", "cdata"), _), 3477 (L.ECApp ((L.EFfi ("Basis", "cdata"), _),
3512 _), _), 3478 _), _),
3513 _), _), 3479 _), _),
3514 (L.EPrim (Prim.String s), _)), _), NONE) => 3480 (L.EPrim (Prim.String (_, s)), _)), _), NONE) =>
3515 if CharVector.all Char.isSpace s andalso isSingleton () then 3481 if CharVector.all Char.isSpace s andalso isSingleton () then
3516 ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String " />"), loc)), loc), fm) 3482 ((L'.EStrcat (tagStart, strH " />"), loc), fm)
3517 else 3483 else
3518 normal () 3484 normal ()
3519 | _ => normal () 3485 | _ => normal ()
3520 end 3486 end
3521 3487
3522 fun setAttrs jexp = 3488 fun setAttrs jexp =
3523 let 3489 let
3524 val s = (L'.EPrim (Prim.String (String.concat ["<", tag])), loc) 3490 val s = strH (String.concat ["<", tag])
3525 3491
3526 val assgns = List.mapPartial 3492 val assgns = List.mapPartial
3527 (fn ("Source", _, _) => NONE 3493 (fn ("Source", _, _) => NONE
3528 | ("Onchange", e, _) => 3494 | ("Onchange", e, _) =>
3529 SOME (strcat [str "addOnChange(d,exec(", 3495 SOME (strcat [str "addOnChange(d,exec(",
3568 str ");"])) 3534 str ");"]))
3569 attrs 3535 attrs
3570 3536
3571 val t = (L'.TFfi ("Basis", "string"), loc) 3537 val t = (L'.TFfi ("Basis", "string"), loc)
3572 val setClass = (L'.ECase (class, 3538 val setClass = (L'.ECase (class,
3573 [((L'.PPrim (Prim.String ""), loc), 3539 [((L'.PPrim (Prim.String (Prim.Normal, "")), loc),
3574 str ""), 3540 str ""),
3575 ((L'.PVar ("x", t), loc), 3541 ((L'.PVar ("x", t), loc),
3576 (L'.EStrcat ((L'.EPrim (Prim.String "d.className=\""), loc), 3542 (L'.EStrcat (strH "d.className=\"",
3577 (L'.EStrcat ((L'.ERel 0, loc), 3543 (L'.EStrcat ((L'.ERel 0, loc),
3578 (L'.EPrim (Prim.String "\";"), loc)), loc)), 3544 strH "\";"), loc)),
3579 loc))], 3545 loc))],
3580 {disc = (L'.TOption t, loc), 3546 {disc = (L'.TOption t, loc),
3581 result = t}), loc) 3547 result = t}), loc)
3582 in 3548 in
3583 case assgns of 3549 case assgns of
3592 :: assgns) 3558 :: assgns)
3593 end 3559 end
3594 3560
3595 fun execify e = 3561 fun execify e =
3596 case e of 3562 case e of
3597 NONE => (L'.EPrim (Prim.String ""), loc) 3563 NONE => strH ""
3598 | SOME e => 3564 | SOME e =>
3599 let 3565 let
3600 val e = (L'.EApp (e, (L'.ERecord [], loc)), loc) 3566 val e = (L'.EApp (e, (L'.ERecord [], loc)), loc)
3601 in 3567 in
3602 (L'.EStrcat ((L'.EPrim (Prim.String "exec("), loc), 3568 (L'.EStrcat (strH "exec(",
3603 (L'.EStrcat ((L'.EJavaScript (L'.Attribute, e), loc), 3569 (L'.EStrcat ((L'.EJavaScript (L'.Attribute, e), loc),
3604 (L'.EPrim (Prim.String ")"), loc)), loc)), loc) 3570 strH ")"), loc)), loc)
3605 end 3571 end
3606 3572
3607 fun inTag tag' = case ctxOuter of 3573 fun inTag tag' = case ctxOuter of
3608 (L.CRecord (_, ctx), _) => 3574 (L.CRecord (_, ctx), _) =>
3609 List.exists (fn ((L.CName tag'', _), _) => tag'' = tag' 3575 List.exists (fn ((L.CName tag'', _), _) => tag'' = tag'
3641 let 3607 let
3642 in 3608 in
3643 case attrs of 3609 case attrs of
3644 [("Signal", e, _)] => 3610 [("Signal", e, _)] =>
3645 ((L'.EStrcat 3611 ((L'.EStrcat
3646 ((L'.EPrim (Prim.String ("<script type=\"text/javascript\">dyn(\"" 3612 (strH ("<script type=\"text/javascript\">dyn(\""
3647 ^ pnode () ^ "\", execD(")), loc), 3613 ^ pnode () ^ "\", execD("),
3648 (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc), 3614 (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc),
3649 (L'.EPrim (Prim.String ("))</script>")), loc)), loc)), loc), 3615 strH ("))</script>")), loc)), loc),
3650 fm) 3616 fm)
3651 | _ => raise Fail "Monoize: Bad <dyn> attributes" 3617 | _ => raise Fail "Monoize: Bad <dyn> attributes"
3652 end 3618 end
3653 3619
3654 | "active" => 3620 | "active" =>
3655 (case attrs of 3621 (case attrs of
3656 [("Code", e, _)] => 3622 [("Code", e, _)] =>
3657 ((L'.EStrcat 3623 ((L'.EStrcat
3658 ((L'.EPrim (Prim.String ("<script type=\"text/javascript\">active(execD(")), loc), 3624 (strH "<script type=\"text/javascript\">active(execD(",
3659 (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc), 3625 (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc),
3660 (L'.EPrim (Prim.String ("))</script>")), loc)), loc)), loc), 3626 strH "))</script>"), loc)), loc),
3661 fm) 3627 fm)
3662 | _ => raise Fail "Monoize: Bad <active> attributes") 3628 | _ => raise Fail "Monoize: Bad <active> attributes")
3663 3629
3664 | "script" => 3630 | "script" =>
3665 (case attrs of 3631 (case attrs of
3666 [("Code", e, _)] => 3632 [("Code", e, _)] =>
3667 ((L'.EStrcat 3633 ((L'.EStrcat
3668 ((L'.EPrim (Prim.String ("<script type=\"text/javascript\">execF(execD(")), loc), 3634 (strH "<script type=\"text/javascript\">execF(execD(",
3669 (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc), 3635 (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc),
3670 (L'.EPrim (Prim.String ("))</script>")), loc)), loc)), loc), 3636 strH "))</script>"), loc)), loc),
3671 fm) 3637 fm)
3672 | _ => raise Fail "Monoize: Bad <script> attributes") 3638 | _ => raise Fail "Monoize: Bad <script> attributes")
3673 3639
3674 | "submit" => normal ("input type=\"submit\"", NONE) 3640 | "submit" => normal ("input type=\"submit\"", NONE)
3675 | "image" => normal ("input type=\"image\"", NONE) 3641 | "image" => normal ("input type=\"image\"", NONE)
3682 NONE => 3648 NONE =>
3683 let 3649 let
3684 val (ts, fm) = tagStart "input" 3650 val (ts, fm) = tagStart "input"
3685 in 3651 in
3686 ((L'.EStrcat (ts, 3652 ((L'.EStrcat (ts,
3687 (L'.EPrim (Prim.String (" type=\"text\" name=\"" ^ name ^ "\" />")), 3653 strH (" type=\"text\" name=\"" ^ name ^ "\" />")),
3688 loc)), loc), fm) 3654 loc), fm)
3689 end 3655 end
3690 | SOME (_, src, _) => 3656 | SOME (_, src, _) =>
3691 (strcat [str "<script type=\"text/javascript\">inp(exec(", 3657 (strcat [str "<script type=\"text/javascript\">inp(exec(",
3692 (L'.EJavaScript (L'.Script, src), loc), 3658 (L'.EJavaScript (L'.Script, src), loc),
3693 str "), \"", 3659 str "), \"",
3703 let 3669 let
3704 val (ts, fm) = tagStart "textarea" 3670 val (ts, fm) = tagStart "textarea"
3705 val (xml, fm) = monoExp (env, st, fm) xml 3671 val (xml, fm) = monoExp (env, st, fm) xml
3706 in 3672 in
3707 ((L'.EStrcat ((L'.EStrcat (ts, 3673 ((L'.EStrcat ((L'.EStrcat (ts,
3708 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc), 3674 strH (" name=\"" ^ name ^ "\">")), loc),
3709 (L'.EStrcat (xml, 3675 (L'.EStrcat (xml,
3710 (L'.EPrim (Prim.String "</textarea>"), 3676 strH "</textarea>"), loc)),
3711 loc)), loc)),
3712 loc), fm) 3677 loc), fm)
3713 end 3678 end
3714 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); 3679 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
3715 raise Fail "No name passed to ltextarea tag")) 3680 raise Fail "No name passed to ltextarea tag"))
3716 3681
3726 | "radioOption" => 3691 | "radioOption" =>
3727 (case St.radioGroup st of 3692 (case St.radioGroup st of
3728 NONE => raise Fail "No name for radioGroup" 3693 NONE => raise Fail "No name for radioGroup"
3729 | SOME name => 3694 | SOME name =>
3730 normal ("input", 3695 normal ("input",
3731 SOME (L'.EPrim (Prim.String (" type=\"radio\" name=\"" ^ name ^ "\"")), loc))) 3696 SOME (strH (" type=\"radio\" name=\"" ^ name ^ "\""))))
3732 3697
3733 | "select" => 3698 | "select" =>
3734 (case targs of 3699 (case targs of
3735 [_, (L.CName name, _)] => 3700 [_, (L.CName name, _)] =>
3736 let 3701 let
3737 val (ts, fm) = tagStart "select" 3702 val (ts, fm) = tagStart "select"
3738 val (xml, fm) = monoExp (env, st, fm) xml 3703 val (xml, fm) = monoExp (env, st, fm) xml
3739 in 3704 in
3740 ((L'.EStrcat ((L'.EStrcat (ts, 3705 ((L'.EStrcat ((L'.EStrcat (ts,
3741 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), 3706 strH (" name=\"" ^ name ^ "\">")), loc),
3742 loc)), loc),
3743 (L'.EStrcat (xml, 3707 (L'.EStrcat (xml,
3744 (L'.EPrim (Prim.String "</select>"), 3708 strH "</select>"),
3745 loc)), loc)), 3709 loc)),
3746 loc), 3710 loc),
3747 fm) 3711 fm)
3748 end 3712 end
3749 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); 3713 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
3750 raise Fail "No name passed to lselect tag")) 3714 raise Fail "No name passed to lselect tag"))
3754 NONE => 3718 NONE =>
3755 let 3719 let
3756 val (ts, fm) = tagStart "input" 3720 val (ts, fm) = tagStart "input"
3757 in 3721 in
3758 ((L'.EStrcat (ts, 3722 ((L'.EStrcat (ts,
3759 (L'.EPrim (Prim.String " type=\"text\" />"), loc)), 3723 strH " type=\"text\" />"),
3760 loc), fm) 3724 loc), fm)
3761 end 3725 end
3762 | SOME (_, src, _) => 3726 | SOME (_, src, _) =>
3763 let 3727 let
3764 val sc = strcat [str "inp(exec(", 3728 val sc = strcat [str "inp(exec(",
3777 NONE => 3741 NONE =>
3778 let 3742 let
3779 val (ts, fm) = tagStart "input type=\"checkbox\"" 3743 val (ts, fm) = tagStart "input type=\"checkbox\""
3780 in 3744 in
3781 ((L'.EStrcat (ts, 3745 ((L'.EStrcat (ts,
3782 (L'.EPrim (Prim.String " />"), loc)), 3746 strH " />"),
3783 loc), fm) 3747 loc), fm)
3784 end 3748 end
3785 | SOME (_, src, _) => 3749 | SOME (_, src, _) =>
3786 let 3750 let
3787 val sc = strcat [str "chk(exec(", 3751 val sc = strcat [str "chk(exec(",
3832 NONE => 3796 NONE =>
3833 let 3797 let
3834 val (ts, fm) = tagStart "textarea" 3798 val (ts, fm) = tagStart "textarea"
3835 in 3799 in
3836 ((L'.EStrcat (ts, 3800 ((L'.EStrcat (ts,
3837 (L'.EPrim (Prim.String " />"), loc)), 3801 strH " />"),
3838 loc), fm) 3802 loc), fm)
3839 end 3803 end
3840 | SOME (_, src, _) => 3804 | SOME (_, src, _) =>
3841 let 3805 let
3842 val sc = strcat [str "tbx(exec(", 3806 val sc = strcat [str "tbx(exec(",
3955 | _ => Error) 3919 | _ => Error)
3956 | _ => findSubmit xml) 3920 | _ => findSubmit xml)
3957 | _ => NotFound 3921 | _ => NotFound
3958 3922
3959 val (func, action, fm) = case findSubmit xml of 3923 val (func, action, fm) = case findSubmit xml of
3960 NotFound => (0, (L'.EPrim (Prim.String ""), loc), fm) 3924 NotFound => (0, strH "", fm)
3961 | Error => raise Fail "Not ready for multi-submit lforms yet" 3925 | Error => raise Fail "Not ready for multi-submit lforms yet"
3962 | Found (action, actionT) => 3926 | Found (action, actionT) =>
3963 let 3927 let
3964 val func = case #1 action of 3928 val func = case #1 action of
3965 L.EClosure (n, _) => n 3929 L.EClosure (n, _) => n
3967 val actionT = monoType env actionT 3931 val actionT = monoType env actionT
3968 val (action, fm) = monoExp (env, st, fm) action 3932 val (action, fm) = monoExp (env, st, fm) action
3969 val (action, fm) = urlifyExp env fm (action, actionT) 3933 val (action, fm) = urlifyExp env fm (action, actionT)
3970 in 3934 in
3971 (func, 3935 (func,
3972 (L'.EStrcat ((L'.EPrim (Prim.String " action=\""), loc), 3936 (L'.EStrcat (strH " action=\"",
3973 (L'.EStrcat (action, 3937 (L'.EStrcat (action,
3974 (L'.EPrim (Prim.String "\""), loc)), loc)), loc), 3938 strH "\""), loc)), loc),
3975 fm) 3939 fm)
3976 end 3940 end
3977 3941
3978 val hasUpload = CoreUtil.Exp.exists {kind = fn _ => false, 3942 val hasUpload = CoreUtil.Exp.exists {kind = fn _ => false,
3979 con = fn _ => false, 3943 con = fn _ => false,
4008 "Sig" 3972 "Sig"
4009 end 3973 end
4010 3974
4011 val sigName = getSigName () 3975 val sigName = getSigName ()
4012 val sigSet = (L'.EFfiApp ("Basis", "sigString", [((L'.ERecord [], loc), (L'.TRecord [], loc))]), loc) 3976 val sigSet = (L'.EFfiApp ("Basis", "sigString", [((L'.ERecord [], loc), (L'.TRecord [], loc))]), loc)
4013 val sigSet = (L'.EStrcat ((L'.EPrim (Prim.String ("<input type=\"hidden\" name=\"" 3977 val sigSet = (L'.EStrcat (strH ("<input type=\"hidden\" name=\""
4014 ^ sigName 3978 ^ sigName
4015 ^ "\" value=\"")), loc), 3979 ^ "\" value=\""),
4016 sigSet), loc) 3980 sigSet), loc)
4017 val sigSet = (L'.EStrcat (sigSet, 3981 val sigSet = (L'.EStrcat (sigSet,
4018 (L'.EPrim (Prim.String "\" />"), loc)), loc) 3982 strH "\" />"), loc)
4019 in 3983 in
4020 (L'.EStrcat (sigSet, xml), loc) 3984 (L'.EStrcat (sigSet, xml), loc)
4021 end 3985 end
4022 else 3986 else
4023 xml 3987 xml
4024 3988
4025 val action = if hasUpload then 3989 val action = if hasUpload then
4026 (L'.EStrcat (action, 3990 (L'.EStrcat (action,
4027 (L'.EPrim (Prim.String " enctype=\"multipart/form-data\""), loc)), loc) 3991 strH " enctype=\"multipart/form-data\""), loc)
4028 else 3992 else
4029 action 3993 action
4030 3994
4031 val stt = (L'.TFfi ("Basis", "string"), loc) 3995 val stt = (L'.TFfi ("Basis", "string"), loc)
4032 val (class, fm) = monoExp (env, st, fm) class 3996 val (class, fm) = monoExp (env, st, fm) class
4033 val action = (L'.EStrcat (action, 3997 val action = (L'.EStrcat (action,
4034 (L'.ECase (class, 3998 (L'.ECase (class,
4035 [((L'.PNone stt, loc), 3999 [((L'.PNone stt, loc),
4036 (L'.EPrim (Prim.String ""), loc)), 4000 strH ""),
4037 ((L'.PSome (stt, (L'.PVar ("x", stt), loc)), loc), 4001 ((L'.PSome (stt, (L'.PVar ("x", stt), loc)), loc),
4038 (L'.EStrcat ((L'.EPrim (Prim.String " class=\""), loc), 4002 (L'.EStrcat (strH " class=\"",
4039 (L'.EStrcat ((L'.ERel 0, loc), 4003 (L'.EStrcat ((L'.ERel 0, loc),
4040 (L'.EPrim (Prim.String "\""), loc)), loc)), loc))], 4004 strH "\""), loc)), loc))],
4041 {disc = (L'.TOption stt, loc), 4005 {disc = (L'.TOption stt, loc),
4042 result = stt}), loc)), loc) 4006 result = stt}), loc)), loc)
4043 in 4007 in
4044 ((L'.EStrcat ((L'.EStrcat ((L'.EPrim (Prim.String "<form method=\"post\""), loc), 4008 ((L'.EStrcat ((L'.EStrcat (strH "<form method=\"post\"",
4045 (L'.EStrcat (action, 4009 (L'.EStrcat (action,
4046 (L'.EPrim (Prim.String ">"), loc)), loc)), loc), 4010 strH ">"), loc)), loc),
4047 (L'.EStrcat (xml, 4011 (L'.EStrcat (xml,
4048 (L'.EPrim (Prim.String "</form>"), loc)), loc)), loc), 4012 strH "</form>"), loc)), loc),
4049 fm) 4013 fm)
4050 end 4014 end
4051 4015
4052 | L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp ( 4016 | L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp (
4053 (L.EFfi ("Basis", "subform"), _), _), _), _), 4017 (L.EFfi ("Basis", "subform"), _), _), _), _),
4054 _), _), _), (L.CName nm, loc)) => 4018 _), _), _), (L.CName nm, loc)) =>
4055 let 4019 let
4056 val s = (L'.TFfi ("Basis", "string"), loc) 4020 val s = (L'.TFfi ("Basis", "string"), loc)
4057 in 4021 in
4058 ((L'.EAbs ("xml", s, s, 4022 ((L'.EAbs ("xml", s, s,
4059 strcat [(L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".b\" value=\"" 4023 strcat [strH ("<input type=\"hidden\" name=\".b\" value=\""
4060 ^ nm ^ "\" />")), loc), 4024 ^ nm ^ "\" />"),
4061 (L'.ERel 0, loc), 4025 (L'.ERel 0, loc),
4062 (L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".e\" value=\"1\" />")), loc)]), 4026 strH ("<input type=\"hidden\" name=\".e\" value=\"1\" />")]),
4063 loc), 4027 loc),
4064 fm) 4028 fm)
4065 end 4029 end
4066 4030
4067 | L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp ( 4031 | L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp (
4069 _), _), _), (L.CName nm, loc)) => 4033 _), _), _), (L.CName nm, loc)) =>
4070 let 4034 let
4071 val s = (L'.TFfi ("Basis", "string"), loc) 4035 val s = (L'.TFfi ("Basis", "string"), loc)
4072 in 4036 in
4073 ((L'.EAbs ("xml", s, s, 4037 ((L'.EAbs ("xml", s, s,
4074 strcat [(L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".s\" value=\"" 4038 strcat [strH ("<input type=\"hidden\" name=\".s\" value=\""
4075 ^ nm ^ "\" />")), loc), 4039 ^ nm ^ "\" />"),
4076 (L'.ERel 0, loc), 4040 (L'.ERel 0, loc),
4077 (L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".e\" value=\"1\" />")), loc)]), 4041 strH ("<input type=\"hidden\" name=\".e\" value=\"1\" />")]),
4078 loc), 4042 loc),
4079 fm) 4043 fm)
4080 end 4044 end
4081 4045
4082 | L.ECApp ((L.ECApp ( 4046 | L.ECApp ((L.ECApp (
4083 (L.EFfi ("Basis", "entry"), _), _), _), _) => 4047 (L.EFfi ("Basis", "entry"), _), _), _), _) =>
4084 let 4048 let
4085 val s = (L'.TFfi ("Basis", "string"), loc) 4049 val s = (L'.TFfi ("Basis", "string"), loc)
4086 in 4050 in
4087 ((L'.EAbs ("xml", s, s, 4051 ((L'.EAbs ("xml", s, s,
4088 strcat [(L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".i\" value=\"1\" />")), loc), 4052 strcat [strH ("<input type=\"hidden\" name=\".i\" value=\"1\" />"),
4089 (L'.ERel 0, loc), 4053 (L'.ERel 0, loc),
4090 (L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".e\" value=\"1\" />")), loc)]), 4054 strH ("<input type=\"hidden\" name=\".e\" value=\"1\" />")]),
4091 loc), 4055 loc),
4092 fm) 4056 fm)
4093 end 4057 end
4094 4058
4095 | L.EApp ((L.ECApp ( 4059 | L.EApp ((L.ECApp (
4173 | L.EFfiApp ("Basis", "url", [(e, _)]) => 4137 | L.EFfiApp ("Basis", "url", [(e, _)]) =>
4174 let 4138 let
4175 val (e, fm) = monoExp (env, st, fm) e 4139 val (e, fm) = monoExp (env, st, fm) e
4176 val (e, fm) = urlifyExp env fm (e, dummyTyp) 4140 val (e, fm) = urlifyExp env fm (e, dummyTyp)
4177 in 4141 in
4178 ((L'.EStrcat ((L'.EPrim (Prim.String (Settings.getUrlPrePrefix ())), loc), e), loc), fm) 4142 ((L'.EStrcat (str (Settings.getUrlPrePrefix ()), e), loc), fm)
4179 end 4143 end
4180 4144
4181 | L.EApp (e1, e2) => 4145 | L.EApp (e1, e2) =>
4182 let 4146 let
4183 val (e1, fm) = monoExp (env, st, fm) e1 4147 val (e1, fm) = monoExp (env, st, fm) e1
4294 | (e :: es, (L.TFun (dom, ran), _)) => 4258 | (e :: es, (L.TFun (dom, ran), _)) =>
4295 let 4259 let
4296 val (e, fm) = urlifyExp env fm (e, monoType env dom) 4260 val (e, fm) = urlifyExp env fm (e, monoType env dom)
4297 in 4261 in
4298 encodeArgs (es, ran, e 4262 encodeArgs (es, ran, e
4299 :: (L'.EPrim (Prim.String "/"), loc) 4263 :: str "/"
4300 :: acc, fm) 4264 :: acc, fm)
4301 end 4265 end
4302 | _ => raise Fail "Monoize: Not enough arguments visible in RPC function type" 4266 | _ => raise Fail "Monoize: Not enough arguments visible in RPC function type"
4303 4267
4304 val (call, fm) = encodeArgs (es, ft, [], fm) 4268 val (call, fm) = encodeArgs (es, ft, [], fm)
4305 val call = foldl (fn (e, call) => (L'.EStrcat (call, e), loc)) 4269 val call = foldl (fn (e, call) => (L'.EStrcat (call, e), loc))
4306 (L'.EPrim (Prim.String name), loc) call 4270 (str name) call
4307 4271
4308 val unit = (L'.TRecord [], loc) 4272 val unit = (L'.TRecord [], loc)
4309 4273
4310 val eff = if IS.member (!readCookie, n) then 4274 val eff = if IS.member (!readCookie, n) then
4311 L'.ReadCookieWrite 4275 L'.ReadCookieWrite
4327 let 4291 let
4328 fun poly () = 4292 fun poly () =
4329 (E.errorAt loc "Unsupported declaration"; 4293 (E.errorAt loc "Unsupported declaration";
4330 Print.eprefaces' [("Declaration", CorePrint.p_decl env all)]; 4294 Print.eprefaces' [("Declaration", CorePrint.p_decl env all)];
4331 NONE) 4295 NONE)
4296
4297 fun str s = (L'.EPrim (Prim.String (Prim.Normal, s)), loc)
4298 fun strH s = (L'.EPrim (Prim.String (Prim.Html, s)), loc)
4332 in 4299 in
4333 case d of 4300 case d of
4334 L.DCon _ => NONE 4301 L.DCon _ => NONE
4335 | L.DDatatype [("list", n, [_], [("Nil", _, NONE), 4302 | L.DDatatype [("list", n, [_], [("Nil", _, NONE),
4336 ("Cons", _, SOME (L.TRecord (L.CRecord (_, 4303 ("Cons", _, SOME (L.TRecord (L.CRecord (_,
4424 | L.DTable (x, n, (L.CRecord (_, xts), _), s, pe, _, ce, _) => 4391 | L.DTable (x, n, (L.CRecord (_, xts), _), s, pe, _, ce, _) =>
4425 let 4392 let
4426 val t = (L.CFfi ("Basis", "string"), loc) 4393 val t = (L.CFfi ("Basis", "string"), loc)
4427 val t' = (L'.TFfi ("Basis", "string"), loc) 4394 val t' = (L'.TFfi ("Basis", "string"), loc)
4428 val s = Settings.mangleSqlTable s 4395 val s = Settings.mangleSqlTable s
4429 val e_name = (L'.EPrim (Prim.String s), loc) 4396 val e_name = str s
4430 4397
4431 val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts 4398 val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
4432 4399
4433 val (pe, fm) = monoExp (env, St.empty, fm) pe 4400 val (pe, fm) = monoExp (env, St.empty, fm) pe
4434 val (ce, fm) = monoExp (env, St.empty, fm) ce 4401 val (ce, fm) = monoExp (env, St.empty, fm) ce
4442 | L.DView (x, n, s, e, (L.CRecord (_, xts), _)) => 4409 | L.DView (x, n, s, e, (L.CRecord (_, xts), _)) =>
4443 let 4410 let
4444 val t = (L.CFfi ("Basis", "string"), loc) 4411 val t = (L.CFfi ("Basis", "string"), loc)
4445 val t' = (L'.TFfi ("Basis", "string"), loc) 4412 val t' = (L'.TFfi ("Basis", "string"), loc)
4446 val s = Settings.mangleSqlTable s 4413 val s = Settings.mangleSqlTable s
4447 val e_name = (L'.EPrim (Prim.String s), loc) 4414 val e_name = str s
4448 4415
4449 val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts 4416 val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
4450 4417
4451 val (e, fm) = monoExp (env, St.empty, fm) e 4418 val (e, fm) = monoExp (env, St.empty, fm) e
4452 val e = (L'.EFfiApp ("Basis", "viewify", [(e, t')]), loc) 4419 val e = (L'.EFfiApp ("Basis", "viewify", [(e, t')]), loc)
4460 | L.DSequence (x, n, s) => 4427 | L.DSequence (x, n, s) =>
4461 let 4428 let
4462 val t = (L.CFfi ("Basis", "string"), loc) 4429 val t = (L.CFfi ("Basis", "string"), loc)
4463 val t' = (L'.TFfi ("Basis", "string"), loc) 4430 val t' = (L'.TFfi ("Basis", "string"), loc)
4464 val s = Settings.mangleSql s 4431 val s = Settings.mangleSql s
4465 val e = (L'.EPrim (Prim.String s), loc) 4432 val e = str s
4466 in 4433 in
4467 SOME (Env.pushENamed env x n t NONE s, 4434 SOME (Env.pushENamed env x n t NONE s,
4468 fm, 4435 fm,
4469 [(L'.DSequence s, loc), 4436 [(L'.DSequence s, loc),
4470 (L'.DVal (x, n, t', e, s), loc)]) 4437 (L'.DVal (x, n, t', e, s), loc)])
4472 | L.DDatabase _ => NONE 4439 | L.DDatabase _ => NONE
4473 | L.DCookie (x, n, t, s) => 4440 | L.DCookie (x, n, t, s) =>
4474 let 4441 let
4475 val t = (L.CFfi ("Basis", "string"), loc) 4442 val t = (L.CFfi ("Basis", "string"), loc)
4476 val t' = (L'.TFfi ("Basis", "string"), loc) 4443 val t' = (L'.TFfi ("Basis", "string"), loc)
4477 val e = (L'.EPrim (Prim.String s), loc) 4444 val e = str s
4478 in 4445 in
4479 SOME (Env.pushENamed env x n t NONE s, 4446 SOME (Env.pushENamed env x n t NONE s,
4480 fm, 4447 fm,
4481 [(L'.DCookie s, loc), 4448 [(L'.DCookie s, loc),
4482 (L'.DVal (x, n, t', e, s), loc)]) 4449 (L'.DVal (x, n, t', e, s), loc)])
4483 end 4450 end
4484 | L.DStyle (x, n, s) => 4451 | L.DStyle (x, n, s) =>
4485 let 4452 let
4486 val t = (L.CFfi ("Basis", "string"), loc) 4453 val t = (L.CFfi ("Basis", "string"), loc)
4487 val t' = (L'.TFfi ("Basis", "string"), loc) 4454 val t' = (L'.TFfi ("Basis", "string"), loc)
4488 val e = (L'.EPrim (Prim.String s), loc) 4455 val e = strH s
4489 in 4456 in
4490 SOME (Env.pushENamed env x n t NONE s, 4457 SOME (Env.pushENamed env x n t NONE s,
4491 fm, 4458 fm,
4492 [(L'.DStyle s, loc), 4459 [(L'.DStyle s, loc),
4493 (L'.DVal (x, n, t', e, s), loc)]) 4460 (L'.DVal (x, n, t', e, s), loc)])
4579 4546
4580 val loc = E.dummySpan 4547 val loc = E.dummySpan
4581 val client = (L'.TFfi ("Basis", "client"), loc) 4548 val client = (L'.TFfi ("Basis", "client"), loc)
4582 val unit = (L'.TRecord [], loc) 4549 val unit = (L'.TRecord [], loc)
4583 4550
4551 fun str s = (L'.EPrim (Prim.String (Prim.Normal, s)), loc)
4552 fun strH s = (L'.EPrim (Prim.String (Prim.Html, s)), loc)
4553
4584 fun calcClientish xts = 4554 fun calcClientish xts =
4585 foldl (fn ((x : L.con, t : L.con), st as (nullable, notNullable)) => 4555 foldl (fn ((x : L.con, t : L.con), st as (nullable, notNullable)) =>
4586 case #1 x of 4556 case #1 x of
4587 L.CName x => 4557 L.CName x =>
4588 (case #1 t of 4558 (case #1 t of
4608 L.CRecord (_, xts) => 4578 L.CRecord (_, xts) =>
4609 let 4579 let
4610 val (nullable, notNullable) = calcClientish xts 4580 val (nullable, notNullable) = calcClientish xts
4611 4581
4612 fun cond (x, v) = 4582 fun cond (x, v) =
4613 (L'.EStrcat ((L'.EPrim (Prim.String (Settings.mangleSql x 4583 (L'.EStrcat (str (Settings.mangleSql x
4614 ^ (case v of 4584 ^ (case v of
4615 Client => "" 4585 Client => ""
4616 | Channel => " >> 32") 4586 | Channel => " >> 32")
4617 ^ " = ")), loc), 4587 ^ " = "),
4618 target), loc) 4588 target), loc)
4619 4589
4620 val e = 4590 val e =
4621 foldl (fn ((x, v), e) => 4591 foldl (fn ((x, v), e) =>
4622 (L'.ESeq ( 4592 (L'.ESeq (
4623 (L'.EDml ((L'.EStrcat ( 4593 (L'.EDml ((L'.EStrcat (
4624 (L'.EPrim (Prim.String ("UPDATE " 4594 str ("UPDATE "
4625 ^ Settings.mangleSql tab 4595 ^ Settings.mangleSql tab
4626 ^ " SET " 4596 ^ " SET "
4627 ^ Settings.mangleSql x 4597 ^ Settings.mangleSql x
4628 ^ " = NULL WHERE ")), loc), 4598 ^ " = NULL WHERE "),
4629 cond (x, v)), loc), L'.Error), loc), 4599 cond (x, v)), loc), L'.Error), loc),
4630 e), loc)) 4600 e), loc))
4631 e nullable 4601 e nullable
4632 4602
4633 val e = 4603 val e =
4636 | eb :: ebs => 4606 | eb :: ebs =>
4637 (L'.ESeq ( 4607 (L'.ESeq (
4638 (L'.EDml (foldl 4608 (L'.EDml (foldl
4639 (fn (eb, s) => 4609 (fn (eb, s) =>
4640 (L'.EStrcat (s, 4610 (L'.EStrcat (s,
4641 (L'.EStrcat ((L'.EPrim (Prim.String " OR "), 4611 (L'.EStrcat (str " OR ",
4642 loc),
4643 cond eb), loc)), loc)) 4612 cond eb), loc)), loc))
4644 (L'.EStrcat ((L'.EPrim (Prim.String ("DELETE FROM " 4613 (L'.EStrcat (str ("DELETE FROM "
4645 ^ Settings.mangleSql tab 4614 ^ Settings.mangleSql tab
4646 ^ " WHERE ")), loc), 4615 ^ " WHERE "),
4647 cond eb), loc) 4616 cond eb), loc)
4648 ebs, L'.Error), loc), 4617 ebs, L'.Error), loc),
4649 e), loc) 4618 e), loc)
4650 in 4619 in
4651 e 4620 e
4671 val e = 4640 val e =
4672 case nullable of 4641 case nullable of
4673 [] => e 4642 [] => e
4674 | (x, _) :: ebs => 4643 | (x, _) :: ebs =>
4675 (L'.ESeq ( 4644 (L'.ESeq (
4676 (L'.EDml ((L'.EPrim (Prim.String 4645 (L'.EDml (str
4677 (foldl (fn ((x, _), s) => 4646 (foldl (fn ((x, _), s) =>
4678 s ^ ", " ^ Settings.mangleSql x ^ " = NULL") 4647 s ^ ", " ^ Settings.mangleSql x ^ " = NULL")
4679 ("UPDATE uw_" 4648 ("UPDATE uw_"
4680 ^ tab 4649 ^ tab
4681 ^ " SET " 4650 ^ " SET "
4682 ^ Settings.mangleSql x 4651 ^ Settings.mangleSql x
4683 ^ " = NULL") 4652 ^ " = NULL")
4684 ebs)), loc), L'.Error), loc), 4653 ebs), L'.Error), loc),
4685 e), loc) 4654 e), loc)
4686 4655
4687 val e = 4656 val e =
4688 case notNullable of 4657 case notNullable of
4689 [] => e 4658 [] => e
4690 | eb :: ebs => 4659 | eb :: ebs =>
4691 (L'.ESeq ( 4660 (L'.ESeq (
4692 (L'.EDml ((L'.EPrim (Prim.String ("DELETE FROM " 4661 (L'.EDml (str ("DELETE FROM "
4693 ^ Settings.mangleSql tab)), loc), L'.Error), loc), 4662 ^ Settings.mangleSql tab), L'.Error), loc),
4694 e), loc) 4663 e), loc)
4695 in 4664 in
4696 e 4665 e
4697 end 4666 end
4698 | _ => e 4667 | _ => e