Mercurial > urweb
comparison src/sqlcache.sml @ 2264:bbcf9ba9b39a
Fix another mismatch between expunger SQL generation and SQL parser.
author | Ziv Scully <ziv@mit.edu> |
---|---|
date | Tue, 13 Oct 2015 20:24:37 -0400 |
parents | 34ad83d9b729 |
children | a647a1560628 |
comparison
equal
deleted
inserted
replaced
2263:dfadb5effdc0 | 2264:bbcf9ba9b39a |
---|---|
602 val numArgs = length newVariables | 602 val numArgs = length newVariables |
603 in | 603 in |
604 (newText, wrapLets, numArgs) | 604 (newText, wrapLets, numArgs) |
605 end | 605 end |
606 | 606 |
607 fun cacheQuery effs env (queryInfo as (tableToIndices, indexToQueryNumArgs, index)) = | |
608 fn e' as EQuery {query = origQueryText, | |
609 state = resultTyp, | |
610 initial, body, tables, exps} => | |
611 let | |
612 val (newQueryText, wrapLets, numArgs) = factorOutNontrivial origQueryText | |
613 (* Increment once for each new variable just made. *) | |
614 val queryExp = incRels numArgs | |
615 (EQuery {query = newQueryText, | |
616 state = resultTyp, | |
617 initial = initial, | |
618 body = body, | |
619 tables = tables, | |
620 exps = exps}, | |
621 dummyLoc) | |
622 (* DEBUG *) | |
623 (* val () = Print.preface ("sqlcache> ", MonoPrint.p_exp MonoEnv.empty queryText) *) | |
624 val args = List.tabulate (numArgs, fn n => (ERel n, dummyLoc)) | |
625 fun bind x f = Option.mapPartial f x | |
626 fun guard b x = if b then x else NONE | |
627 (* We use dummyTyp here. I think this is okay because databases don't | |
628 store (effectful) functions, but perhaps there's some pathalogical | |
629 corner case missing.... *) | |
630 fun safe bound = | |
631 not | |
632 o effectful effs | |
633 (iterate (fn env => MonoEnv.pushERel env "_" dummyTyp NONE) | |
634 bound | |
635 env) | |
636 val textOfQuery = fn (EQuery {query, ...}, _) => SOME query | _ => NONE | |
637 val attempt = | |
638 (* Ziv misses Haskell's do notation.... *) | |
639 bind (textOfQuery queryExp) (fn queryText => | |
640 guard (safe 0 queryText andalso safe 0 initial andalso safe 2 body) ( | |
641 bind (Sql.parse Sql.query queryText) (fn queryParsed => | |
642 bind (cacheWrap (env, queryExp, resultTyp, args, index)) (fn cachedExp => | |
643 SOME (wrapLets cachedExp, | |
644 (SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, index)) | |
645 tableToIndices | |
646 (tablesQuery queryParsed), | |
647 IM.insert (indexToQueryNumArgs, index, (queryParsed, numArgs)), | |
648 index + 1)))))) | |
649 in | |
650 case attempt of | |
651 SOME pair => pair | |
652 (* We have to increment index conservatively. *) | |
653 (* TODO: just use a reference for current index.... *) | |
654 | NONE => (e', (tableToIndices, indexToQueryNumArgs, index + 1)) | |
655 end | |
656 | e' => (e', queryInfo) | |
657 | |
607 fun addChecking file = | 658 fun addChecking file = |
608 let | 659 let |
609 val effs = effectfulDecls file | 660 val effs = effectfulDecls file |
610 fun doExp env (queryInfo as (tableToIndices, indexToQueryNumArgs, index)) = | 661 in |
611 fn e' as EQuery {query = origQueryText, | 662 (fileAllMapfoldB (fn env => fn exp => fn state => cacheQuery effs env state exp) |
612 state = resultTyp, | 663 file |
613 initial, body, tables, exps} => | 664 (SIMM.empty, IM.empty, 0), |
614 let | |
615 val (newQueryText, wrapLets, numArgs) = factorOutNontrivial origQueryText | |
616 (* Increment once for each new variable just made. *) | |
617 val queryExp = incRels numArgs | |
618 (EQuery {query = newQueryText, | |
619 state = resultTyp, | |
620 initial = initial, | |
621 body = body, | |
622 tables = tables, | |
623 exps = exps}, | |
624 dummyLoc) | |
625 val (EQuery {query = queryText, ...}, _) = queryExp | |
626 (* DEBUG *) | |
627 (* val () = Print.preface ("sqlcache> ", MonoPrint.p_exp MonoEnv.empty queryText) *) | |
628 val args = List.tabulate (numArgs, fn n => (ERel n, dummyLoc)) | |
629 fun bind x f = Option.mapPartial f x | |
630 fun guard b x = if b then x else NONE | |
631 (* We use dummyTyp here. I think this is okay because databases | |
632 don't store (effectful) functions, but perhaps there's some | |
633 pathalogical corner case missing.... *) | |
634 fun safe bound = | |
635 not | |
636 o effectful effs | |
637 (iterate (fn env => MonoEnv.pushERel env "_" dummyTyp NONE) | |
638 bound | |
639 env) | |
640 val attempt = | |
641 (* Ziv misses Haskell's do notation.... *) | |
642 guard (safe 0 queryText andalso safe 0 initial andalso safe 2 body) ( | |
643 bind (Sql.parse Sql.query queryText) (fn queryParsed => | |
644 bind (cacheWrap (env, queryExp, resultTyp, args, index)) (fn cachedExp => | |
645 SOME (wrapLets cachedExp, | |
646 (SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, index)) | |
647 tableToIndices | |
648 (tablesQuery queryParsed), | |
649 IM.insert (indexToQueryNumArgs, index, (queryParsed, numArgs)), | |
650 index + 1))))) | |
651 in | |
652 case attempt of | |
653 SOME pair => pair | |
654 (* We have to increment index conservatively. *) | |
655 (* TODO: just use a reference for current index.... *) | |
656 | NONE => (e', (tableToIndices, indexToQueryNumArgs, index + 1)) | |
657 end | |
658 | e' => (e', queryInfo) | |
659 in | |
660 (fileAllMapfoldB (fn env => fn exp => fn state => doExp env state exp) | |
661 file | |
662 (SIMM.empty, IM.empty, 0), | |
663 effs) | 665 effs) |
664 end | 666 end |
665 | 667 |
666 structure Invalidations = struct | 668 structure Invalidations = struct |
667 | 669 |
723 (* val () = gunk' := origDmlText :: !gunk' *) | 725 (* val () = gunk' := origDmlText :: !gunk' *) |
724 val (newDmlText, wrapLets, numArgs) = factorOutNontrivial origDmlText | 726 val (newDmlText, wrapLets, numArgs) = factorOutNontrivial origDmlText |
725 val dmlText = incRels numArgs newDmlText | 727 val dmlText = incRels numArgs newDmlText |
726 val dmlExp = EDml (dmlText, failureMode) | 728 val dmlExp = EDml (dmlText, failureMode) |
727 (* DEBUG *) | 729 (* DEBUG *) |
728 (* val () = Print.preface ("SQLCACHE: ", (MonoPrint.p_exp MonoEnv.empty origDmlText)) *) | 730 val () = Print.preface ("SQLCACHE: ", (MonoPrint.p_exp MonoEnv.empty origDmlText)) |
729 val inval = | 731 val inval = |
730 case Sql.parse Sql.dml dmlText of | 732 case Sql.parse Sql.dml dmlText of |
731 SOME dmlParsed => | 733 SOME dmlParsed => |
732 SOME (map (fn i => (case IM.find (indexToQueryNumArgs, i) of | 734 SOME (map (fn i => (case IM.find (indexToQueryNumArgs, i) of |
733 SOME queryNumArgs => | 735 SOME queryNumArgs => |