summaryrefslogtreecommitdiff
path: root/src/monoize.sml
diff options
context:
space:
mode:
Diffstat (limited to 'src/monoize.sml')
-rw-r--r--src/monoize.sml280
1 files changed, 142 insertions, 138 deletions
diff --git a/src/monoize.sml b/src/monoize.sml
index 8224b26f..4985c932 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -249,7 +249,13 @@ fun monoType env =
(L'.TFfi ("Basis", "string"), loc)
| L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_from_items"), _), _), _), _) =>
(L'.TFfi ("Basis", "string"), loc)
- | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_exp"), _), _), _), _), _), _), _), _), _), _) =>
+ | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_exp"), _), _), _), _), _), _), _), _) =>
+ (L'.TFfi ("Basis", "string"), loc)
+ | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_expw"), _), _), _), _), _), _), _), _) =>
+ (L'.TFfi ("Basis", "string"), loc)
+ | L.CApp ((L.CFfi ("Basis", "sql_window"), _), _) =>
+ (L'.TRecord [], loc)
+ | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_window_function"), _), _), _), _), _), _), _), _) =>
(L'.TFfi ("Basis", "string"), loc)
| L.CApp ((L.CApp ((L.CFfi ("Basis", "primary_key"), _), _), _), _) =>
(L'.TFfi ("Basis", "string"), loc)
@@ -299,16 +305,16 @@ fun monoType env =
(L'.TRecord [], loc)
| L.CApp ((L.CFfi ("Basis", "sql_maxable"), _), _) =>
(L'.TRecord [], loc)
- | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_partition"), _), _), _), _), _), _) =>
- (L'.TFfi ("Basis", "string"), loc)
- | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_window"), _), _), _), _), _), _), _), _) =>
- (L'.TFfi ("Basis", "string"), loc)
| L.CApp ((L.CFfi ("Basis", "sql_arith"), _), _) =>
(L'.TRecord [], loc)
| L.CApp ((L.CFfi ("Basis", "sql_nfunc"), _), _) =>
(L'.TFfi ("Basis", "string"), loc)
| L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_ufunc"), _), _), _), _) =>
(L'.TFfi ("Basis", "string"), loc)
+ | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_partition"), _), _), _), _), _), _) =>
+ (L'.TFfi ("Basis", "string"), loc)
+ | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_window"), _), _), _), _), _), _), _), _) =>
+ (L'.TFfi ("Basis", "string"), loc)
| L.CApp ((L.CFfi ("Basis", "channel"), _), _) =>
(L'.TFfi ("Basis", "channel"), loc)
@@ -2111,9 +2117,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L.ECApp (
(L.ECApp (
(L.ECApp (
- (L.ECApp (
- (L.EFfi ("Basis", "sql_inject"), _),
- _), _),
+ (L.EFfi ("Basis", "sql_inject"), _),
_), _),
_), _),
_), _),
@@ -2426,7 +2430,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
| L.ECApp (
(L.ECApp (
(L.ECApp (
- (L.EFfi ("Basis", "sql_order_by_Cons"), _),
+ (L.ECApp (
+ (L.EFfi ("Basis", "sql_order_by_Cons"), _),
+ _), _),
_), _),
_), _),
_) =>
@@ -2434,19 +2440,20 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
val s = (L'.TFfi ("Basis", "string"), loc)
fun sc s = (L'.EPrim (Prim.String s), loc)
in
- ((L'.EAbs ("e1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
- (L'.EAbs ("d", s, (L'.TFun (s, s), loc),
- (L'.EAbs ("e2", s, s,
- (L'.ECase ((L'.ERel 0, loc),
- [((L'.PPrim (Prim.String ""), loc),
- strcat [(L'.ERel 2, loc),
- (L'.ERel 1, loc)]),
- ((L'.PWild, loc),
- strcat [(L'.ERel 2, loc),
- (L'.ERel 1, loc),
- sc ", ",
- (L'.ERel 0, loc)])],
- {disc = s, result = s}), loc)), loc)), loc)), loc),
+ ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc),
+ (L'.EAbs ("e1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
+ (L'.EAbs ("d", s, (L'.TFun (s, s), loc),
+ (L'.EAbs ("e2", s, s,
+ (L'.ECase ((L'.ERel 0, loc),
+ [((L'.PPrim (Prim.String ""), loc),
+ strcat [(L'.ERel 2, loc),
+ (L'.ERel 1, loc)]),
+ ((L'.PWild, loc),
+ strcat [(L'.ERel 2, loc),
+ (L'.ERel 1, loc),
+ sc ", ",
+ (L'.ERel 0, loc)])],
+ {disc = s, result = s}), loc)), loc)), loc)), loc)), loc),
fm)
end
@@ -2512,10 +2519,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L.ECApp (
(L.ECApp (
(L.ECApp (
- (L.ECApp (
(L.EFfi ("Basis", "sql_unary"), _),
_), _),
- _), _),
_), _),
_), _),
_), _),
@@ -2544,9 +2549,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L.ECApp (
(L.ECApp (
(L.ECApp (
- (L.ECApp (
- (L.EFfi ("Basis", "sql_binary"), _),
- _), _),
+ (L.EFfi ("Basis", "sql_binary"), _),
_), _),
_), _),
_), _),
@@ -2579,9 +2582,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L.ECApp (
(L.ECApp (
(L.ECApp (
- (L.ECApp (
- (L.EFfi ("Basis", "sql_field"), _),
- _), _),
+ (L.EFfi ("Basis", "sql_field"), _),
_), _),
_), _),
_), _),
@@ -2595,9 +2596,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L.ECApp (
(L.ECApp (
(L.ECApp (
- (L.ECApp (
- (L.EFfi ("Basis", "sql_exp"), _),
- _), _),
+ (L.EFfi ("Basis", "sql_exp"), _),
_), _),
_), _),
_), _),
@@ -2701,9 +2700,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
| L.ECApp (
(L.ECApp (
(L.ECApp (
- (L.ECApp (
- (L.EFfi ("Basis", "sql_count"), _),
- _), _),
+ (L.EFfi ("Basis", "sql_count"), _),
_), _),
_), _),
_) => ((L'.EPrim (Prim.String "COUNT(*)"), loc),
@@ -2714,9 +2711,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L.ECApp (
(L.ECApp (
(L.ECApp (
- (L.ECApp (
- (L.EFfi ("Basis", "sql_aggregate"), _),
- _), _),
+ (L.EFfi ("Basis", "sql_aggregate"), _),
_), _),
_), _),
_), _),
@@ -2732,7 +2727,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
sc ")"]
in
((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
- (L'.EAbs ("e1", s, s, main), loc)), loc),
+ (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), main), loc)), loc),
fm)
end
@@ -2781,73 +2776,33 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L'.EPrim (Prim.String "MIN"), loc)), loc)), loc),
fm)
- | L.ECApp (
- (L.ECApp (
- (L.ECApp (
- (L.EFfi ("Basis", "sql_no_partition"), _),
- _), _),
- _), _),
- _) => ((L'.EPrim (Prim.String ""), loc), fm)
- | L.ECApp (
- (L.ECApp (
- (L.ECApp (
- (L.ECApp (
- (L.EFfi ("Basis", "sql_partition"), _),
- _), _),
- _), _),
- _), _),
- _) =>
- let
- val s = (L'.TFfi ("Basis", "string"), loc)
- in
- ((L'.EAbs ("e", s, s, strcat [(L'.EPrim (Prim.String "PARTITION BY "), loc), (L'.ERel 0, loc)]), loc),
- fm)
- end
-
+ | L.EFfi ("Basis", "sql_asc") => ((L'.EPrim (Prim.String ""), loc), fm)
+ | L.EFfi ("Basis", "sql_desc") => ((L'.EPrim (Prim.String " DESC"), loc), fm)
| L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
- (L.EFfi ("Basis", "sql_window"), _),
+ (L.EFfi ("Basis", "sql_nfunc"), _),
_), _),
_), _),
_), _),
- _) =>
+ _) =>
let
- val () = if #windowFunctions (Settings.currentDbms ()) then
- ()
- else
- ErrorMsg.errorAt loc "The DBMS you've selected doesn't support window functions."
-
val s = (L'.TFfi ("Basis", "string"), loc)
fun sc s = (L'.EPrim (Prim.String s), loc)
-
- val main = strcat [(L'.ERel 2, loc),
- sc " OVER (",
- (L'.ERel 1, loc),
- (L'.ECase ((L'.ERel 0, loc),
- [((L'.PPrim (Prim.String ""), loc),
- sc ""),
- ((L'.PWild, loc),
- strcat [sc " ORDER BY ",
- (L'.ERel 0, loc)])],
- {disc = s,
- result = s}), loc),
- sc ")"]
in
- ((L'.EAbs ("w", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
- (L'.EAbs ("p", s, (L'.TFun (s, s), loc),
- (L'.EAbs ("o", s, s,
- main), loc)), loc)), loc),
+ ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc),
fm)
end
+ | L.EFfi ("Basis", "sql_window_normal") => ((L'.ERecord [], loc), fm)
+ | L.EFfi ("Basis", "sql_window_fancy") => ((L'.ERecord [], loc), fm)
| L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
- (L.EFfi ("Basis", "sql_window_aggregate"), _),
+ (L.EFfi ("Basis", "sql_window"), _),
_), _),
_), _),
_), _),
@@ -2855,43 +2810,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
_) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
- fun sc s = (L'.EPrim (Prim.String s), loc)
-
- val main = strcat [(L'.ERel 1, loc),
- sc "(",
- (L'.ERel 0, loc),
- sc ")"]
in
- ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
- (L'.EAbs ("e1", s, s, main), loc)), loc),
+ ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (s, s), loc),
+ (L'.EAbs ("e", s, s,
+ (L'.ERel 0, loc)), loc)), loc),
fm)
end
- | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_window_count"), _), _), _), _), _), _) =>
- ((L'.EPrim (Prim.String "COUNT(*)"), loc), fm)
- | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_window_rank"), _), _), _), _), _), _) =>
- ((L'.EPrim (Prim.String "RANK()"), loc), fm)
-
- | L.EFfi ("Basis", "sql_asc") => ((L'.EPrim (Prim.String ""), loc), fm)
- | L.EFfi ("Basis", "sql_desc") => ((L'.EPrim (Prim.String " DESC"), loc), fm)
- | L.ECApp (
- (L.ECApp (
- (L.ECApp (
- (L.ECApp (
- (L.ECApp (
- (L.EFfi ("Basis", "sql_nfunc"), _),
- _), _),
- _), _),
- _), _),
- _), _),
- _) =>
- let
- val s = (L'.TFfi ("Basis", "string"), loc)
- fun sc s = (L'.EPrim (Prim.String s), loc)
- in
- ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc),
- fm)
- end
| L.EFfi ("Basis", "sql_current_timestamp") => ((L'.EPrim (Prim.String "CURRENT_TIMESTAMP"), loc), fm)
| L.ECApp (
@@ -2899,9 +2824,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L.ECApp (
(L.ECApp (
(L.ECApp (
- (L.ECApp (
- (L.EFfi ("Basis", "sql_ufunc"), _),
- _), _),
+ (L.EFfi ("Basis", "sql_ufunc"), _),
_), _),
_), _),
_), _),
@@ -2935,9 +2858,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L.ECApp (
(L.ECApp (
(L.ECApp (
- (L.ECApp (
- (L.EFfi ("Basis", "sql_is_null"), _), _),
- _), _),
+ (L.EFfi ("Basis", "sql_is_null"), _), _),
_), _),
_), _),
_), _)) =>
@@ -2978,11 +2899,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L.ECApp (
(L.ECApp (
(L.ECApp (
- (L.ECApp (
- (L.ECApp (
- (L.EFfi ("Basis", "sql_if_then_else"), _), _),
- _), _),
- _), _),
+ (L.EFfi ("Basis", "sql_if_then_else"), _), _),
_), _),
_), _),
_), _)) =>
@@ -3007,9 +2924,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L.ECApp (
(L.ECApp (
(L.ECApp (
- (L.ECApp (
- (L.EFfi ("Basis", "sql_nullable"), _),
- _), _),
+ (L.EFfi ("Basis", "sql_nullable"), _),
_), _),
_), _),
_), _),
@@ -3030,9 +2945,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L.ECApp (
(L.ECApp (
(L.ECApp (
- (L.ECApp (
- (L.EFfi ("Basis", "sql_subquery"), _),
- _), _),
+ (L.EFfi ("Basis", "sql_subquery"), _),
_), _),
_), _),
_), _),
@@ -3051,6 +2964,97 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
fm)
end
+ | L.ECApp (
+ (L.ECApp (
+ (L.ECApp (
+ (L.EFfi ("Basis", "sql_no_partition"), _),
+ _), _),
+ _), _),
+ _) => ((L'.EPrim (Prim.String ""), loc), fm)
+ | L.ECApp (
+ (L.ECApp (
+ (L.ECApp (
+ (L.ECApp (
+ (L.EFfi ("Basis", "sql_partition"), _),
+ _), _),
+ _), _),
+ _), _),
+ _) =>
+ let
+ val s = (L'.TFfi ("Basis", "string"), loc)
+ in
+ ((L'.EAbs ("e", s, s, strcat [(L'.EPrim (Prim.String "PARTITION BY "), loc), (L'.ERel 0, loc)]), loc),
+ fm)
+ end
+
+ | L.ECApp (
+ (L.ECApp (
+ (L.ECApp (
+ (L.ECApp (
+ (L.EFfi ("Basis", "sql_window_function"), _),
+ _), _),
+ _), _),
+ _), _),
+ _) =>
+ let
+ val () = if #windowFunctions (Settings.currentDbms ()) then
+ ()
+ else
+ ErrorMsg.errorAt loc "The DBMS you've selected doesn't support window functions."
+
+ val s = (L'.TFfi ("Basis", "string"), loc)
+ fun sc s = (L'.EPrim (Prim.String s), loc)
+
+ val main = strcat [(L'.ERel 2, loc),
+ sc " OVER (",
+ (L'.ERel 1, loc),
+ (L'.ECase ((L'.ERel 0, loc),
+ [((L'.PPrim (Prim.String ""), loc),
+ sc ""),
+ ((L'.PWild, loc),
+ strcat [sc " ORDER BY ",
+ (L'.ERel 0, loc)])],
+ {disc = s,
+ result = s}), loc),
+ sc ")"]
+ in
+ ((L'.EAbs ("w", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
+ (L'.EAbs ("p", s, (L'.TFun (s, s), loc),
+ (L'.EAbs ("o", s, s,
+ main), loc)), loc)), loc),
+ fm)
+ end
+
+ | L.ECApp (
+ (L.ECApp (
+ (L.ECApp (
+ (L.ECApp (
+ (L.ECApp (
+ (L.EFfi ("Basis", "sql_window_aggregate"), _),
+ _), _),
+ _), _),
+ _), _),
+ _), _),
+ _) =>
+ let
+ val s = (L'.TFfi ("Basis", "string"), loc)
+ fun sc s = (L'.EPrim (Prim.String s), loc)
+
+ val main = strcat [(L'.ERel 1, loc),
+ sc "(",
+ (L'.ERel 0, loc),
+ sc ")"]
+ in
+ ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
+ (L'.EAbs ("e1", s, s, main), loc)), loc),
+ fm)
+ end
+
+ | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_window_count"), _), _), _), _), _), _) =>
+ ((L'.EPrim (Prim.String "COUNT(*)"), loc), fm)
+ | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_rank"), _), _), _), _), _), _) =>
+ ((L'.EPrim (Prim.String "RANK()"), loc), fm)
+
| L.EFfiApp ("Basis", "nextval", [(e, _)]) =>
let
val (e, fm) = monoExp (env, st, fm) e
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-20 07:01:40 +0000