Mercurial > urweb

comparison src/sqlcache.sml @ 2294:f8903af753ff

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Support nested queries but disable UrFlow for now.
author Ziv Scully <ziv@mit.edu>
date Thu, 19 Nov 2015 01:59:00 -0500
parents 50ad02829abd
children e6c5bb62fef8
comparison
equal deleted inserted replaced
2293:8be54d7bd06e 2294:f8903af753ff
28 28
29 fun mapFst f (x, y) = (f x, y) 29 fun mapFst f (x, y) = (f x, y)
30 30
31 (* Option monad. *) 31 (* Option monad. *)
32 fun obind (x, f) = Option.mapPartial f x 32 fun obind (x, f) = Option.mapPartial f x
33 fun oguard (b, x) = if b then x else NONE 33 fun oguard (b, x) = if b then x () else NONE
34 fun omap f = fn SOME x => SOME (f x) | _ => NONE 34 fun omap f = fn SOME x => SOME (f x) | _ => NONE
35 fun omap2 f = fn (SOME x, SOME y) => SOME (f (x,y)) | _ => NONE 35 fun omap2 f = fn (SOME x, SOME y) => SOME (f (x,y)) | _ => NONE
36 fun osequence ys = List.foldr (omap2 op::) (SOME []) ys 36 fun osequence ys = List.foldr (omap2 op::) (SOME []) ys
37
38 fun concatMap f xs = List.concat (map f xs)
39
40 val rec cartesianProduct : 'a list list -> 'a list list =
41 fn [] => [[]]
42 | (xs :: xss) => concatMap (fn ys => concatMap (fn x => [x :: ys]) xs)
43 (cartesianProduct xss)
37 44
38 fun indexOf test = 45 fun indexOf test =
39 let 46 let
40 fun f n = 47 fun f n =
41 fn [] => NONE 48 fn [] => NONE
102 | (env, MonoUtil.Exp.Datatype (x, n, cs)) => MonoEnv.pushDatatype env x n cs 109 | (env, MonoUtil.Exp.Datatype (x, n, cs)) => MonoEnv.pushDatatype env x n cs
103 110
104 val dummyLoc = ErrorMsg.dummySpan 111 val dummyLoc = ErrorMsg.dummySpan
105 112
106 (* DEBUG *) 113 (* DEBUG *)
107 fun printExp msg exp = Print.preface ("SQLCACHE: " ^ msg ^ ":", MonoPrint.p_exp MonoEnv.empty exp) 114 fun printExp msg exp =
108 fun printExp' msg exp' = printExp msg (exp', dummyLoc) 115 (Print.preface ("SQLCACHE: " ^ msg ^ ":", MonoPrint.p_exp MonoEnv.empty exp); exp)
109 fun printTyp msg typ = Print.preface ("SQLCACHE: " ^ msg ^ ":", MonoPrint.p_typ MonoEnv.empty typ) 116 fun printExp' msg exp' = (printExp msg (exp', dummyLoc); exp')
110 fun printTyp' msg typ' = printTyp msg (typ', dummyLoc) 117 fun printTyp msg typ =
118 (Print.preface ("SQLCACHE: " ^ msg ^ ":", MonoPrint.p_typ MonoEnv.empty typ); typ)
119 fun printTyp' msg typ' = (printTyp msg (typ', dummyLoc); typ')
111 fun obindDebug printer (x, f) = 120 fun obindDebug printer (x, f) =
112 case x of 121 case x of
113 NONE => NONE 122 NONE => NONE
114 | SOME x' => case f x' of 123 | SOME x' => case f x' of
115 NONE => (printer (); NONE) 124 NONE => (printer (); NONE)
202 Atom' of 'atom 211 Atom' of 'atom
203 | Combo' of junctionType * 'atom formula' list 212 | Combo' of junctionType * 'atom formula' list
204 213
205 val flipJt = fn Conj => Disj | Disj => Conj 214 val flipJt = fn Conj => Disj | Disj => Conj
206 215
207 fun concatMap f xs = List.concat (map f xs)
208
209 val rec cartesianProduct : 'a list list -> 'a list list =
210 fn [] => [[]]
211 | (xs :: xss) => concatMap (fn ys => concatMap (fn x => [x :: ys]) xs)
212 (cartesianProduct xss)
213
214 (* Pushes all negation to the atoms.*) 216 (* Pushes all negation to the atoms.*)
215 fun pushNegate (normalizeAtom : bool * 'atom -> 'atom) (negating : bool) = 217 fun pushNegate (normalizeAtom : bool * 'atom -> 'atom) (negating : bool) =
216 fn Atom x => Atom' (normalizeAtom (negating, x)) 218 fn Atom x => Atom' (normalizeAtom (negating, x))
217 | Negate f => pushNegate normalizeAtom (not negating) f 219 | Negate f => pushNegate normalizeAtom (not negating) f
218 | Combo (j, fs) => Combo' (if negating then flipJt j else j, 220 | Combo (j, fs) => Combo' (if negating then flipJt j else j,
347 end 349 end
348 350
349 structure AtomOptionKey = OptionKeyFn(AtomExpKey) 351 structure AtomOptionKey = OptionKeyFn(AtomExpKey)
350 352
351 val rec tablesOfQuery = 353 val rec tablesOfQuery =
352 fn Sql.Query1 {From = tablePairs, ...} => SS.fromList (map #1 tablePairs) 354 fn Sql.Query1 {From = fitems, ...} => List.foldl SS.union SS.empty (map tableOfFitem fitems)
353 | Sql.Union (q1, q2) => SS.union (tablesOfQuery q1, tablesOfQuery q2) 355 | Sql.Union (q1, q2) => SS.union (tablesOfQuery q1, tablesOfQuery q2)
356 and tableOfFitem =
357 fn Sql.Table (t, _) => SS.singleton t
358 | Sql.Nested (q, _) => tablesOfQuery q
359 | Sql.Join (_, f1, f2, _) => SS.union (tableOfFitem f1, tableOfFitem f2)
354 360
355 val tableOfDml = 361 val tableOfDml =
356 fn Sql.Insert (tab, _) => tab 362 fn Sql.Insert (tab, _) => tab
357 | Sql.Delete (tab, _) => tab 363 | Sql.Delete (tab, _) => tab
358 | Sql.Update (tab, _, _) => tab 364 | Sql.Update (tab, _, _) => tab
487 (* Traversal Utilities *) 493 (* Traversal Utilities *)
488 (* TODO: get rid of unused ones. *) 494 (* TODO: get rid of unused ones. *)
489 495
490 (* Need lift', etc. because we don't have rank-2 polymorphism. This should 496 (* Need lift', etc. because we don't have rank-2 polymorphism. This should
491 probably use a functor (an ML one, not Haskell) but works for now. *) 497 probably use a functor (an ML one, not Haskell) but works for now. *)
492 fun traverseSqexp (pure, _, lift, _, lift'', lift2, _) f = 498 fun traverseSqexp (pure, _, _, _, lift, lift', _, _, lift2, _, _, _, _, _) f =
493 let 499 let
494 val rec tr = 500 val rec tr =
495 fn Sql.SqNot se => lift Sql.SqNot (tr se) 501 fn Sql.SqNot se => lift Sql.SqNot (tr se)
496 | Sql.Binop (r, se1, se2) => 502 | Sql.Binop (r, se1, se2) =>
497 lift2 (fn (trse1, trse2) => Sql.Binop (r, trse1, trse2)) (tr se1, tr se2) 503 lift2 (fn (trse1, trse2) => Sql.Binop (r, trse1, trse2)) (tr se1, tr se2)
498 | Sql.SqKnown se => lift Sql.SqKnown (tr se) 504 | Sql.SqKnown se => lift Sql.SqKnown (tr se)
499 | Sql.Inj (e', loc) => lift'' (fn fe' => Sql.Inj (fe', loc)) (f e') 505 | Sql.Inj (e', loc) => lift' (fn fe' => Sql.Inj (fe', loc)) (f e')
500 | Sql.SqFunc (s, se) => lift (fn trse => Sql.SqFunc (s, trse)) (tr se) 506 | Sql.SqFunc (s, se) => lift (fn trse => Sql.SqFunc (s, trse)) (tr se)
501 | se => pure se 507 | se => pure se
502 in 508 in
503 tr 509 tr
504 end 510 end
505 511
506 fun traverseQuery (ops as (_, pure', _, lift', _, _, lift2')) f = 512 fun traverseFitem (ops as (_, _, _, pure''', _, _, _, lift''', _, _, _, _, lift2'''', lift2''''')) f =
507 let 513 let
508 val rec mp = 514 val rec tr =
515 fn Sql.Table t => pure''' (Sql.Table t)
516 | Sql.Join (jt, fi1, fi2, se) =>
517 lift2'''' (fn ((trfi1, trfi2), trse) => Sql.Join (jt, trfi1, trfi2, trse))
518 (lift2''''' id (tr fi1, tr fi2), traverseSqexp ops f se)
519 | Sql.Nested (q, s) => lift''' (fn trq => Sql.Nested (trq, s))
520 (traverseQuery ops f q)
521 in
522 tr
523 end
524
525 and traverseQuery (ops as (_, pure', pure'', _, _, _, lift'', _, _, lift2', lift2'', lift2''', _, _)) f =
526 let
527 val rec seqList =
528 fn [] => pure'' []
529 | (x::xs) => lift2''' op:: (x, seqList xs)
530 val rec tr =
509 fn Sql.Query1 q => 531 fn Sql.Query1 q =>
510 (case #Where q of 532 (* TODO: make sure we don't need to traverse [#Select q]. *)
511 NONE => pure' (Sql.Query1 q) 533 lift2' (fn (trfrom, trwher) => Sql.Query1 {Select = #Select q,
512 | SOME se => 534 From = trfrom,
513 lift' (fn mpse => Sql.Query1 {Select = #Select q, 535 Where = trwher})
514 From = #From q, 536 (seqList (map (traverseFitem ops f) (#From q)),
515 Where = SOME mpse}) 537 case #Where q of
516 (traverseSqexp ops f se)) 538 NONE => pure' NONE
517 | Sql.Union (q1, q2) => lift2' Sql.Union (mp q1, mp q2) 539 | SOME se => lift'' SOME (traverseSqexp ops f se))
540 | Sql.Union (q1, q2) => lift2'' Sql.Union (tr q1, tr q2)
518 in 541 in
519 mp 542 tr
520 end 543 end
521 544
522 (* Include unused tuple elements in argument for convenience of using same 545 (* Include unused tuple elements in argument for convenience of using same
523 argument as [traverseQuery]. *) 546 argument as [traverseQuery]. *)
524 fun traverseIM (pure, _, _, _, _, lift2, _) f = 547 fun traverseIM (pure, _, _, _, _, _, _, _, _, lift2, _, _, _, _) f =
525 IM.foldli (fn (k, v, acc) => lift2 (fn (acc, w) => IM.insert (acc, k, w)) (acc, f (k,v))) 548 IM.foldli (fn (k, v, acc) => lift2 (fn (acc, w) => IM.insert (acc, k, w)) (acc, f (k,v)))
526 (pure IM.empty) 549 (pure IM.empty)
527 550
528 fun traverseSubst (ops as (_, pure', lift, _, _, _, lift2')) f = 551 fun traverseSubst (ops as (_, pure', _, _, lift, _, _, _, _, lift2', _, _, _, _)) f =
529 let 552 let
530 fun mp ((n, fields), sqlify) = 553 fun mp ((n, fields), sqlify) =
531 lift (fn ((n', fields'), sqlify') => 554 lift (fn ((n', fields'), sqlify') =>
532 let 555 let
533 fun wrap sq = ((n', fields' @ fields), sq) 556 fun wrap sq = ((n', fields' @ fields), sq)
544 (f n) 567 (f n)
545 in 568 in
546 traverseIM ops (fn (_, v) => mp v) 569 traverseIM ops (fn (_, v) => mp v)
547 end 570 end
548 571
549 fun monoidOps plus zero = (fn _ => zero, fn _ => zero, 572 fun monoidOps plus zero =
550 fn _ => fn x => x, fn _ => fn x => x, fn _ => fn x => x, 573 (fn _ => zero, fn _ => zero, fn _ => zero, fn _ => zero,
551 fn _ => plus, fn _ => plus) 574 fn _ => fn x => x, fn _ => fn x => x, fn _ => fn x => x, fn _ => fn x => x,
552 575 fn _ => plus, fn _ => plus, fn _ => plus, fn _ => plus, fn _ => plus, fn _ => plus)
553 val optionOps = (SOME, SOME, omap, omap, omap, omap2, omap2) 576
577 val optionOps = (SOME, SOME, SOME, SOME,
578 omap, omap, omap, omap,
579 omap2, omap2, omap2, omap2, omap2, omap2)
554 580
555 fun foldMapQuery plus zero = traverseQuery (monoidOps plus zero) 581 fun foldMapQuery plus zero = traverseQuery (monoidOps plus zero)
556 val omapQuery = traverseQuery optionOps 582 val omapQuery = traverseQuery optionOps
557 fun foldMapIM plus zero = traverseIM (monoidOps plus zero) 583 fun foldMapIM plus zero = traverseIM (monoidOps plus zero)
558 fun omapIM f = traverseIM optionOps f 584 fun omapIM f = traverseIM optionOps f
725 | Sql.SqFunc _ => raise Fail "Sqlcache: sqexpToFormula (SqFunc)" 751 | Sql.SqFunc _ => raise Fail "Sqlcache: sqexpToFormula (SqFunc)"
726 | Sql.Unmodeled => raise Fail "Sqlcache: sqexpToFormula (Unmodeled)" 752 | Sql.Unmodeled => raise Fail "Sqlcache: sqexpToFormula (Unmodeled)"
727 | Sql.Null => raise Fail "Sqlcache: sqexpToFormula (Null)" 753 | Sql.Null => raise Fail "Sqlcache: sqexpToFormula (Null)"
728 754
729 fun mapSqexpFields f = 755 fun mapSqexpFields f =
730 fn Sql.Field (t, v) => f (t, v) 756 fn Sql.Field (t, v) => f (t, v)
731 | Sql.SqNot e => Sql.SqNot (mapSqexpFields f e) 757 | Sql.SqNot e => Sql.SqNot (mapSqexpFields f e)
732 | Sql.Binop (r, e1, e2) => Sql.Binop (r, mapSqexpFields f e1, mapSqexpFields f e2) 758 | Sql.Binop (r, e1, e2) => Sql.Binop (r, mapSqexpFields f e1, mapSqexpFields f e2)
733 | Sql.SqKnown e => Sql.SqKnown (mapSqexpFields f e) 759 | Sql.SqKnown e => Sql.SqKnown (mapSqexpFields f e)
734 | Sql.SqFunc (s, e) => Sql.SqFunc (s, mapSqexpFields f e) 760 | Sql.SqFunc (s, e) => Sql.SqFunc (s, mapSqexpFields f e)
735 | e => e 761 | e => e
742 | SOME (realTable, _) => realTable 768 | SOME (realTable, _) => realTable
743 in 769 in
744 mapSqexpFields (fn (t, f) => Sql.Field (rename t, f)) 770 mapSqexpFields (fn (t, f) => Sql.Field (rename t, f))
745 end 771 end
746 772
747 fun queryToFormula marker = 773 structure FlattenQuery = struct
748 fn Sql.Query1 {Select = sitems, From = tablePairs, Where = wher} => 774
749 let 775 datatype substitution = RenameTable of string | SubstituteExp of Sql.sqexp SM.map
750 val fWhere = case wher of 776
751 NONE => Combo (Conj, []) 777 fun applySubst substTable =
752 | SOME e => sqexpToFormula (renameTables tablePairs e) 778 let
779 fun substitute (table, field) =
780 case SM.find (substTable, table) of
781 NONE => Sql.Field (table, field)
782 | SOME (RenameTable realTable) => Sql.Field (realTable, field)
783 | SOME (SubstituteExp substField) =>
784 case SM.find (substField, field) of
785 NONE => raise Fail "Sqlcache: applySubst"
786 | SOME se => se
787 in
788 mapSqexpFields substitute
789 end
790
791 fun addToSubst (substTable, table, substField) =
792 SM.insert (substTable,
793 table,
794 case substField of
795 RenameTable _ => substField
796 | SubstituteExp subst => SubstituteExp (SM.map (applySubst substTable) subst))
797
798 fun newSubst (t, s) = addToSubst (SM.empty, t, s)
799
800 datatype sitem' = Named of Sql.sqexp * string | Unnamed of Sql.sqexp
801
802 type queryFlat = {Select : sitem' list, Where : Sql.sqexp}
803
804 val sitemsToSubst =
805 List.foldl (fn (Named (se, s), acc) => SM.insert (acc, s, se)
806 | (Unnamed _, _) => raise Fail "Sqlcache: sitemsToSubst")
807 SM.empty
808
809 fun unionSubst (s1, s2) = SM.unionWith (fn _ => raise Fail "Sqlcache: unionSubst") (s1, s2)
810
811 fun sqlAnd (se1, se2) = Sql.Binop (Sql.RLop Sql.And, se1, se2)
812
813 val rec flattenFitem : Sql.fitem -> (Sql.sqexp * substitution SM.map) list =
814 fn Sql.Table (real, alias) => [(Sql.SqTrue, newSubst (alias, RenameTable real))]
815 | Sql.Nested (q, s) =>
816 let
817 val qfs = flattenQuery q
818 in
819 map (fn (qf, subst) =>
820 (#Where qf, addToSubst (subst, s, SubstituteExp (sitemsToSubst (#Select qf)))))
821 qfs
822 end
823 | Sql.Join (jt, fi1, fi2, se) =>
824 concatMap (fn ((wher1, subst1)) =>
825 map (fn (wher2, subst2) =>
826 (sqlAnd (wher1, wher2),
827 (* There should be no name conflicts... Ziv hopes? *)
828 unionSubst (subst1, subst2)))
829 (flattenFitem fi2))
830 (flattenFitem fi1)
831
832 and flattenQuery : Sql.query -> (queryFlat * substitution SM.map) list =
833 fn Sql.Query1 q =>
834 let
835 val fifss = cartesianProduct (map flattenFitem (#From q))
836 in
837 map (fn fifs =>
838 let
839 val subst = List.foldl (fn ((_, subst), acc) => unionSubst (acc, subst))
840 SM.empty
841 fifs
842 val wher = List.foldr (fn ((wher, _), acc) => sqlAnd (wher, acc))
843 (case #Where q of
844 NONE => Sql.SqTrue
845 | SOME wher => wher)
846 fifs
847 in
848 (* ASK: do we actually need to pass the substitution through here? *)
849 (* We use the substitution later, but it's not clear we
850 need any of its currently present fields again. *)
851 ({Select = map (fn Sql.SqExp (se, s) => Named (applySubst subst se, s)
852 | Sql.SqField tf =>
853 Unnamed (applySubst subst (Sql.Field tf)))
854 (#Select q),
855 Where = applySubst subst wher},
856 subst)
857 end)
858 fifss
859 end
860 | Sql.Union (q1, q2) => (flattenQuery q1) @ (flattenQuery q2)
861
862 end
863
864 val flattenQuery = map #1 o FlattenQuery.flattenQuery
865
866 fun queryFlatToFormula marker {Select = sitems, Where = wher} =
867 let
868 val fWhere = sqexpToFormula wher
753 in 869 in
754 case marker of 870 case marker of
755 NONE => fWhere 871 NONE => fWhere
756 | SOME markFields => 872 | SOME markFields =>
757 let 873 let
758 val fWhereMarked = mapFormulaExps markFields fWhere 874 val fWhereMarked = mapFormulaExps markFields fWhere
759 val toSqexp = 875 val toSqexp =
760 fn Sql.SqField tf => Sql.Field tf 876 fn FlattenQuery.Named (se, _) => se
761 | Sql.SqExp (se, _) => se 877 | FlattenQuery.Unnamed se => se
762 fun ineq se = Atom (Sql.Ne, se, markFields se) 878 fun ineq se = Atom (Sql.Ne, se, markFields se)
763 val fIneqs = Combo (Disj, map (ineq o renameTables tablePairs o toSqexp) sitems) 879 val fIneqs = Combo (Disj, map (ineq o toSqexp) sitems)
764 in 880 in
765 (Combo (Conj, 881 (Combo (Conj,
766 [fWhere, 882 [fWhere,
767 Combo (Disj, 883 Combo (Disj,
768 [Negate fWhereMarked, 884 [Negate fWhereMarked,
769 Combo (Conj, [fWhereMarked, fIneqs])])])) 885 Combo (Conj, [fWhereMarked, fIneqs])])]))
770 end 886 end
771 end 887 end
772 | Sql.Union (q1, q2) => Combo (Disj, [queryToFormula marker q1, queryToFormula marker q2]) 888
889 fun queryToFormula marker q = Combo (Disj, map (queryFlatToFormula marker) (flattenQuery q))
773 890
774 fun valsToFormula (markLeft, markRight) (table, vals) = 891 fun valsToFormula (markLeft, markRight) (table, vals) =
775 Combo (Conj, 892 Combo (Conj,
776 map (fn (field, v) => Atom (Sql.Eq, markLeft (Sql.Field (table, field)), markRight v)) 893 map (fn (field, v) => Atom (Sql.Eq, markLeft (Sql.Field (table, field)), markRight v))
777 vals) 894 vals)
826 fn (cmp, SOME ae1, SOME ae2) => (cmp = Sql.Ne orelse cmp = Sql.Lt orelse cmp = Sql.Gt) 943 fn (cmp, SOME ae1, SOME ae2) => (cmp = Sql.Ne orelse cmp = Sql.Lt orelse cmp = Sql.Gt)
827 andalso UF.together (uf, ae1, ae2) 944 andalso UF.together (uf, ae1, ae2)
828 (* If we don't know one side of the comparision, not a contradiction. *) 945 (* If we don't know one side of the comparision, not a contradiction. *)
829 | _ => false 946 | _ => false
830 in 947 in
831 not (List.exists contradiction atoms) <\oguard\> SOME (UF.classes uf) 948 not (List.exists contradiction atoms) <\oguard\> (fn _ => SOME (UF.classes uf))
832 end 949 end
833 950
834 fun addToEqs (eqs, n, e) = 951 fun addToEqs (eqs, n, e) =
835 case IM.find (eqs, n) of 952 case IM.find (eqs, n) of
836 (* Comparing to a constant is probably better than comparing to a 953 (* Comparing to a constant is probably better than comparing to a
904 val markDml : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula -> 1021 val markDml : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula ->
905 (Sql.cmp * atomExp option * atomExp option) formula = 1022 (Sql.cmp * atomExp option * atomExp option) formula =
906 mapFormula (toAtomExps DmlRel) 1023 mapFormula (toAtomExps DmlRel)
907 1024
908 (* No eqs should have key conflicts because no variable is in two 1025 (* No eqs should have key conflicts because no variable is in two
909 equivalence classes, so the [#1] could be [#2]. *) 1026 equivalence classes. *)
910 val mergeEqs : (atomExp IntBinaryMap.map option list 1027 val mergeEqs : (atomExp IntBinaryMap.map option list
911 -> atomExp IntBinaryMap.map option) = 1028 -> atomExp IntBinaryMap.map option) =
912 List.foldr (omap2 (IM.unionWith #1)) (SOME IM.empty) 1029 List.foldr (omap2 (IM.unionWith (fn _ => raise Fail "Sqlcache: ConflictMaps.mergeEqs")))
1030 (SOME IM.empty)
913 1031
914 val simplify = 1032 val simplify =
915 map TS.listItems 1033 map TS.listItems
916 o removeRedundant (fn (x, y) => TS.isSubset (y, x)) 1034 o removeRedundant (fn (x, y) => TS.isSubset (y, x))
917 o map (fn xs => TS.addList (TS.empty, xs)) 1035 o map (fn xs => TS.addList (TS.empty, xs))
1006 | Search.Return _ => raise Fail "Sqlcache: fileAllMapfoldB" 1124 | Search.Return _ => raise Fail "Sqlcache: fileAllMapfoldB"
1007 1125
1008 fun fileMap doExp file = #1 (fileAllMapfoldB (fn _ => fn e => fn _ => (doExp e, ())) file ()) 1126 fun fileMap doExp file = #1 (fileAllMapfoldB (fn _ => fn e => fn _ => (doExp e, ())) file ())
1009 1127
1010 (* TODO: make this a bit prettier.... *) 1128 (* TODO: make this a bit prettier.... *)
1129 (* TODO: factour out identical subexpressions to the same variable.... *)
1011 val simplifySql = 1130 val simplifySql =
1012 let 1131 let
1013 fun factorOutNontrivial text = 1132 fun factorOutNontrivial text =
1014 let 1133 let
1015 val loc = dummyLoc 1134 val loc = dummyLoc
1016 fun strcat (e1, e2) = (EStrcat (e1, e2), loc) 1135 val strcat =
1136 fn (e1, (EPrim (Prim.String (Prim.Normal, "")), _)) => e1
1137 | ((EPrim (Prim.String (Prim.Normal, "")), _), e2) => e2
1138 | (e1, e2) => (EStrcat (e1, e2), loc)
1017 val chunks = Sql.chunkify text 1139 val chunks = Sql.chunkify text
1018 val (newText, newVariables) = 1140 val (newText, newVariables) =
1019 (* Important that this is foldr (to oppose foldl below). *) 1141 (* Important that this is foldr (to oppose foldl below). *)
1020 List.foldr 1142 List.foldr
1021 (fn (chunk, (qText, newVars)) => 1143 (fn (chunk, (qText, newVars)) =>
1191 getAlwaysConsolidate () 1313 getAlwaysConsolidate ()
1192 orelse not (List.exists isAsIs args andalso List.exists (not o isAsIs) args) 1314 orelse not (List.exists isAsIs args andalso List.exists (not o isAsIs) args)
1193 end 1315 end
1194 1316
1195 fun cacheExp (env, exp', invalInfo, state : state) = 1317 fun cacheExp (env, exp', invalInfo, state : state) =
1196 case worthCaching exp' <\oguard\> typOfExp' env exp' of 1318 case worthCaching exp' <\oguard\> (fn _ => typOfExp' env exp') of
1197 NONE => NONE 1319 NONE => NONE
1198 | SOME (TFun _, _) => NONE 1320 | SOME (TFun _, _) => NONE
1199 | SOME typ => 1321 | SOME typ =>
1200 let 1322 let
1201 val args = InvalInfo.orderArgs (invalInfo, (exp', dummyLoc)) 1323 val args = InvalInfo.orderArgs (invalInfo, (exp', dummyLoc))
1202 in 1324 in
1203 shouldConsolidate args 1325 shouldConsolidate args
1204 <\oguard\> 1326 <\oguard\>
1205 List.foldr (fn (arg, acc) => 1327 (fn _ =>
1206 acc 1328 List.foldr (fn (arg, acc) =>
1207 <\obind\> 1329 acc
1208 (fn args' => 1330 <\obind\>
1209 (case arg of 1331 (fn args' =>
1210 AsIs exp => SOME exp 1332 (case arg of
1211 | Urlify exp => 1333 AsIs exp => SOME exp
1212 typOfExp env exp 1334 | Urlify exp =>
1213 <\obind\> 1335 typOfExp env exp
1214 (fn typ => (MonoFooify.urlify env (exp, typ)))) 1336 <\obind\>
1215 <\obind\> 1337 (fn typ => (MonoFooify.urlify env (exp, typ))))
1216 (fn arg' => SOME (arg' :: args')))) 1338 <\obind\>
1217 (SOME []) 1339 (fn arg' => SOME (arg' :: args'))))
1218 args 1340 (SOME [])
1219 <\obind\> 1341 args
1220 (fn args' =>
1221 cacheWrap (env, (exp', dummyLoc), typ, args', #index state)
1222 <\obind\> 1342 <\obind\>
1223 (fn cachedExp => 1343 (fn args' =>
1224 SOME (cachedExp, InvalInfo.updateState (invalInfo, length args', state)))) 1344 cacheWrap (env, (exp', dummyLoc), typ, args', #index state)
1345 <\obind\>
1346 (fn cachedExp =>
1347 SOME (cachedExp,
1348 InvalInfo.updateState (invalInfo, length args', state)))))
1225 end 1349 end
1226 1350
1227 fun cacheQuery (effs, env, q) : subexp = 1351 fun cacheQuery (effs, env, q) : subexp =
1228 let 1352 let
1229 (* We use dummyTyp here. I think this is okay because databases don't 1353 (* We use dummyTyp here. I think this is okay because databases don't
1236 bound 1360 bound
1237 env) 1361 env)
1238 val {query = queryText, initial, body, ...} = q 1362 val {query = queryText, initial, body, ...} = q
1239 val attempt = 1363 val attempt =
1240 (* Ziv misses Haskell's do notation.... *) 1364 (* Ziv misses Haskell's do notation.... *)
1241 (safe 0 queryText andalso safe 0 initial andalso safe 2 body) 1365 (safe 0 (printExp "attempt" queryText) andalso safe 0 initial andalso safe 2 body)
1242 <\oguard\> 1366 <\oguard\>
1243 Sql.parse Sql.query queryText 1367 (fn _ =>
1244 <\obind\> 1368 Sql.parse Sql.query (printExp "safe" queryText)
1245 (fn queryParsed => 1369 <\obind\>
1246 let 1370 (fn queryParsed =>
1247 val invalInfo = InvalInfo.singleton queryParsed 1371 let
1248 fun mkExp state = 1372 val _ = (printExp "parsed" queryText)
1249 case cacheExp (env, EQuery q, invalInfo, state) of 1373 val invalInfo = InvalInfo.singleton queryParsed
1250 NONE => ((EQuery q, dummyLoc), state) 1374 fun mkExp state =
1251 | SOME (cachedExp, state) => ((cachedExp, dummyLoc), state) 1375 case cacheExp (env, EQuery q, invalInfo, state) of
1252 in 1376 NONE => ((EQuery q, dummyLoc), state)
1253 SOME (Cachable (invalInfo, mkExp)) 1377 | SOME (cachedExp, state) => ((cachedExp, dummyLoc), state)
1254 end) 1378 in
1379 SOME (Cachable (invalInfo, mkExp))
1380 end))
1255 in 1381 in
1256 case attempt of 1382 case attempt of
1257 NONE => Impure (EQuery q, dummyLoc) 1383 NONE => Impure (EQuery q, dummyLoc)
1258 | SOME subexp => subexp 1384 | SOME subexp => subexp
1259 end 1385 end
1277 (ListPair.map 1403 (ListPair.map
1278 (fn (subexp, (_, unbinds)) => 1404 (fn (subexp, (_, unbinds)) =>
1279 InvalInfo.unbind (invalInfoOfSubexp subexp, unbinds)) 1405 InvalInfo.unbind (invalInfoOfSubexp subexp, unbinds))
1280 (subexps, args))) 1406 (subexps, args)))
1281 <\obind\> 1407 <\obind\>
1282 (fn invalInfo => 1408 (fn invalInfo =>
1283 SOME (Cachable (invalInfo, 1409 SOME (Cachable (invalInfo,
1284 fn state => 1410 fn state =>
1285 case cacheExp (env, 1411 case cacheExp (env,
1286 f (map (#2 o #1) args), 1412 f (map (#2 o #1) args),
1287 invalInfo, 1413 invalInfo,
1288 state) of 1414 state) of
1289 NONE => mkExp state 1415 NONE => mkExp state
1290 | SOME (e', state) => ((e', loc), state)), 1416 | SOME (e', state) => ((e', loc), state)),
1291 state)) 1417 state))
1292 in 1418 in
1293 case attempt of 1419 case attempt of
1294 SOME (subexp, state) => (subexp, state) 1420 SOME (subexp, state) => (subexp, state)
1295 | NONE => mapFst Impure (mkExp state) 1421 | NONE => mapFst Impure (mkExp state)
1296 end 1422 end
1382 | SOME e => (ESome (stringTyp, 1508 | SOME e => (ESome (stringTyp,
1383 (case e of 1509 (case e of
1384 DmlRel n => ERel n 1510 DmlRel n => ERel n
1385 | Prim p => EPrim p 1511 | Prim p => EPrim p
1386 (* TODO: make new type containing only these two. *) 1512 (* TODO: make new type containing only these two. *)
1387 | _ => raise Fail "Sqlcache: optionAtomExpToExp", 1513 | _ => raise Fail "Sqlcache: Invalidations.optionAtomExpToExp",
1388 loc)), 1514 loc)),
1389 loc) 1515 loc)
1390 1516
1391 fun eqsToInvalidation numArgs eqs = 1517 fun eqsToInvalidation numArgs eqs =
1392 List.tabulate (numArgs, (fn n => IM.find (eqs, n))) 1518 List.tabulate (numArgs, (fn n => IM.find (eqs, n)))
1504 @ map (fn i => (i, false)) (IS.listItems (IS.difference (store, flush))) 1630 @ map (fn i => (i, false)) (IS.listItems (IS.difference (store, flush)))
1505 in 1631 in
1506 ListMergeSort.sort (fn ((i, _), (j, _)) => i > j) ls 1632 ListMergeSort.sort (fn ((i, _), (j, _)) => i > j) ls
1507 end 1633 end
1508 fun locksOfName n = 1634 fun locksOfName n =
1509 lockList {store = IIMM.findSet (#flush lockMap, n), 1635 lockList {flush = IIMM.findSet (#flush lockMap, n),
1510 flush =IIMM.findSet (#store lockMap, n)} 1636 store = IIMM.findSet (#store lockMap, n)}
1511 val locksOfExp = lockList o locksNeeded lockMap 1637 val locksOfExp = lockList o locksNeeded lockMap
1512 val expts = exports file 1638 val expts = exports file
1513 fun doVal (v as (x, n, t, exp, s)) = 1639 fun doVal (v as (x, n, t, exp, s)) =
1514 if IS.member (expts, n) 1640 if IS.member (expts, n)
1515 then (x, n, t, wrapLocks ((locksOfName n), exp), s) 1641 then (x, n, t, wrapLocks ((locksOfName n), exp), s)