Mercurial > urweb
changeset 2294:f8903af753ff
Support nested queries but disable UrFlow for now.
| author | Ziv Scully <ziv@mit.edu> |
|---|---|
| date | Thu, 19 Nov 2015 01:59:00 -0500 |
| parents | 8be54d7bd06e |
| children | e6c5bb62fef8 |
| files | caching-tests/test.ur caching-tests/test.urp caching-tests/test.urs src/compiler.sig src/compiler.sml src/sources src/sql.sig src/sql.sml src/sqlcache.sml |
| diffstat | 9 files changed, 332 insertions(+), 170 deletions(-) [+] |
line wrap: on
line diff
--- a/caching-tests/test.ur Wed Nov 18 14:48:24 2015 -0500 +++ b/caching-tests/test.ur Thu Nov 19 01:59:00 2015 -0500 @@ -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 @@ | 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 @@ 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 *)
--- a/caching-tests/test.urp Wed Nov 18 14:48:24 2015 -0500 +++ b/caching-tests/test.urp Thu Nov 19 01:59:00 2015 -0500 @@ -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
--- a/caching-tests/test.urs Wed Nov 18 14:48:24 2015 -0500 +++ b/caching-tests/test.urs Thu Nov 19 01:59:00 2015 -0500 @@ -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 *)
--- a/src/compiler.sig Wed Nov 18 14:48:24 2015 -0500 +++ b/src/compiler.sig Thu Nov 19 01:59:00 2015 -0500 @@ -114,7 +114,7 @@ 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 @@ 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
--- a/src/compiler.sml Wed Nov 18 14:48:24 2015 -0500 +++ b/src/compiler.sml Thu Nov 19 01:59:00 2015 -0500 @@ -1372,19 +1372,21 @@ 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
--- a/src/sources Wed Nov 18 14:48:24 2015 -0500 +++ b/src/sources Thu Nov 19 01:59:00 2015 -0500 @@ -207,9 +207,6 @@ $(SRC)/fuse.sig $(SRC)/fuse.sml -$(SRC)/iflow.sig -$(SRC)/iflow.sml - $(SRC)/name_js.sig $(SRC)/name_js.sml
--- a/src/sql.sig Wed Nov 18 14:48:24 2015 -0500 +++ b/src/sql.sig Thu Nov 19 01:59:00 2015 -0500 @@ -81,12 +81,15 @@ 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
--- a/src/sql.sml Wed Nov 18 14:48:24 2015 -0500 +++ b/src/sql.sml Thu Nov 19 01:59:00 2015 -0500 @@ -382,48 +382,72 @@ (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) + +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 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 query = - Query1 of query1 - | Union of query * query - 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
--- a/src/sqlcache.sml Wed Nov 18 14:48:24 2015 -0500 +++ b/src/sqlcache.sml Thu Nov 19 01:59:00 2015 -0500 @@ -30,11 +30,18 @@ (* 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 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 @@ 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 @@ 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 @@ (* 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 mp = + 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 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 @@ 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 @@ | 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 @@ 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 @@ 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 @@ 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 @@ (* 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 @@ 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 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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)) =