summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2008-08-31 13:58:47 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2008-08-31 13:58:47 -0400
commit769dd2e60357a97baee02b9595340a3c0ee79fb8 (patch)
tree5473200fdf38863018a2ba54f02b520bd02492ca
parent4688519e58b0b2923e291d6a719a7f34810bfdc1 (diff)
Monoized and optimized initial query test
-rw-r--r--lib/basis.urs2
-rw-r--r--src/cjrize.sml2
-rw-r--r--src/mono.sml7
-rw-r--r--src/mono_print.sml81
-rw-r--r--src/mono_reduce.sml99
-rw-r--r--src/mono_util.sml30
-rw-r--r--src/monoize.sig2
-rw-r--r--src/monoize.sml290
8 files changed, 449 insertions, 64 deletions
diff --git a/lib/basis.urs b/lib/basis.urs
index 421a07bc..7435e716 100644
--- a/lib/basis.urs
+++ b/lib/basis.urs
@@ -156,8 +156,8 @@ val bind : t1 ::: Type -> t2 ::: Type
-> transaction t2
val query : tables ::: {{Type}} -> exps ::: {Type} -> tables ~ exps
- -> sql_query tables exps
-> state ::: Type
+ -> sql_query tables exps
-> ($(exps ++ fold (fn nm (fields :: {Type}) acc => [nm] ~ acc => [nm = $fields] ++ acc) [] tables)
-> state
-> transaction state)
diff --git a/src/cjrize.sml b/src/cjrize.sml
index aa8ae562..7dbabe74 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -280,6 +280,8 @@ fun cifyExp ((e, loc), sm) =
| L.EClosure _ => (ErrorMsg.errorAt loc "Nested closure remains in code generation";
(dummye, sm))
+ | L.EQuery _ => raise Fail "Cjrize EQuery"
+
fun cifyDecl ((d, loc), sm) =
case d of
L.DDatatype (x, n, xncs) =>
diff --git a/src/mono.sml b/src/mono.sml
index c38e58ed..ae1b95dc 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -75,6 +75,13 @@ datatype exp' =
| EClosure of int * exp list
+ | EQuery of { exps : (string * typ) list,
+ tables : (string * (string * typ) list) list,
+ state : typ,
+ query : exp,
+ body : exp,
+ initial : exp }
+
withtype exp = exp' located
diff --git a/src/mono_print.sml b/src/mono_print.sml
index 9ac80b42..39db4c1c 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -38,6 +38,8 @@ structure E = MonoEnv
val debug = ref false
+val dummyt = (TRecord [], ErrorMsg.dummySpan)
+
fun p_typ' par env (t, _) =
case t of
TFun (t1, t2) => parenIf par (box [p_typ' true env t1,
@@ -133,17 +135,17 @@ fun p_exp' par env (e, _) =
| EApp (e1, e2) => parenIf par (box [p_exp env e1,
space,
p_exp' true env e2])
- | EAbs (x, t, _, e) => parenIf par (box [string "fn",
- space,
- string x,
- space,
- string ":",
- space,
- p_typ env t,
- space,
- string "=>",
- space,
- p_exp (E.pushERel env x t NONE) e])
+ | EAbs (x, t, _, e) => parenIf true (box [string "fn",
+ space,
+ string x,
+ space,
+ string ":",
+ space,
+ p_typ env t,
+ space,
+ string "=>",
+ space,
+ p_exp (E.pushERel env x t NONE) e])
| ERecord xes => box [string "{",
p_list (fn (x, e, _) =>
@@ -158,18 +160,18 @@ fun p_exp' par env (e, _) =
string ".",
string x]
- | ECase (e, pes, _) => parenIf par (box [string "case",
- space,
- p_exp env e,
- space,
- string "of",
- space,
- p_list_sep (box [space, string "|", space])
- (fn (p, e) => box [p_pat env p,
- space,
- string "=>",
- space,
- p_exp (E.patBinds env p) e]) pes])
+ | ECase (e, pes, _) => parenIf true (box [string "case",
+ space,
+ p_exp env e,
+ space,
+ string "of",
+ space,
+ p_list_sep (box [space, string "|", space])
+ (fn (p, e) => box [p_pat env p,
+ space,
+ string "=>",
+ space,
+ p_exp (E.patBinds env p) e]) pes])
| EStrcat (e1, e2) => box [p_exp' true env e1,
space,
@@ -185,7 +187,7 @@ fun p_exp' par env (e, _) =
string ";",
space,
p_exp env e2]
- | ELet (x, t, e1, e2) => box [string "let",
+ | ELet (x, t, e1, e2) => box [string "(let",
space,
string x,
space,
@@ -195,11 +197,15 @@ fun p_exp' par env (e, _) =
space,
string "=",
space,
+ string "(",
p_exp env e1,
+ string ")",
space,
string "in",
space,
- p_exp (E.pushERel env x t NONE) e2]
+ string "(",
+ p_exp (E.pushERel env x t NONE) e2,
+ string "))"]
| EClosure (n, es) => box [string "CLOSURE(",
p_enamed env n,
@@ -207,6 +213,31 @@ fun p_exp' par env (e, _) =
p_exp env e]) es,
string ")"]
+ | EQuery {exps, tables, state, query, body, initial} =>
+ box [string "query[",
+ p_list (fn (x, t) => box [string x, space, string ":", space, p_typ env t]) exps,
+ string "] [",
+ p_list (fn (x, xts) => box [string x,
+ space,
+ string ":",
+ space,
+ string "{",
+ p_list (fn (x, t) => box [string x, space, string ":", space, p_typ env t]) xts,
+ string "}"]) tables,
+ string "] [",
+ p_typ env state,
+ string "]",
+ space,
+ p_exp env query,
+ space,
+ string "initial",
+ space,
+ p_exp env initial,
+ space,
+ string "in",
+ space,
+ p_exp (E.pushERel (E.pushERel env "r" dummyt NONE) "acc" dummyt NONE) body]
+
and p_exp env = p_exp' false env
fun p_vali env (x, n, t, e, s) =
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 31757daa..1941f0cc 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -34,20 +34,38 @@ open Mono
structure E = MonoEnv
structure U = MonoUtil
-val liftExpInExp =
- U.Exp.mapB {typ = fn t => t,
- exp = fn bound => fn e =>
- case e of
- ERel xn =>
- if xn < bound then
- e
- else
- ERel (xn + 1)
- | _ => e,
- bind = fn (bound, U.Exp.RelE _) => bound + 1
- | (bound, _) => bound}
-
-val subExpInExp =
+
+fun impure (e, _) =
+ case e of
+ EWrite _ => true
+ | EQuery _ => true
+ | EAbs _ => false
+
+ | EPrim _ => false
+ | ERel _ => false
+ | ENamed _ => false
+ | ECon (_, _, eo) => (case eo of NONE => false | SOME e => impure e)
+ | EFfi _ => false
+ | EFfiApp _ => false
+ | EApp ((EFfi _, _), _) => false
+ | EApp _ => true
+
+ | ERecord xes => List.exists (fn (_, e, _) => impure e) xes
+ | EField (e, _) => impure e
+
+ | ECase (e, pes, _) => impure e orelse List.exists (fn (_, e) => impure e) pes
+
+ | EStrcat (e1, e2) => impure e1 orelse impure e2
+
+ | ESeq (e1, e2) => impure e1 orelse impure e2
+ | ELet (_, _, e1, e2) => impure e1 orelse impure e2
+
+ | EClosure (_, es) => List.exists impure es
+
+
+val liftExpInExp = Monoize.liftExpInExp
+
+val subExpInExp' =
U.Exp.mapB {typ = fn t => t,
exp = fn (xn, rep) => fn e =>
case e of
@@ -60,11 +78,15 @@ val subExpInExp =
bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, liftExpInExp 0 rep)
| (ctx, _) => ctx}
-fun bind (env, b) =
- case b of
- U.Decl.Datatype (x, n, xncs) => E.pushDatatype env x n xncs
- | U.Decl.RelE (x, t) => E.pushERel env x t NONE
- | U.Decl.NamedE (x, n, t, eo, s) => E.pushENamed env x n t eo s
+fun subExpInExp (n, e1) e2 =
+ let
+ val r = subExpInExp' (n, e1) e2
+ in
+ (*Print.prefaces "subExpInExp" [("e1", MonoPrint.p_exp MonoEnv.empty e1),
+ ("e2", MonoPrint.p_exp MonoEnv.empty e2),
+ ("r", MonoPrint.p_exp MonoEnv.empty r)];*)
+ r
+ end
fun typ c = c
@@ -132,8 +154,13 @@ fun exp env e =
(_, _, SOME e', _) => #1 e'
| _ => e)
- | EApp ((EAbs (_, _, _, e1), loc), e2) =>
- #1 (reduceExp env (subExpInExp (0, e2) e1))
+ | EApp ((EAbs (x, t, _, e1), loc), e2) =>
+ ((*Print.prefaces "Considering" [("e1", MonoPrint.p_exp env e1),
+ ("e2", MonoPrint.p_exp env e2)];*)
+ if impure e2 then
+ #1 (reduceExp env (ELet (x, t, e2, e1), loc))
+ else
+ #1 (reduceExp env (subExpInExp (0, e2) e1)))
| ECase (disc, pes, _) =>
(case ListUtil.search (fn (p, body) =>
@@ -143,8 +170,38 @@ fun exp env e =
NONE => e
| SOME e' => e')
+ | EField ((ERecord xes, _), x) =>
+ (case List.find (fn (x', _, _) => x' = x) xes of
+ SOME (_, e, _) => #1 e
+ | NONE => e)
+
+ | ELet (x1, t1, (ELet (x2, t2, e1, b1), loc), b2) =>
+ let
+ val e' = (ELet (x2, t2, e1,
+ (ELet (x1, t1, b1,
+ liftExpInExp 1 b2), loc)), loc)
+ in
+ Print.prefaces "ELet commute" [("e", MonoPrint.p_exp env (e, loc)),
+ ("e'", MonoPrint.p_exp env e')];
+ #1 (reduceExp env e')
+ end
+ | EApp ((ELet (x, t, e, b), loc), e') =>
+ #1 (reduceExp env (ELet (x, t, e,
+ (EApp (b, liftExpInExp 0 e'), loc)), loc))
+ | ELet (x, t, e', b) =>
+ if impure e' then
+ e
+ else
+ #1 (reduceExp env (subExpInExp (0, e') b))
+
| _ => e
+and bind (env, b) =
+ case b of
+ U.Decl.Datatype (x, n, xncs) => E.pushDatatype env x n xncs
+ | U.Decl.RelE (x, t) => E.pushERel env x t NONE
+ | U.Decl.NamedE (x, n, t, eo, s) => E.pushENamed env x n t (Option.map (reduceExp env) eo) s
+
and reduceExp env = U.Exp.mapB {typ = typ, exp = exp, bind = bind} env
fun decl env d = d
diff --git a/src/mono_util.sml b/src/mono_util.sml
index 8f5b29e8..0b2817f1 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -218,7 +218,7 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
fn t' =>
S.bind2 (mfe ctx e1,
fn e1' =>
- S.map2 (mfe (bind (ctx, RelE (x, t))) e2,
+ S.map2 (mfe (bind (ctx, RelE (x, t'))) e2,
fn e2' =>
(ELet (x, t', e1', e2'), loc))))
@@ -226,6 +226,34 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
S.map2 (ListUtil.mapfold (mfe ctx) es,
fn es' =>
(EClosure (n, es'), loc))
+
+ | EQuery {exps, tables, state, query, body, initial} =>
+ S.bind2 (ListUtil.mapfold (fn (x, t) =>
+ S.map2 (mft t,
+ fn t' => (x, t'))) exps,
+ fn exps' =>
+ S.bind2 (ListUtil.mapfold (fn (x, xts) =>
+ S.map2 (ListUtil.mapfold
+ (fn (x, t) =>
+ S.map2 (mft t,
+ fn t' => (x, t'))) xts,
+ fn xts' => (x, xts'))) tables,
+ fn tables' =>
+ S.bind2 (mft state,
+ fn state' =>
+ S.bind2 (mfe ctx query,
+ fn query' =>
+ S.bind2 (mfe ctx body,
+ fn body' =>
+ S.map2 (mfe ctx initial,
+ fn initial' =>
+ (EQuery {exps = exps',
+ tables = tables',
+ state = state',
+ query = query',
+ body = body',
+ initial = initial'},
+ loc)))))))
in
mfe
end
diff --git a/src/monoize.sig b/src/monoize.sig
index 0e9c23c3..838d7c4c 100644
--- a/src/monoize.sig
+++ b/src/monoize.sig
@@ -29,4 +29,6 @@ signature MONOIZE = sig
val monoize : CoreEnv.env -> Core.file -> Mono.file
+ val liftExpInExp : int -> Mono.exp -> Mono.exp
+
end
diff --git a/src/monoize.sml b/src/monoize.sml
index b1a38558..abbd4f40 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -37,6 +37,21 @@ structure IM = IntBinaryMap
val dummyTyp = (L'.TDatatype (0, ref (L'.Enum, [])), E.dummySpan)
+structure U = MonoUtil
+
+val liftExpInExp =
+ U.Exp.mapB {typ = fn t => t,
+ exp = fn bound => fn e =>
+ case e of
+ L'.ERel xn =>
+ if xn < bound then
+ e
+ else
+ L'.ERel (xn + 1)
+ | _ => e,
+ bind = fn (bound, U.Exp.RelE _) => bound + 1
+ | (bound, _) => bound}
+
fun monoName env (all as (c, loc)) =
let
fun poly () =
@@ -71,7 +86,43 @@ fun monoType env =
(L'.TFfi ("Basis", "string"), loc)
| L.CApp ((L.CFfi ("Basis", "transaction"), _), t) =>
- (L'.TFun (mt env dtmap t, (L'.TRecord [], loc)), loc)
+ (L'.TFun ((L'.TRecord [], loc), mt env dtmap t), loc)
+ | L.CApp ((L.CFfi ("Basis", "sql_table"), _), _) =>
+ (L'.TFfi ("Basis", "string"), loc)
+ | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_query"), _), _), _), _) =>
+ (L'.TFfi ("Basis", "string"), loc)
+ | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_query1"), _), _), _), _), _), _) =>
+ (L'.TFfi ("Basis", "string"), loc)
+ | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_exp"), _), _), _), _), _), _), _), _) =>
+ (L'.TFfi ("Basis", "string"), loc)
+
+ | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_subset"), _), _), _), _) =>
+ (L'.TRecord [], loc)
+ | L.CFfi ("Basis", "sql_relop") =>
+ (L'.TFfi ("Basis", "string"), loc)
+ | L.CFfi ("Basis", "sql_direction") =>
+ (L'.TFfi ("Basis", "string"), loc)
+ | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_order_by"), _), _), _), _) =>
+ (L'.TFfi ("Basis", "string"), loc)
+ | L.CFfi ("Basis", "sql_limit") =>
+ (L'.TFfi ("Basis", "string"), loc)
+ | L.CFfi ("Basis", "sql_offset") =>
+ (L'.TFfi ("Basis", "string"), loc)
+
+ | L.CApp ((L.CFfi ("Basis", "sql_injectable"), _), t) =>
+ (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc)
+ | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_unary"), _), _), _), _) =>
+ (L'.TFfi ("Basis", "string"), loc)
+ | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_binary"), _), _), _), _), _), _) =>
+ (L'.TFfi ("Basis", "string"), loc)
+ | L.CFfi ("Basis", "sql_comparison") =>
+ (L'.TFfi ("Basis", "string"), loc)
+ | L.CApp ((L.CFfi ("Basis", "sql_aggregate"), _), t) =>
+ (L'.TFfi ("Basis", "string"), loc)
+ | L.CApp ((L.CFfi ("Basis", "sql_summable"), _), _) =>
+ (L'.TRecord [], loc)
+ | L.CApp ((L.CFfi ("Basis", "sql_maxable"), _), _) =>
+ (L'.TRecord [], loc)
| L.CRel _ => poly ()
| L.CNamed n =>
@@ -347,6 +398,41 @@ fun monoPat env (all as (p, loc)) =
| L.PRecord xps => (L'.PRecord (map (fn (x, p, t) => (x, monoPat env p, monoType env t)) xps), loc)
end
+fun strcat loc es =
+ case es of
+ [] => (L'.EPrim (Prim.String ""), loc)
+ | [e] => e
+ | _ =>
+ let
+ val e2 = List.last es
+ val es = List.take (es, length es - 1)
+ val e1 = List.last es
+ val es = List.take (es, length es - 1)
+ in
+ foldr (fn (e, e') => (L'.EStrcat (e, e'), loc))
+ (L'.EStrcat (e1, e2), loc) es
+ end
+
+fun strcatComma loc es =
+ case es of
+ [] => (L'.EPrim (Prim.String ""), loc)
+ | [e] => e
+ | _ =>
+ let
+ val e1 = List.last es
+ val es = List.take (es, length es - 1)
+ in
+ foldr (fn (e, e') =>
+ case e of
+ (L'.EPrim (Prim.String ""), _) => e'
+ | _ =>
+ (L'.EStrcat (e,
+ (L'.EStrcat ((L'.EPrim (Prim.String ", "), loc), e'), loc)), loc))
+ e1 es
+ end
+
+fun strcatR loc e xs = strcatComma loc (map (fn (x, _) => (L'.EField (e, x), loc)) xs)
+
fun monoExp (env, st, fm) (all as (e, loc)) =
let
fun poly () =
@@ -373,32 +459,195 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
((L'.ECon (dk, monoPatCon env pc, eo), loc), fm)
end
| L.ECon _ => poly ()
- | L.EFfi mx => ((L'.EFfi mx, loc), fm)
- | L.EFfiApp (m, x, es) =>
+
+ | L.ECApp ((L.EFfi ("Basis", "return"), _), t) =>
let
- val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es
+ val t = monoType env t
in
- ((L'.EFfiApp (m, x, es), loc), fm)
+ ((L'.EAbs ("x", t,
+ (L'.TFun ((L'.TRecord [], loc), t), loc),
+ (L'.EAbs ("_", (L'.TRecord [], loc), t,
+ (L'.ERel 1, loc)), loc)), loc), fm)
end
-
- | L.ECApp ((L.EFfi ("Basis", "return"), _), t) =>
- ((L'.EAbs ("x", monoType env t, (L'.TRecord [], loc), (L'.ERel 0, loc)), loc), fm)
| L.ECApp ((L.ECApp ((L.EFfi ("Basis", "bind"), _), t1), _), t2) =>
let
val t1 = monoType env t1
val t2 = monoType env t2
val un = (L'.TRecord [], loc)
- val mt1 = (L'.TFun (t1, un), loc)
- val mt2 = (L'.TFun (t2, un), loc)
+ val mt1 = (L'.TFun (un, t1), loc)
+ val mt2 = (L'.TFun (un, t2), loc)
in
- ((L'.EAbs ("m1", mt1, (L'.TFun (mt1, (L'.TFun (mt2, un), loc)), loc),
- (L'.EAbs ("m2", mt2, un,
- (L'.ELet ("r", t1, (L'.ERel 1, loc),
- (L'.EApp ((L'.ERel 1, loc), (L'.ERel 0, loc)),
- loc)), loc)), loc)), loc),
+ ((L'.EAbs ("m1", mt1, (L'.TFun (mt1, (L'.TFun (mt2, (L'.TFun (un, un), loc)), loc)), loc),
+ (L'.EAbs ("m2", mt2, (L'.TFun (un, un), loc),
+ (L'.EAbs ("_", un, un,
+ (L'.ELet ("r", t1, (L'.EApp ((L'.ERel 2, loc),
+ (L'.ERecord [], loc)), loc),
+ (L'.EApp (
+ (L'.EApp ((L'.ERel 2, loc), (L'.ERel 0, loc)), loc),
+ (L'.ERecord [], loc)),
+ loc)), loc)), loc)), loc)), loc),
fm)
end
+ | L.ECApp (
+ (L.ECApp (
+ (L.ECApp ((L.EFfi ("Basis", "query"), _), (L.CRecord (_, tables), _)), _),
+ exps), _),
+ state) =>
+ (case monoType env (L.TRecord exps, loc) of
+ (L'.TRecord exps, _) =>
+ let
+ val tables = map (fn ((L.CName x, _), xts) =>
+ (case monoType env (L.TRecord xts, loc) of
+ (L'.TRecord xts, _) => SOME (x, xts)
+ | _ => NONE)
+ | _ => NONE) tables
+ in
+ if List.exists (fn x => x = NONE) tables then
+ poly ()
+ else
+ let
+ val tables = List.mapPartial (fn x => x) tables
+ val state = monoType env state
+ val s = (L'.TFfi ("Basis", "string"), loc)
+ val un = (L'.TRecord [], loc)
+
+ val rt = exps @ map (fn (x, xts) => (x, (L'.TRecord xts, loc))) tables
+ val ft = (L'.TFun ((L'.TRecord rt, loc),
+ (L'.TFun (state,
+ (L'.TFun (un, state), loc)),
+ loc)), loc)
+
+ val body' = (L'.EAbs ("r", (L'.TRecord rt, loc),
+ (L'.TFun (state, state), loc),
+ (L'.EAbs ("acc", state, state,
+ (L'.EApp (
+ (L'.EApp (
+ (L'.EApp ((L'.ERel 4, loc),
+ (L'.ERel 1, loc)), loc),
+ (L'.ERel 0, loc)), loc),
+ (L'.ERecord [], loc)), loc)), loc)), loc)
+
+ val body = (L'.EQuery {exps = exps,
+ tables = tables,
+ state = state,
+ query = (L'.ERel 3, loc),
+ body = body',
+ initial = (L'.ERel 1, loc)},
+ loc)
+ in
+ ((L'.EAbs ("q", s, (L'.TFun (ft, (L'.TFun (state, (L'.TFun (un, state), loc)), loc)), loc),
+ (L'.EAbs ("f", ft, (L'.TFun (state, (L'.TFun (un, state), loc)), loc),
+ (L'.EAbs ("i", state, (L'.TFun (un, state), loc),
+ (L'.EAbs ("_", un, state,
+ body), loc)), loc)), loc)), loc), fm)
+ end
+ end
+ | _ => poly ())
+
+ | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_query"), _), _), _), _), _), _) =>
+ let
+ fun sc s = (L'.EPrim (Prim.String s), loc)
+ val s = (L'.TFfi ("Basis", "string"), loc)
+ fun gf s = (L'.EField ((L'.ERel 0, loc), s), loc)
+ in
+ ((L'.EAbs ("r",
+ (L'.TRecord [("Rows", s), ("OrderBy", s), ("Limit", s), ("Offset", s)], loc),
+ s,
+ strcat loc [gf "Rows",
+ gf "OrderBy",
+ gf "Limit",
+ gf "Offset"]), loc), fm)
+ end
+
+ | L.ECApp (
+ (L.ECApp (
+ (L.ECApp (
+ (L.ECApp (
+ (L.EFfi ("Basis", "sql_query1"), _),
+ (L.CRecord (_, tables), _)), _),
+ (L.CRecord (_, grouped), _)), _),
+ (L.CRecord (_, stables), _)), _),
+ sexps) =>
+ let
+ fun sc s = (L'.EPrim (Prim.String s), loc)
+ val s = (L'.TFfi ("Basis", "string"), loc)
+ val un = (L'.TRecord [], loc)
+ fun gf s = (L'.EField ((L'.ERel 0, loc), s), loc)
+
+ fun doTables tables =
+ let
+ val tables = map (fn ((L.CName x, _), xts) =>
+ (case monoType env (L.TRecord xts, loc) of
+ (L'.TRecord xts, _) => SOME (x, xts)
+ | _ => NONE)
+ | _ => NONE) tables
+ in
+ if List.exists (fn x => x = NONE) tables then
+ NONE
+ else
+ SOME (List.mapPartial (fn x => x) tables)
+ end
+ in
+ case (doTables tables, doTables grouped, doTables stables, monoType env (L.TRecord sexps, loc)) of
+ (SOME tables, SOME grouped, SOME stables, (L'.TRecord sexps, _)) =>
+ ((L'.EAbs ("r",
+ (L'.TRecord [("From", (L'.TRecord (map (fn (x, _) => (x, s)) tables), loc)),
+ ("Where", s),
+ ("GroupBy", un),
+ ("Having", s),
+ ("SelectFields", un),
+ ("SelectExps", (L'.TRecord (map (fn (x, _) => (x, s)) sexps), loc))],
+ loc),
+ s,
+ strcat loc [sc "SELECT ",
+ strcatR loc (gf "SelectExps") sexps,
+ case sexps of
+ [] => sc ""
+ | _ => sc ", ",
+ strcatComma loc (map (fn (x, xts) =>
+ strcatComma loc
+ (map (fn (x', _) =>
+ sc (x ^ "." ^ x'))
+ xts)) stables),
+ sc " FROM ",
+ strcatComma loc (map (fn (x, _) => strcat loc [(L'.EField (gf "From", x), loc),
+ sc (" AS " ^ x)]) tables)
+ ]), loc),
+ fm)
+ | _ => poly ()
+ end
+
+ | L.ECApp (
+ (L.ECApp (
+ (L.ECApp (
+ (L.ECApp (
+ (L.EFfi ("Basis", "sql_inject"), _),
+ _), _),
+ _), _),
+ _), _),
+ t) =>
+ let
+ val t = monoType env t
+ val s = (L'.TFfi ("Basis", "string"), loc)
+ in
+ ((L'.EAbs ("f", (L'.TFun (t, s), loc), (L'.TFun (t, s), loc),
+ (L'.ERel 0, loc)), loc), fm)
+ end
+
+ | L.ECApp ((L.EFfi ("Basis", "sql_subset"), _), _) =>
+ ((L'.ERecord [], loc), fm)
+ | L.ECApp ((L.EFfi ("Basis", "sql_subset_all"), _), _) =>
+ ((L'.ERecord [], loc), fm)
+
+ | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_order_by_Nil"), _), _), _), _) =>
+ ((L'.EPrim (Prim.String ""), loc), fm)
+
+ | L.EFfi ("Basis", "sql_no_limit") =>
+ ((L'.EPrim (Prim.String ""), loc), fm)
+ | L.EFfi ("Basis", "sql_no_offset") =>
+ ((L'.EPrim (Prim.String ""), loc), fm)
+
| L.EApp (
(L.ECApp (
(L.ECApp ((L.EFfi ("Basis", "cdata"), _), _), _),
@@ -721,6 +970,14 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
| L.ECApp _ => poly ()
| L.ECAbs _ => poly ()
+ | L.EFfi mx => ((L'.EFfi mx, loc), fm)
+ | L.EFfiApp (m, x, es) =>
+ let
+ val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es
+ in
+ ((L'.EFfiApp (m, x, es), loc), fm)
+ end
+
| L.ERecord xes =>
let
val (xes, fm) = ListUtil.foldlMap
@@ -762,7 +1019,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
let
val (e, fm) = monoExp (env, st, fm) e
in
- ((L'.EWrite e, loc), fm)
+ ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
+ (L'.EWrite (liftExpInExp 0 e), loc)), loc), fm)
end
| L.EClosure (n, es) =>