aboutsummaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
authorGravatar Ziv Scully <ziv@mit.edu>2015-11-19 01:59:00 -0500
committerGravatar Ziv Scully <ziv@mit.edu>2015-11-19 01:59:00 -0500
commitbfcd84434ee997b474935aa13ae7bc1f3801d795 (patch)
tree77c947df67cba402ee17c655d8557bd1a29dfae8
parent588831a34eb1747b5468581169f6e68116ecbd62 (diff)
Support nested queries but disable UrFlow for now.
Diffstat
-rw-r--r--caching-tests/test.ur71
-rw-r--r--caching-tests/test.urp4
-rw-r--r--caching-tests/test.urs7
-rw-r--r--src/compiler.sig4
-rw-r--r--src/compiler.sml4
-rw-r--r--src/sources3
-rw-r--r--src/sql.sig13
-rw-r--r--src/sql.sml86
-rw-r--r--src/sqlcache.sml310
9 files changed, 332 insertions, 170 deletions
diff --git a/caching-tests/test.ur b/caching-tests/test.ur
index cbfde556..ea64bb2d 100644
--- a/caching-tests/test.ur
+++ b/caching-tests/test.ur
@@ -1,9 +1,7 @@
table tab : {Id : int, Val : int, Foo : int} PRIMARY KEY Id
fun cache id =
- res <- oneOrNoRows (SELECT tab.Val
- FROM tab
- WHERE tab.Id = {[id]});
+ res <- oneOrNoRows (SELECT tab.Val FROM tab WHERE tab.Id = {[id]});
return <xml><body>
cache
{case res of
@@ -11,21 +9,32 @@ fun cache id =
| Some row => <xml>{[row.Tab.Val]}</xml>}
</body></xml>
-fun sillyRecursive {Id = id : int, FooBar = fooBar} =
- if fooBar <= 0
- then 0
- else 1 + sillyRecursive {Id = id, FooBar = fooBar - 1}
+(* fun cacheAlt id = *)
+(* res <- oneOrNoRows (SELECT Q.Id *)
+(* FROM (SELECT Tab.Id AS Id FROM tab WHERE Tab.Id = {[id]}) *)
+(* AS Q); *)
+(* return <xml><body> *)
+(* cacheAlt *)
+(* {case res of *)
+(* None => <xml>?</xml> *)
+(* | Some row => <xml>{[row.Q.Id]}</xml>} *)
+(* </body></xml> *)
-fun cacheR (r : {Id : int, FooBar : int}) =
- res <- oneOrNoRows (SELECT tab.Val
- FROM tab
- WHERE tab.Id = {[r.Id]});
- return <xml><body>
- cacheR {[r.FooBar]}
- {case res of
- None => <xml>?</xml>
- | Some row => <xml>{[row.Tab.Val]}</xml>}
- </body></xml>
+(* fun sillyRecursive {Id = id : int, FooBar = fooBar} = *)
+(* if fooBar <= 0 *)
+(* then 0 *)
+(* else 1 + sillyRecursive {Id = id, FooBar = fooBar - 1} *)
+
+(* fun cacheR (r : {Id : int, FooBar : int}) = *)
+(* res <- oneOrNoRows (SELECT tab.Val *)
+(* FROM tab *)
+(* WHERE tab.Id = {[r.Id]}); *)
+(* return <xml><body> *)
+(* cacheR {[r.FooBar]} *)
+(* {case res of *)
+(* None => <xml>?</xml> *)
+(* | Some row => <xml>{[row.Tab.Val]}</xml>} *)
+(* </body></xml> *)
(* fun cache2 id v = *)
(* res <- oneOrNoRows (SELECT tab.Val *)
@@ -60,21 +69,21 @@ fun flush id =
Changed {[id]}!
</body></xml>
-fun flash id =
- dml (UPDATE tab
- SET Foo = Val
- WHERE Id = {[id]} OR Id = {[id - 1]} OR Id = {[id + 1]});
- return <xml><body>
- Maybe changed {[id]}?
- </body></xml>
+(* fun flash id = *)
+(* dml (UPDATE tab *)
+(* SET Foo = Val *)
+(* WHERE Id = {[id]} OR Id = {[id - 1]} OR Id = {[id + 1]}); *)
+(* return <xml><body> *)
+(* Maybe changed {[id]}? *)
+(* </body></xml> *)
-fun floosh id =
- dml (UPDATE tab
- SET Id = {[id + 1]}
- WHERE Id = {[id]});
- return <xml><body>
- Shifted {[id]}!
- </body></xml>
+(* fun floosh id = *)
+(* dml (UPDATE tab *)
+(* SET Id = {[id + 1]} *)
+(* WHERE Id = {[id]} OR Id = {[id - 1]} OR Id = {[id + 1]}); *)
+(* return <xml><body> *)
+(* Shifted {[id]}! *)
+(* </body></xml> *)
(* val flush17 = *)
(* dml (UPDATE tab *)
diff --git a/caching-tests/test.urp b/caching-tests/test.urp
index 07922e69..2cb9e711 100644
--- a/caching-tests/test.urp
+++ b/caching-tests/test.urp
@@ -1,8 +1,8 @@
database host=localhost
sql test.sql
safeGet Test/flush
-safeGet Test/flash
-safeGet Test/floosh
+# safeGet Test/flash
+# safeGet Test/floosh
# safeGet Test/flush17
minHeap 4096
diff --git a/caching-tests/test.urs b/caching-tests/test.urs
index 1fa5a9c2..d6e8dd2e 100644
--- a/caching-tests/test.urs
+++ b/caching-tests/test.urs
@@ -1,7 +1,8 @@
val cache : int -> transaction page
-val cacheR : {Id : int, FooBar : int} -> transaction page
+(* val cacheAlt : int -> transaction page *)
+(* val cacheR : {Id : int, FooBar : int} -> transaction page *)
(* val cache2 : int -> int -> transaction page *)
val flush : int -> transaction page
-val flash : int -> transaction page
-val floosh : int -> transaction page
+(* val flash : int -> transaction page *)
+(* val floosh : int -> transaction page *)
(* val flush17 : transaction page *)
diff --git a/src/compiler.sig b/src/compiler.sig
index c154240a..1ab0f7ae 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -114,7 +114,7 @@ signature COMPILER = sig
val untangle : (Mono.file, Mono.file) phase
val mono_reduce : (Mono.file, Mono.file) phase
val mono_shake : (Mono.file, Mono.file) phase
- val iflow : (Mono.file, Mono.file) phase
+ (* val iflow : (Mono.file, Mono.file) phase *)
val namejs : (Mono.file, Mono.file) phase
val scriptcheck : (Mono.file, Mono.file) phase
val jscomp : (Mono.file, Mono.file) phase
@@ -169,7 +169,7 @@ signature COMPILER = sig
val toMono_reduce : (string, Mono.file) transform
val toMono_shake : (string, Mono.file) transform
val toMono_opt2 : (string, Mono.file) transform
- val toIflow : (string, Mono.file) transform
+ (* val toIflow : (string, Mono.file) transform *)
val toNamejs : (string, Mono.file) transform
val toNamejs_untangle : (string, Mono.file) transform
val toScriptcheck : (string, Mono.file) transform
diff --git a/src/compiler.sml b/src/compiler.sml
index 814c48d3..d91d02aa 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -1372,19 +1372,21 @@ val toMono_shake = transform mono_shake "mono_shake1" o toMono_reduce
val toMono_opt2 = transform mono_opt "mono_opt2" o toMono_shake
+(*
val iflow = {
func = (fn file => (if !doIflow then Iflow.check file else (); file)),
print = MonoPrint.p_file MonoEnv.empty
}
val toIflow = transform iflow "iflow" o toMono_opt2
+*)
val namejs = {
func = NameJS.rewrite,
print = MonoPrint.p_file MonoEnv.empty
}
-val toNamejs = transform namejs "namejs" o toIflow
+val toNamejs = transform namejs "namejs" o toMono_opt2
val toNamejs_untangle = transform untangle "namejs_untangle" o toNamejs
diff --git a/src/sources b/src/sources
index 8bf80bc6..1436575d 100644
--- a/src/sources
+++ b/src/sources
@@ -207,9 +207,6 @@ $(SRC)/mono_shake.sml
$(SRC)/fuse.sig
$(SRC)/fuse.sml
-$(SRC)/iflow.sig
-$(SRC)/iflow.sml
-
$(SRC)/name_js.sig
$(SRC)/name_js.sml
diff --git a/src/sql.sig b/src/sql.sig
index 5f5d1b23..317c157f 100644
--- a/src/sql.sig
+++ b/src/sql.sig
@@ -81,12 +81,15 @@ datatype sitem =
SqField of string * string
| SqExp of sqexp * string
-type query1 = {Select : sitem list,
- From : (string * string) list,
- Where : sqexp option}
+datatype jtype = Inner | Left | Right | Full
-datatype query =
- Query1 of query1
+datatype fitem =
+ Table of string * string (* table AS name *)
+ | Join of jtype * fitem * fitem * sqexp
+ | Nested of query * string (* query AS name *)
+
+ and query =
+ Query1 of {Select : sitem list, From : fitem list, Where : sqexp option}
| Union of query * query
val query : query parser
diff --git a/src/sql.sml b/src/sql.sml
index 08315a16..16d4210c 100644
--- a/src/sql.sml
+++ b/src/sql.sml
@@ -382,48 +382,72 @@ val select = log "select"
(wrap (follow (const "SELECT ") (list sitem))
(fn ((), ls) => ls))
-val fitem = wrap (follow uw_ident
- (follow (const " AS ")
- t_ident))
- (fn (t, ((), f)) => (t, f))
+datatype jtype = Inner | Left | Right | Full
-val from = log "from"
- (wrap (follow (const "FROM ") (list fitem))
- (fn ((), ls) => ls))
+val jtype = wrap (ws (follow (opt (altL [wrap (const "LEFT") (fn () => Left),
+ wrap (const "RIGHT") (fn () => Right),
+ wrap (const "FULL") (fn () => Full)]))
+ (const " JOIN ")))
+ (fn (SOME jt, ()) => jt | (NONE, ()) => Inner)
-val wher = wrap (follow (ws (const "WHERE ")) sqexp)
- (fn ((), ls) => ls)
-
-type query1 = {Select : sitem list,
- From : (string * string) list,
- Where : sqexp option}
-
-val query1 = log "query1"
- (wrap (follow (follow select from) (opt wher))
- (fn ((fs, ts), wher) => {Select = fs, From = ts, Where = wher}))
+datatype fitem =
+ Table of string * string (* table AS name *)
+ | Join of jtype * fitem * fitem * sqexp
+ | Nested of query * string (* query AS name *)
-datatype query =
- Query1 of query1
+ and query =
+ Query1 of {Select : sitem list, From : fitem list, Where : sqexp option}
| Union of query * query
+val wher = wrap (follow (ws (const "WHERE ")) sqexp)
+ (fn ((), ls) => ls)
+
val orderby = log "orderby"
(wrap (follow (ws (const "ORDER BY "))
(follow (list sqexp)
(opt (ws (const "DESC")))))
ignore)
-fun query chs = log "query"
- (wrap
- (follow
- (alt (wrap (follow (const "((")
- (follow query
- (follow (const ") UNION (")
- (follow query (const "))")))))
- (fn ((), (q1, ((), (q2, ())))) => Union (q1, q2)))
- (wrap query1 Query1))
- (opt orderby))
- #1)
- chs
+fun fitem chs = altL [wrap (follow uw_ident
+ (follow (const " AS ")
+ t_ident))
+ (fn (t, ((), f)) => Table (t, f)),
+ wrap (follow (const "(")
+ (follow fitem
+ (follow jtype
+ (follow fitem
+ (follow (const " ON ")
+ (follow sqexp
+ (const ")")))))))
+ (fn ((), (fi1, (jt, (fi2, ((), (se, ())))))) =>
+ Join (jt, fi1, fi2, se)),
+ wrap (follow (const "(")
+ (follow query
+ (follow (const ") AS ") t_ident)))
+ (fn ((), (q, ((), f))) => Nested (q, f))]
+ chs
+
+and query1 chs = log "query1"
+ (wrap (follow (follow select from) (opt wher))
+ (fn ((fs, ts), wher) => {Select = fs, From = ts, Where = wher}))
+ chs
+
+and from chs = log "from"
+ (wrap (follow (const "FROM ") (list fitem))
+ (fn ((), ls) => ls))
+ chs
+
+and query chs = log "query"
+ (wrap (follow
+ (alt (wrap (follow (const "((")
+ (follow query
+ (follow (const ") UNION (")
+ (follow query (const "))")))))
+ (fn ((), (q1, ((), (q2, ())))) => Union (q1, q2)))
+ (wrap query1 Query1))
+ (opt orderby))
+ #1)
+ chs
datatype dml =
Insert of string * (string * sqexp) list
diff --git a/src/sqlcache.sml b/src/sqlcache.sml
index a8ef647b..9ff7c61d 100644
--- a/src/sqlcache.sml
+++ b/src/sqlcache.sml
@@ -30,11 +30,18 @@ fun mapFst f (x, y) = (f x, y)
(* Option monad. *)
fun obind (x, f) = Option.mapPartial f x
-fun oguard (b, x) = if b then x else NONE
+fun oguard (b, x) = if b then x () else NONE
fun omap f = fn SOME x => SOME (f x) | _ => NONE
fun omap2 f = fn (SOME x, SOME y) => SOME (f (x,y)) | _ => NONE
fun osequence ys = List.foldr (omap2 op::) (SOME []) ys
+fun concatMap f xs = List.concat (map f xs)
+
+val rec cartesianProduct : 'a list list -> 'a list list =
+ fn [] => [[]]
+ | (xs :: xss) => concatMap (fn ys => concatMap (fn x => [x :: ys]) xs)
+ (cartesianProduct xss)
+
fun indexOf test =
let
fun f n =
@@ -104,10 +111,12 @@ val doBind =
val dummyLoc = ErrorMsg.dummySpan
(* DEBUG *)
-fun printExp msg exp = Print.preface ("SQLCACHE: " ^ msg ^ ":", MonoPrint.p_exp MonoEnv.empty exp)
-fun printExp' msg exp' = printExp msg (exp', dummyLoc)
-fun printTyp msg typ = Print.preface ("SQLCACHE: " ^ msg ^ ":", MonoPrint.p_typ MonoEnv.empty typ)
-fun printTyp' msg typ' = printTyp msg (typ', dummyLoc)
+fun printExp msg exp =
+ (Print.preface ("SQLCACHE: " ^ msg ^ ":", MonoPrint.p_exp MonoEnv.empty exp); exp)
+fun printExp' msg exp' = (printExp msg (exp', dummyLoc); exp')
+fun printTyp msg typ =
+ (Print.preface ("SQLCACHE: " ^ msg ^ ":", MonoPrint.p_typ MonoEnv.empty typ); typ)
+fun printTyp' msg typ' = (printTyp msg (typ', dummyLoc); typ')
fun obindDebug printer (x, f) =
case x of
NONE => NONE
@@ -204,13 +213,6 @@ datatype 'atom formula' =
val flipJt = fn Conj => Disj | Disj => Conj
-fun concatMap f xs = List.concat (map f xs)
-
-val rec cartesianProduct : 'a list list -> 'a list list =
- fn [] => [[]]
- | (xs :: xss) => concatMap (fn ys => concatMap (fn x => [x :: ys]) xs)
- (cartesianProduct xss)
-
(* Pushes all negation to the atoms.*)
fun pushNegate (normalizeAtom : bool * 'atom -> 'atom) (negating : bool) =
fn Atom x => Atom' (normalizeAtom (negating, x))
@@ -349,8 +351,12 @@ end
structure AtomOptionKey = OptionKeyFn(AtomExpKey)
val rec tablesOfQuery =
- fn Sql.Query1 {From = tablePairs, ...} => SS.fromList (map #1 tablePairs)
+ fn Sql.Query1 {From = fitems, ...} => List.foldl SS.union SS.empty (map tableOfFitem fitems)
| Sql.Union (q1, q2) => SS.union (tablesOfQuery q1, tablesOfQuery q2)
+and tableOfFitem =
+ fn Sql.Table (t, _) => SS.singleton t
+ | Sql.Nested (q, _) => tablesOfQuery q
+ | Sql.Join (_, f1, f2, _) => SS.union (tableOfFitem f1, tableOfFitem f2)
val tableOfDml =
fn Sql.Insert (tab, _) => tab
@@ -489,43 +495,60 @@ end = struct
(* Need lift', etc. because we don't have rank-2 polymorphism. This should
probably use a functor (an ML one, not Haskell) but works for now. *)
- fun traverseSqexp (pure, _, lift, _, lift'', lift2, _) f =
+ fun traverseSqexp (pure, _, _, _, lift, lift', _, _, lift2, _, _, _, _, _) f =
let
val rec tr =
fn Sql.SqNot se => lift Sql.SqNot (tr se)
| Sql.Binop (r, se1, se2) =>
lift2 (fn (trse1, trse2) => Sql.Binop (r, trse1, trse2)) (tr se1, tr se2)
| Sql.SqKnown se => lift Sql.SqKnown (tr se)
- | Sql.Inj (e', loc) => lift'' (fn fe' => Sql.Inj (fe', loc)) (f e')
+ | Sql.Inj (e', loc) => lift' (fn fe' => Sql.Inj (fe', loc)) (f e')
| Sql.SqFunc (s, se) => lift (fn trse => Sql.SqFunc (s, trse)) (tr se)
| se => pure se
in
tr
end
- fun traverseQuery (ops as (_, pure', _, lift', _, _, lift2')) f =
+ fun traverseFitem (ops as (_, _, _, pure''', _, _, _, lift''', _, _, _, _, lift2'''', lift2''''')) f =
+ let
+ val rec tr =
+ fn Sql.Table t => pure''' (Sql.Table t)
+ | Sql.Join (jt, fi1, fi2, se) =>
+ lift2'''' (fn ((trfi1, trfi2), trse) => Sql.Join (jt, trfi1, trfi2, trse))
+ (lift2''''' id (tr fi1, tr fi2), traverseSqexp ops f se)
+ | Sql.Nested (q, s) => lift''' (fn trq => Sql.Nested (trq, s))
+ (traverseQuery ops f q)
+ in
+ tr
+ end
+
+ and traverseQuery (ops as (_, pure', pure'', _, _, _, lift'', _, _, lift2', lift2'', lift2''', _, _)) f =
let
- val rec mp =
+ val rec seqList =
+ fn [] => pure'' []
+ | (x::xs) => lift2''' op:: (x, seqList xs)
+ val rec tr =
fn Sql.Query1 q =>
- (case #Where q of
- NONE => pure' (Sql.Query1 q)
- | SOME se =>
- lift' (fn mpse => Sql.Query1 {Select = #Select q,
- From = #From q,
- Where = SOME mpse})
- (traverseSqexp ops f se))
- | Sql.Union (q1, q2) => lift2' Sql.Union (mp q1, mp q2)
+ (* TODO: make sure we don't need to traverse [#Select q]. *)
+ lift2' (fn (trfrom, trwher) => Sql.Query1 {Select = #Select q,
+ From = trfrom,
+ Where = trwher})
+ (seqList (map (traverseFitem ops f) (#From q)),
+ case #Where q of
+ NONE => pure' NONE
+ | SOME se => lift'' SOME (traverseSqexp ops f se))
+ | Sql.Union (q1, q2) => lift2'' Sql.Union (tr q1, tr q2)
in
- mp
+ tr
end
(* Include unused tuple elements in argument for convenience of using same
argument as [traverseQuery]. *)
- fun traverseIM (pure, _, _, _, _, lift2, _) f =
+ fun traverseIM (pure, _, _, _, _, _, _, _, _, lift2, _, _, _, _) f =
IM.foldli (fn (k, v, acc) => lift2 (fn (acc, w) => IM.insert (acc, k, w)) (acc, f (k,v)))
(pure IM.empty)
- fun traverseSubst (ops as (_, pure', lift, _, _, _, lift2')) f =
+ fun traverseSubst (ops as (_, pure', _, _, lift, _, _, _, _, lift2', _, _, _, _)) f =
let
fun mp ((n, fields), sqlify) =
lift (fn ((n', fields'), sqlify') =>
@@ -546,11 +569,14 @@ end = struct
traverseIM ops (fn (_, v) => mp v)
end
- fun monoidOps plus zero = (fn _ => zero, fn _ => zero,
- fn _ => fn x => x, fn _ => fn x => x, fn _ => fn x => x,
- fn _ => plus, fn _ => plus)
+ fun monoidOps plus zero =
+ (fn _ => zero, fn _ => zero, fn _ => zero, fn _ => zero,
+ fn _ => fn x => x, fn _ => fn x => x, fn _ => fn x => x, fn _ => fn x => x,
+ fn _ => plus, fn _ => plus, fn _ => plus, fn _ => plus, fn _ => plus, fn _ => plus)
- val optionOps = (SOME, SOME, omap, omap, omap, omap2, omap2)
+ val optionOps = (SOME, SOME, SOME, SOME,
+ omap, omap, omap, omap,
+ omap2, omap2, omap2, omap2, omap2, omap2)
fun foldMapQuery plus zero = traverseQuery (monoidOps plus zero)
val omapQuery = traverseQuery optionOps
@@ -727,7 +753,7 @@ val rec sqexpToFormula =
| Sql.Null => raise Fail "Sqlcache: sqexpToFormula (Null)"
fun mapSqexpFields f =
- fn Sql.Field (t, v) => f (t, v)
+ fn Sql.Field (t, v) => f (t, v)
| Sql.SqNot e => Sql.SqNot (mapSqexpFields f e)
| Sql.Binop (r, e1, e2) => Sql.Binop (r, mapSqexpFields f e1, mapSqexpFields f e2)
| Sql.SqKnown e => Sql.SqKnown (mapSqexpFields f e)
@@ -744,12 +770,102 @@ fun renameTables tablePairs =
mapSqexpFields (fn (t, f) => Sql.Field (rename t, f))
end
-fun queryToFormula marker =
- fn Sql.Query1 {Select = sitems, From = tablePairs, Where = wher} =>
+structure FlattenQuery = struct
+
+ datatype substitution = RenameTable of string | SubstituteExp of Sql.sqexp SM.map
+
+ fun applySubst substTable =
+ let
+ fun substitute (table, field) =
+ case SM.find (substTable, table) of
+ NONE => Sql.Field (table, field)
+ | SOME (RenameTable realTable) => Sql.Field (realTable, field)
+ | SOME (SubstituteExp substField) =>
+ case SM.find (substField, field) of
+ NONE => raise Fail "Sqlcache: applySubst"
+ | SOME se => se
+ in
+ mapSqexpFields substitute
+ end
+
+ fun addToSubst (substTable, table, substField) =
+ SM.insert (substTable,
+ table,
+ case substField of
+ RenameTable _ => substField
+ | SubstituteExp subst => SubstituteExp (SM.map (applySubst substTable) subst))
+
+ fun newSubst (t, s) = addToSubst (SM.empty, t, s)
+
+ datatype sitem' = Named of Sql.sqexp * string | Unnamed of Sql.sqexp
+
+ type queryFlat = {Select : sitem' list, Where : Sql.sqexp}
+
+ val sitemsToSubst =
+ List.foldl (fn (Named (se, s), acc) => SM.insert (acc, s, se)
+ | (Unnamed _, _) => raise Fail "Sqlcache: sitemsToSubst")
+ SM.empty
+
+ fun unionSubst (s1, s2) = SM.unionWith (fn _ => raise Fail "Sqlcache: unionSubst") (s1, s2)
+
+ fun sqlAnd (se1, se2) = Sql.Binop (Sql.RLop Sql.And, se1, se2)
+
+ val rec flattenFitem : Sql.fitem -> (Sql.sqexp * substitution SM.map) list =
+ fn Sql.Table (real, alias) => [(Sql.SqTrue, newSubst (alias, RenameTable real))]
+ | Sql.Nested (q, s) =>
+ let
+ val qfs = flattenQuery q
+ in
+ map (fn (qf, subst) =>
+ (#Where qf, addToSubst (subst, s, SubstituteExp (sitemsToSubst (#Select qf)))))
+ qfs
+ end
+ | Sql.Join (jt, fi1, fi2, se) =>
+ concatMap (fn ((wher1, subst1)) =>
+ map (fn (wher2, subst2) =>
+ (sqlAnd (wher1, wher2),
+ (* There should be no name conflicts... Ziv hopes? *)
+ unionSubst (subst1, subst2)))
+ (flattenFitem fi2))
+ (flattenFitem fi1)
+
+ and flattenQuery : Sql.query -> (queryFlat * substitution SM.map) list =
+ fn Sql.Query1 q =>
+ let
+ val fifss = cartesianProduct (map flattenFitem (#From q))
+ in
+ map (fn fifs =>
+ let
+ val subst = List.foldl (fn ((_, subst), acc) => unionSubst (acc, subst))
+ SM.empty
+ fifs
+ val wher = List.foldr (fn ((wher, _), acc) => sqlAnd (wher, acc))
+ (case #Where q of
+ NONE => Sql.SqTrue
+ | SOME wher => wher)
+ fifs
+ in
+ (* ASK: do we actually need to pass the substitution through here? *)
+ (* We use the substitution later, but it's not clear we
+ need any of its currently present fields again. *)
+ ({Select = map (fn Sql.SqExp (se, s) => Named (applySubst subst se, s)
+ | Sql.SqField tf =>
+ Unnamed (applySubst subst (Sql.Field tf)))
+ (#Select q),
+ Where = applySubst subst wher},
+ subst)
+ end)
+ fifss
+ end
+ | Sql.Union (q1, q2) => (flattenQuery q1) @ (flattenQuery q2)
+
+end
+
+val flattenQuery = map #1 o FlattenQuery.flattenQuery
+
+fun queryFlatToFormula marker {Select = sitems, Where = wher} =
let
- val fWhere = case wher of
- NONE => Combo (Conj, [])
- | SOME e => sqexpToFormula (renameTables tablePairs e)
+ val fWhere = sqexpToFormula wher
in
case marker of
NONE => fWhere
@@ -757,10 +873,10 @@ fun queryToFormula marker =
let
val fWhereMarked = mapFormulaExps markFields fWhere
val toSqexp =
- fn Sql.SqField tf => Sql.Field tf
- | Sql.SqExp (se, _) => se
+ fn FlattenQuery.Named (se, _) => se
+ | FlattenQuery.Unnamed se => se
fun ineq se = Atom (Sql.Ne, se, markFields se)
- val fIneqs = Combo (Disj, map (ineq o renameTables tablePairs o toSqexp) sitems)
+ val fIneqs = Combo (Disj, map (ineq o toSqexp) sitems)
in
(Combo (Conj,
[fWhere,
@@ -769,7 +885,8 @@ fun queryToFormula marker =
Combo (Conj, [fWhereMarked, fIneqs])])]))
end
end
- | Sql.Union (q1, q2) => Combo (Disj, [queryToFormula marker q1, queryToFormula marker q2])
+
+fun queryToFormula marker q = Combo (Disj, map (queryFlatToFormula marker) (flattenQuery q))
fun valsToFormula (markLeft, markRight) (table, vals) =
Combo (Conj,
@@ -828,7 +945,7 @@ structure ConflictMaps = struct
(* If we don't know one side of the comparision, not a contradiction. *)
| _ => false
in
- not (List.exists contradiction atoms) <\oguard\> SOME (UF.classes uf)
+ not (List.exists contradiction atoms) <\oguard\> (fn _ => SOME (UF.classes uf))
end
fun addToEqs (eqs, n, e) =
@@ -906,10 +1023,11 @@ structure ConflictMaps = struct
mapFormula (toAtomExps DmlRel)
(* No eqs should have key conflicts because no variable is in two
- equivalence classes, so the [#1] could be [#2]. *)
+ equivalence classes. *)
val mergeEqs : (atomExp IntBinaryMap.map option list
-> atomExp IntBinaryMap.map option) =
- List.foldr (omap2 (IM.unionWith #1)) (SOME IM.empty)
+ List.foldr (omap2 (IM.unionWith (fn _ => raise Fail "Sqlcache: ConflictMaps.mergeEqs")))
+ (SOME IM.empty)
val simplify =
map TS.listItems
@@ -1008,12 +1126,16 @@ fun fileAllMapfoldB doExp file start =
fun fileMap doExp file = #1 (fileAllMapfoldB (fn _ => fn e => fn _ => (doExp e, ())) file ())
(* TODO: make this a bit prettier.... *)
+(* TODO: factour out identical subexpressions to the same variable.... *)
val simplifySql =
let
fun factorOutNontrivial text =
let
val loc = dummyLoc
- fun strcat (e1, e2) = (EStrcat (e1, e2), loc)
+ val strcat =
+ fn (e1, (EPrim (Prim.String (Prim.Normal, "")), _)) => e1
+ | ((EPrim (Prim.String (Prim.Normal, "")), _), e2) => e2
+ | (e1, e2) => (EStrcat (e1, e2), loc)
val chunks = Sql.chunkify text
val (newText, newVariables) =
(* Important that this is foldr (to oppose foldl below). *)
@@ -1193,7 +1315,7 @@ fun shouldConsolidate args =
end
fun cacheExp (env, exp', invalInfo, state : state) =
- case worthCaching exp' <\oguard\> typOfExp' env exp' of
+ case worthCaching exp' <\oguard\> (fn _ => typOfExp' env exp') of
NONE => NONE
| SOME (TFun _, _) => NONE
| SOME typ =>
@@ -1202,26 +1324,28 @@ fun cacheExp (env, exp', invalInfo, state : state) =
in
shouldConsolidate args
<\oguard\>
- List.foldr (fn (arg, acc) =>
- acc
- <\obind\>
- (fn args' =>
- (case arg of
- AsIs exp => SOME exp
- | Urlify exp =>
- typOfExp env exp
- <\obind\>
- (fn typ => (MonoFooify.urlify env (exp, typ))))
- <\obind\>
- (fn arg' => SOME (arg' :: args'))))
- (SOME [])
- args
- <\obind\>
- (fn args' =>
- cacheWrap (env, (exp', dummyLoc), typ, args', #index state)
+ (fn _ =>
+ List.foldr (fn (arg, acc) =>
+ acc
+ <\obind\>
+ (fn args' =>
+ (case arg of
+ AsIs exp => SOME exp
+ | Urlify exp =>
+ typOfExp env exp
+ <\obind\>
+ (fn typ => (MonoFooify.urlify env (exp, typ))))
+ <\obind\>
+ (fn arg' => SOME (arg' :: args'))))
+ (SOME [])
+ args
<\obind\>
- (fn cachedExp =>
- SOME (cachedExp, InvalInfo.updateState (invalInfo, length args', state))))
+ (fn args' =>
+ cacheWrap (env, (exp', dummyLoc), typ, args', #index state)
+ <\obind\>
+ (fn cachedExp =>
+ SOME (cachedExp,
+ InvalInfo.updateState (invalInfo, length args', state)))))
end
fun cacheQuery (effs, env, q) : subexp =
@@ -1238,20 +1362,22 @@ fun cacheQuery (effs, env, q) : subexp =
val {query = queryText, initial, body, ...} = q
val attempt =
(* Ziv misses Haskell's do notation.... *)
- (safe 0 queryText andalso safe 0 initial andalso safe 2 body)
+ (safe 0 (printExp "attempt" queryText) andalso safe 0 initial andalso safe 2 body)
<\oguard\>
- Sql.parse Sql.query queryText
- <\obind\>
- (fn queryParsed =>
- let
- val invalInfo = InvalInfo.singleton queryParsed
- fun mkExp state =
- case cacheExp (env, EQuery q, invalInfo, state) of
- NONE => ((EQuery q, dummyLoc), state)
- | SOME (cachedExp, state) => ((cachedExp, dummyLoc), state)
- in
- SOME (Cachable (invalInfo, mkExp))
- end)
+ (fn _ =>
+ Sql.parse Sql.query (printExp "safe" queryText)
+ <\obind\>
+ (fn queryParsed =>
+ let
+ val _ = (printExp "parsed" queryText)
+ val invalInfo = InvalInfo.singleton queryParsed
+ fun mkExp state =
+ case cacheExp (env, EQuery q, invalInfo, state) of
+ NONE => ((EQuery q, dummyLoc), state)
+ | SOME (cachedExp, state) => ((cachedExp, dummyLoc), state)
+ in
+ SOME (Cachable (invalInfo, mkExp))
+ end))
in
case attempt of
NONE => Impure (EQuery q, dummyLoc)
@@ -1279,16 +1405,16 @@ fun cacheTree (effs : IS.set) ((env, exp as (exp', loc)), state) =
InvalInfo.unbind (invalInfoOfSubexp subexp, unbinds))
(subexps, args)))
<\obind\>
- (fn invalInfo =>
- SOME (Cachable (invalInfo,
- fn state =>
- case cacheExp (env,
- f (map (#2 o #1) args),
- invalInfo,
- state) of
- NONE => mkExp state
- | SOME (e', state) => ((e', loc), state)),
- state))
+ (fn invalInfo =>
+ SOME (Cachable (invalInfo,
+ fn state =>
+ case cacheExp (env,
+ f (map (#2 o #1) args),
+ invalInfo,
+ state) of
+ NONE => mkExp state
+ | SOME (e', state) => ((e', loc), state)),
+ state))
in
case attempt of
SOME (subexp, state) => (subexp, state)
@@ -1384,7 +1510,7 @@ structure Invalidations = struct
DmlRel n => ERel n
| Prim p => EPrim p
(* TODO: make new type containing only these two. *)
- | _ => raise Fail "Sqlcache: optionAtomExpToExp",
+ | _ => raise Fail "Sqlcache: Invalidations.optionAtomExpToExp",
loc)),
loc)
@@ -1506,8 +1632,8 @@ fun addLocking file =
ListMergeSort.sort (fn ((i, _), (j, _)) => i > j) ls
end
fun locksOfName n =
- lockList {store = IIMM.findSet (#flush lockMap, n),
- flush =IIMM.findSet (#store lockMap, n)}
+ lockList {flush = IIMM.findSet (#flush lockMap, n),
+ store = IIMM.findSet (#store lockMap, n)}
val locksOfExp = lockList o locksNeeded lockMap
val expts = exports file
fun doVal (v as (x, n, t, exp, s)) =
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-14 12:28:40 +0000