Mercurial > urweb

comparison src/sqlcache.sml @ 2264:bbcf9ba9b39a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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 =>