summaryrefslogtreecommitdiff
path: root/src/monoize.sml
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-03-29 13:30:01 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-03-29 13:30:01 -0400
commit5430dbfa3f1c7c0adaabc230e86ffd90e6f923da (patch)
tree3bd72d9c87173e9ba21a556e5b90841f36e24651 /src/monoize.sml
parent6217967a353bc9d97ae45c2af495b653a47e2481 (diff)
Expunging non-nullable rows
Diffstat (limited to 'src/monoize.sml')
-rw-r--r--src/monoize.sml131
1 files changed, 100 insertions, 31 deletions
diff --git a/src/monoize.sml b/src/monoize.sml
index 5701cc0c..50678be4 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -165,8 +165,6 @@ fun monoType env =
| L.CApp ((L.CFfi ("Basis", "sql_injectable_prim"), _), t) =>
(L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc)
- | L.CApp ((L.CFfi ("Basis", "sql_injectable_nullable"), _), t) =>
- (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), 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"), _), _), _), _) =>
@@ -248,6 +246,8 @@ structure Fm :> sig
val lookup : t -> foo_kind -> int -> (int -> t -> L'.decl * t) -> t * int
val enter : t -> t
val decls : t -> L'.decl list
+
+ val freshName : t -> int * t
end = struct
structure M = BinaryMapFn(struct
@@ -274,6 +274,7 @@ fun empty count = {
}
fun enter ({count, map, ...} : t) = {count = count, map = map, decls = []}
+fun freshName {count, map, decls} = (count, {count = count + 1, map = map, decls = decls})
fun decls ({decls, ...} : t) = decls
fun lookup (t as {count, map, decls}) k n thunk =
@@ -1455,26 +1456,6 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
result = s}), loc)), loc)), loc),
fm)
end
- | L.ECApp ((L.EFfi ("Basis", "sql_nullable"), _), 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 ((L'.TOption t, loc), s), loc),
- (L'.EAbs ("x",
- (L'.TOption t, loc),
- s,
- (L'.ECase ((L'.ERel 0, loc),
- [((L'.PNone t, loc),
- (L'.EPrim (Prim.String "NULL"), loc)),
- ((L'.PSome (t, (L'.PVar ("y", t), loc)), loc),
- (L'.EApp ((L'.ERel 2, loc), (L'.ERel 0, loc)), loc))],
- {disc = (L'.TOption t, loc),
- result = s}), loc)), loc)), loc),
- fm)
- end
| L.ECApp ((L.EFfi ("Basis", "sql_subset"), _), _) =>
((L'.ERecord [], loc), fm)
@@ -2464,7 +2445,7 @@ fun monoDecl (env, fm) (all as (d, loc)) =
[(L'.DSequence s, loc),
(L'.DVal (x, n, t', e, s), loc)])
end
- | L.DDatabase s => SOME (env, fm, [(L'.DDatabase s, loc)])
+ | L.DDatabase _ => NONE
| L.DCookie (x, n, t, s) =>
let
val t = (L.CFfi ("Basis", "string"), loc)
@@ -2477,7 +2458,9 @@ fun monoDecl (env, fm) (all as (d, loc)) =
end
end
-fun monoize env ds =
+datatype expungable = Client | Channel
+
+fun monoize env file =
let
val p = !urlPrefix
val () =
@@ -2488,14 +2471,100 @@ fun monoize env ds =
else
()
+ val loc = E.dummySpan
+ val client = (L'.TFfi ("Basis", "client"), loc)
+ val unit = (L'.TRecord [], loc)
+ fun expunger () =
+ let
+ val target = (L'.EFfiApp ("Basis", "sqlifyClient", [(L'.ERel 0, loc)]), loc)
+
+ fun doTable (tab, xts, e) =
+ case xts of
+ L.CRecord (_, xts) =>
+ let
+ val (nullable, notNullable) =
+ foldl (fn ((x, t), st as (nullable, notNullable)) =>
+ case #1 x of
+ L.CName x =>
+ (case #1 t of
+ L.CFfi ("Basis", "client") =>
+ (nullable, (x, Client) :: notNullable)
+ | L.CApp ((L.CFfi ("Basis", "option"), _),
+ (L.CFfi ("Basis", "client"), _)) =>
+ ((x, Client) :: nullable, notNullable)
+ | L.CApp ((L.CFfi ("Basis", "channel"), _), _) =>
+ (nullable, (x, Channel) :: notNullable)
+ | L.CApp ((L.CFfi ("Basis", "option"), _),
+ (L.CApp ((L.CFfi ("Basis", "channel"), _), _), _)) =>
+ ((x, Channel) :: nullable, notNullable)
+ | _ => st)
+ | _ => st) ([], []) xts
+
+ val e =
+ case notNullable of
+ [] => e
+ | eb :: ebs =>
+ let
+ fun cond (x, v) =
+ (L'.EStrcat ((L'.EPrim (Prim.String ("uw_" ^ x
+ ^ (case v of
+ Client => ""
+ | Channel => " >> 32")
+ ^ " = ")), loc),
+ target), loc)
+ in
+ (L'.ESeq (
+ (L'.EDml (foldl
+ (fn (eb, s) =>
+ (L'.EStrcat (s,
+ (L'.EStrcat ((L'.EPrim (Prim.String " AND "),
+ loc),
+ cond eb), loc)), loc))
+ (L'.EStrcat ((L'.EPrim (Prim.String ("DELETE FROM uw_"
+ ^ tab
+ ^ " WHERE ")), loc),
+ cond eb), loc)
+ ebs), loc),
+ e), loc)
+ end
+ in
+ e
+ end
+ | _ => e
+
+ val e = (L'.ERecord [], loc)
+ in
+ foldl (fn ((d, _), e) =>
+ case d of
+ L.DTable (_, _, xts, tab) => doTable (tab, #1 xts, e)
+ | _ => e) e file
+ end
+
val (_, _, ds) = List.foldl (fn (d, (env, fm, ds)) =>
- case monoDecl (env, fm) d of
- NONE => (env, fm, ds)
- | SOME (env, fm, ds') =>
- (env,
- Fm.enter fm,
- ds' @ Fm.decls fm @ ds))
- (env, Fm.empty (CoreUtil.File.maxName ds + 1), []) ds
+ case #1 d of
+ L.DDatabase s =>
+ let
+ val (n, fm) = Fm.freshName fm
+
+
+ val d = L'.DVal ("expunger",
+ n,
+ (L'.TFun (client, unit), loc),
+ (L'.EAbs ("cli", client, unit, expunger ()), loc),
+ "expunger")
+ in
+ (env, Fm.enter fm, (L'.DDatabase (s, n), loc)
+ :: (d, loc)
+ :: ds)
+ end
+ | _ =>
+ case monoDecl (env, fm) d of
+ NONE => (env, fm, ds)
+ | SOME (env, fm, ds') =>
+ (env,
+ Fm.enter fm,
+ ds' @ Fm.decls fm @ ds))
+ (env, Fm.empty (CoreUtil.File.maxName file + 1), []) file
in
rev ds
end