Mercurial > urweb

comparison src/monoize.sml @ 1953:0992323fa264

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
noMangleSql .urp directive
author Adam Chlipala <adam@chlipala.net>
date Sat, 04 Jan 2014 19:02:14 -0500
parents 619191c71abb
children 67a6ba016a78
comparison
equal deleted inserted replaced
1952:cf7f7e51b0a2 1953:0992323fa264
1622 in 1622 in
1623 ((L'.EAbs ("_", witnesses, (L'.TFfi ("Basis", "string"), loc), 1623 ((L'.EAbs ("_", witnesses, (L'.TFfi ("Basis", "string"), loc),
1624 (L'.EPrim (Prim.String 1624 (L'.EPrim (Prim.String
1625 (String.concatWith ", " 1625 (String.concatWith ", "
1626 (map (fn (x, _) => 1626 (map (fn (x, _) =>
1627 "uw_" ^ monoNameLc env x 1627 Settings.mangleSql (monoNameLc env x)
1628 ^ (if #textKeysNeedLengths (Settings.currentDbms ()) 1628 ^ (if #textKeysNeedLengths (Settings.currentDbms ())
1629 andalso isBlobby t then 1629 andalso isBlobby t then
1630 "(767)" 1630 "(767)"
1631 else 1631 else
1632 "")) unique))), 1632 "")) unique))),
1666 let 1666 let
1667 val unique = (nm, t) :: unique 1667 val unique = (nm, t) :: unique
1668 in 1668 in
1669 ((L'.EPrim (Prim.String ("UNIQUE (" 1669 ((L'.EPrim (Prim.String ("UNIQUE ("
1670 ^ String.concatWith ", " 1670 ^ String.concatWith ", "
1671 (map (fn (x, t) => "uw_" ^ monoNameLc env x 1671 (map (fn (x, t) => Settings.mangleSql (monoNameLc env x)
1672 ^ (if #textKeysNeedLengths (Settings.currentDbms ()) 1672 ^ (if #textKeysNeedLengths (Settings.currentDbms ())
1673 andalso isBlobby t then 1673 andalso isBlobby t then
1674 "(767)" 1674 "(767)"
1675 else 1675 else
1676 "")) unique) 1676 "")) unique)
1712 in 1712 in
1713 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (mat, mat), loc), 1713 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (mat, mat), loc),
1714 (L'.EAbs ("m", mat, mat, 1714 (L'.EAbs ("m", mat, mat,
1715 (L'.ECase ((L'.EField ((L'.ERel 0, loc), "1"), loc), 1715 (L'.ECase ((L'.EField ((L'.ERel 0, loc), "1"), loc),
1716 [((L'.PPrim (Prim.String ""), loc), 1716 [((L'.PPrim (Prim.String ""), loc),
1717 (L'.ERecord [("1", (L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm1)), 1717 (L'.ERecord [("1", (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm1))),
1718 loc), string), 1718 loc), string),
1719 ("2", (L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm2)), 1719 ("2", (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm2))),
1720 loc), string)], loc)), 1720 loc), string)], loc)),
1721 ((L'.PWild, loc), 1721 ((L'.PWild, loc),
1722 (L'.ERecord [("1", (L'.EStrcat ( 1722 (L'.ERecord [("1", (L'.EStrcat (
1723 (L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm1 1723 (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm1)
1724 ^ ", ")), 1724 ^ ", ")),
1725 loc), 1725 loc),
1726 (L'.EField ((L'.ERel 0, loc), "1"), loc)), 1726 (L'.EField ((L'.ERel 0, loc), "1"), loc)),
1727 loc), string), 1727 loc), string),
1728 ("2", (L'.EStrcat ( 1728 ("2", (L'.EStrcat (
1729 (L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm2 1729 (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm2)
1730 ^ ", ")), loc), 1730 ^ ", ")), loc),
1731 (L'.EField ((L'.ERel 0, loc), "2"), loc)), 1731 (L'.EField ((L'.ERel 0, loc), "2"), loc)),
1732 loc), string)], 1732 loc), string)],
1733 loc))], 1733 loc))],
1734 {disc = string, 1734 {disc = string,
1855 ((L'.EAbs ("tab", s, (L'.TFun (rt, s), loc), 1855 ((L'.EAbs ("tab", s, (L'.TFun (rt, s), loc),
1856 (L'.EAbs ("fs", rt, s, 1856 (L'.EAbs ("fs", rt, s,
1857 strcat [sc "INSERT INTO ", 1857 strcat [sc "INSERT INTO ",
1858 (L'.ERel 1, loc), 1858 (L'.ERel 1, loc),
1859 sc " (", 1859 sc " (",
1860 strcatComma (map (fn (x, _) => sc ("uw_" ^ x)) fields), 1860 strcatComma (map (fn (x, _) => sc (Settings.mangleSql x)) fields),
1861 sc ") VALUES (", 1861 sc ") VALUES (",
1862 strcatComma (map (fn (x, _) => 1862 strcatComma (map (fn (x, _) =>
1863 (L'.EField ((L'.ERel 0, loc), 1863 (L'.EField ((L'.ERel 0, loc),
1864 x), loc)) fields), 1864 x), loc)) fields),
1865 sc ")"]), loc)), loc), 1865 sc ")"]), loc)), loc),
1882 if #supportsUpdateAs (Settings.currentDbms ()) then 1882 if #supportsUpdateAs (Settings.currentDbms ()) then
1883 strcat [sc "UPDATE ", 1883 strcat [sc "UPDATE ",
1884 (L'.ERel 1, loc), 1884 (L'.ERel 1, loc),
1885 sc " AS T_T SET ", 1885 sc " AS T_T SET ",
1886 strcatComma (map (fn (x, _) => 1886 strcatComma (map (fn (x, _) =>
1887 strcat [sc ("uw_" ^ x 1887 strcat [sc (Settings.mangleSql x
1888 ^ " = "), 1888 ^ " = "),
1889 (L'.EField 1889 (L'.EField
1890 ((L'.ERel 2, 1890 ((L'.ERel 2,
1891 loc), 1891 loc),
1892 x), loc)]) 1892 x), loc)])
1896 else 1896 else
1897 strcat [sc "UPDATE ", 1897 strcat [sc "UPDATE ",
1898 (L'.ERel 1, loc), 1898 (L'.ERel 1, loc),
1899 sc " SET ", 1899 sc " SET ",
1900 strcatComma (map (fn (x, _) => 1900 strcatComma (map (fn (x, _) =>
1901 strcat [sc ("uw_" ^ x 1901 strcat [sc (Settings.mangleSql x
1902 ^ " = "), 1902 ^ " = "),
1903 (L'.EFfiApp ("Basis", "unAs", 1903 (L'.EFfiApp ("Basis", "unAs",
1904 [((L'.EField 1904 [((L'.EField
1905 ((L'.ERel 2, 1905 ((L'.ERel 2,
1906 loc), 1906 loc),
2088 (L'.EPrim (Prim.String ""), loc))], 2088 (L'.EPrim (Prim.String ""), loc))],
2089 {disc = b, result = s}), loc), 2089 {disc = b, result = s}), loc),
2090 strcatComma (map (fn (x, t) => 2090 strcatComma (map (fn (x, t) =>
2091 strcat [ 2091 strcat [
2092 (L'.EField (gf "SelectExps", x), loc), 2092 (L'.EField (gf "SelectExps", x), loc),
2093 sc (" AS uw_" ^ x) 2093 sc (" AS " ^ Settings.mangleSql x)
2094 ]) sexps 2094 ]) sexps
2095 @ map (fn (x, xts) => 2095 @ map (fn (x, xts) =>
2096 strcatComma 2096 strcatComma
2097 (map (fn (x', _) => 2097 (map (fn (x', _) =>
2098 sc ("T_" ^ x 2098 sc ("T_" ^ x
2099 ^ ".uw_" 2099 ^ "."
2100 ^ x')) 2100 ^ Settings.mangleSql x'))
2101 xts)) stables), 2101 xts)) stables),
2102 (L'.ECase (gf "From", 2102 (L'.ECase (gf "From",
2103 [((L'.PPrim (Prim.String ""), loc), 2103 [((L'.PPrim (Prim.String ""), loc),
2104 sc ""), 2104 sc ""),
2105 ((L'.PVar ("x", s), loc), 2105 ((L'.PVar ("x", s), loc),
2129 sc " GROUP BY ", 2129 sc " GROUP BY ",
2130 strcatComma (map (fn (x, xts) => 2130 strcatComma (map (fn (x, xts) =>
2131 strcatComma 2131 strcatComma
2132 (map (fn (x', _) => 2132 (map (fn (x', _) =>
2133 sc ("T_" ^ x 2133 sc ("T_" ^ x
2134 ^ ".uw_" 2134 ^ ""
2135 ^ x')) 2135 ^ Settings.mangleSql x'))
2136 xts)) grouped) 2136 xts)) grouped)
2137 ], 2137 ],
2138 2138
2139 (L'.ECase (gf "Having", 2139 (L'.ECase (gf "Having",
2140 [((L'.PPrim (Prim.String 2140 [((L'.PPrim (Prim.String
2624 _), _), 2624 _), _),
2625 _), _), 2625 _), _),
2626 _), _), 2626 _), _),
2627 _), _), 2627 _), _),
2628 (L.CName tab, _)), _), 2628 (L.CName tab, _)), _),
2629 (L.CName field, _)) => ((L'.EPrim (Prim.String ("T_" ^ tab ^ ".uw_" ^ lowercaseFirst field)), loc), fm) 2629 (L.CName field, _)) => ((L'.EPrim (Prim.String ("T_" ^ tab ^ "." ^ Settings.mangleSql (lowercaseFirst field))), loc), fm)
2630 2630
2631 | L.ECApp ( 2631 | L.ECApp (
2632 (L.ECApp ( 2632 (L.ECApp (
2633 (L.ECApp ( 2633 (L.ECApp (
2634 (L.ECApp ( 2634 (L.ECApp (
2636 (L.EFfi ("Basis", "sql_exp"), _), 2636 (L.EFfi ("Basis", "sql_exp"), _),
2637 _), _), 2637 _), _),
2638 _), _), 2638 _), _),
2639 _), _), 2639 _), _),
2640 _), _), 2640 _), _),
2641 (L.CName nm, _)) => ((L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm)), loc), fm) 2641 (L.CName nm, _)) => ((L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm))), loc), fm)
2642 2642
2643 | L.ECApp ( 2643 | L.ECApp (
2644 (L.ECApp ( 2644 (L.ECApp (
2645 (L.ECApp ( 2645 (L.ECApp (
2646 (L.ECApp ( 2646 (L.ECApp (
4366 end 4366 end
4367 | L.DTable (x, n, (L.CRecord (_, xts), _), s, pe, _, ce, _) => 4367 | L.DTable (x, n, (L.CRecord (_, xts), _), s, pe, _, ce, _) =>
4368 let 4368 let
4369 val t = (L.CFfi ("Basis", "string"), loc) 4369 val t = (L.CFfi ("Basis", "string"), loc)
4370 val t' = (L'.TFfi ("Basis", "string"), loc) 4370 val t' = (L'.TFfi ("Basis", "string"), loc)
4371 val s = "uw_" ^ s 4371 val s = Settings.mangleSqlTable s
4372 val e_name = (L'.EPrim (Prim.String s), loc) 4372 val e_name = (L'.EPrim (Prim.String s), loc)
4373 4373
4374 val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts 4374 val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
4375 4375
4376 val (pe, fm) = monoExp (env, St.empty, fm) pe 4376 val (pe, fm) = monoExp (env, St.empty, fm) pe
4384 | L.DTable _ => poly () 4384 | L.DTable _ => poly ()
4385 | L.DView (x, n, s, e, (L.CRecord (_, xts), _)) => 4385 | L.DView (x, n, s, e, (L.CRecord (_, xts), _)) =>
4386 let 4386 let
4387 val t = (L.CFfi ("Basis", "string"), loc) 4387 val t = (L.CFfi ("Basis", "string"), loc)
4388 val t' = (L'.TFfi ("Basis", "string"), loc) 4388 val t' = (L'.TFfi ("Basis", "string"), loc)
4389 val s = "uw_" ^ s 4389 val s = Settings.mangleSqlTable s
4390 val e_name = (L'.EPrim (Prim.String s), loc) 4390 val e_name = (L'.EPrim (Prim.String s), loc)
4391 4391
4392 val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts 4392 val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
4393 4393
4394 val (e, fm) = monoExp (env, St.empty, fm) e 4394 val (e, fm) = monoExp (env, St.empty, fm) e
4402 | L.DView _ => poly () 4402 | L.DView _ => poly ()
4403 | L.DSequence (x, n, s) => 4403 | L.DSequence (x, n, s) =>
4404 let 4404 let
4405 val t = (L.CFfi ("Basis", "string"), loc) 4405 val t = (L.CFfi ("Basis", "string"), loc)
4406 val t' = (L'.TFfi ("Basis", "string"), loc) 4406 val t' = (L'.TFfi ("Basis", "string"), loc)
4407 val s = "uw_" ^ s 4407 val s = Settings.mangleSql s
4408 val e = (L'.EPrim (Prim.String s), loc) 4408 val e = (L'.EPrim (Prim.String s), loc)
4409 in 4409 in
4410 SOME (Env.pushENamed env x n t NONE s, 4410 SOME (Env.pushENamed env x n t NONE s,
4411 fm, 4411 fm,
4412 [(L'.DSequence s, loc), 4412 [(L'.DSequence s, loc),
4551 L.CRecord (_, xts) => 4551 L.CRecord (_, xts) =>
4552 let 4552 let
4553 val (nullable, notNullable) = calcClientish xts 4553 val (nullable, notNullable) = calcClientish xts
4554 4554
4555 fun cond (x, v) = 4555 fun cond (x, v) =
4556 (L'.EStrcat ((L'.EPrim (Prim.String ("uw_" ^ x 4556 (L'.EStrcat ((L'.EPrim (Prim.String (Settings.mangleSql x
4557 ^ (case v of 4557 ^ (case v of
4558 Client => "" 4558 Client => ""
4559 | Channel => " >> 32") 4559 | Channel => " >> 32")
4560 ^ " = ")), loc), 4560 ^ " = ")), loc),
4561 target), loc) 4561 target), loc)
4562 4562
4563 val e = 4563 val e =
4564 foldl (fn ((x, v), e) => 4564 foldl (fn ((x, v), e) =>
4565 (L'.ESeq ( 4565 (L'.ESeq (
4566 (L'.EDml ((L'.EStrcat ( 4566 (L'.EDml ((L'.EStrcat (
4567 (L'.EPrim (Prim.String ("UPDATE uw_" 4567 (L'.EPrim (Prim.String ("UPDATE "
4568 ^ tab 4568 ^ Settings.mangleSql tab
4569 ^ " SET uw_" 4569 ^ " SET "
4570 ^ x 4570 ^ Settings.mangleSql x
4571 ^ " = NULL WHERE ")), loc), 4571 ^ " = NULL WHERE ")), loc),
4572 cond (x, v)), loc), L'.Error), loc), 4572 cond (x, v)), loc), L'.Error), loc),
4573 e), loc)) 4573 e), loc))
4574 e nullable 4574 e nullable
4575 4575
4582 (fn (eb, s) => 4582 (fn (eb, s) =>
4583 (L'.EStrcat (s, 4583 (L'.EStrcat (s,
4584 (L'.EStrcat ((L'.EPrim (Prim.String " OR "), 4584 (L'.EStrcat ((L'.EPrim (Prim.String " OR "),
4585 loc), 4585 loc),
4586 cond eb), loc)), loc)) 4586 cond eb), loc)), loc))
4587 (L'.EStrcat ((L'.EPrim (Prim.String ("DELETE FROM uw_" 4587 (L'.EStrcat ((L'.EPrim (Prim.String ("DELETE FROM "
4588 ^ tab 4588 ^ Settings.mangleSql tab
4589 ^ " WHERE ")), loc), 4589 ^ " WHERE ")), loc),
4590 cond eb), loc) 4590 cond eb), loc)
4591 ebs, L'.Error), loc), 4591 ebs, L'.Error), loc),
4592 e), loc) 4592 e), loc)
4593 in 4593 in
4616 [] => e 4616 [] => e
4617 | (x, _) :: ebs => 4617 | (x, _) :: ebs =>
4618 (L'.ESeq ( 4618 (L'.ESeq (
4619 (L'.EDml ((L'.EPrim (Prim.String 4619 (L'.EDml ((L'.EPrim (Prim.String
4620 (foldl (fn ((x, _), s) => 4620 (foldl (fn ((x, _), s) =>
4621 s ^ ", uw_" ^ x ^ " = NULL") 4621 s ^ ", " ^ Settings.mangleSql x ^ " = NULL")
4622 ("UPDATE uw_" 4622 ("UPDATE uw_"
4623 ^ tab 4623 ^ tab
4624 ^ " SET uw_" 4624 ^ " SET "
4625 ^ x 4625 ^ Settings.mangleSql x
4626 ^ " = NULL") 4626 ^ " = NULL")
4627 ebs)), loc), L'.Error), loc), 4627 ebs)), loc), L'.Error), loc),
4628 e), loc) 4628 e), loc)
4629 4629
4630 val e = 4630 val e =
4631 case notNullable of 4631 case notNullable of
4632 [] => e 4632 [] => e
4633 | eb :: ebs => 4633 | eb :: ebs =>
4634 (L'.ESeq ( 4634 (L'.ESeq (
4635 (L'.EDml ((L'.EPrim (Prim.String ("DELETE FROM uw_" 4635 (L'.EDml ((L'.EPrim (Prim.String ("DELETE FROM "
4636 ^ tab)), loc), L'.Error), loc), 4636 ^ Settings.mangleSql tab)), loc), L'.Error), loc),
4637 e), loc) 4637 e), loc)
4638 in 4638 in
4639 e 4639 e
4640 end 4640 end
4641 | _ => e 4641 | _ => e