From bfcd84434ee997b474935aa13ae7bc1f3801d795 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Thu, 19 Nov 2015 01:59:00 -0500 Subject: Support nested queries but disable UrFlow for now. --- src/sqlcache.sml | 310 ++++++++++++++++++++++++++++++++++++++----------------- 1 file changed, 218 insertions(+), 92 deletions(-) (limited to 'src/sqlcache.sml') 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)) = -- cgit v1.2.3