summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Ziv Scully <ziv@mit.edu>2015-10-13 20:24:37 -0400
committerGravatar Ziv Scully <ziv@mit.edu>2015-10-13 20:24:37 -0400
commit51117ba9333e00cdd8c4c31307effbe93601d328 (patch)
treef364d4a0d54cfc24cc4408a941e6af05e13f2c4f
parentc25f458b3e1721027b76b0cf46593becfd6f2d5f (diff)
Fix another mismatch between expunger SQL generation and SQL parser.
-rw-r--r--src/monoize.sml23
-rw-r--r--src/sqlcache.sml108
2 files changed, 68 insertions, 63 deletions
diff --git a/src/monoize.sml b/src/monoize.sml
index 2e87a70b..bdd8f5c3 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -4371,16 +4371,19 @@ fun monoize env file =
[] => e
| eb :: ebs =>
(L'.ESeq (
- (L'.EDml (foldl
- (fn (eb, s) =>
- (L'.EStrcat (s,
- (L'.EStrcat (str " OR ",
- cond eb), loc)), loc))
- (L'.EStrcat (str ("DELETE FROM "
- ^ Settings.mangleSql tab
- ^ " WHERE "),
- cond eb), loc)
- ebs, L'.Error), loc),
+ (L'.EDml ((L'.EStrcat (str ("DELETE FROM "
+ ^ Settings.mangleSql tab
+ ^ " WHERE "),
+ foldl (fn (eb, s) =>
+ (L'.EStrcat (str "(",
+ (L'.EStrcat (s,
+ (L'.EStrcat (str " OR ",
+ (L'.EStrcat (cond eb,
+ str ")"),
+ loc)), loc)), loc)), loc))
+ (cond eb)
+ ebs), loc),
+ L'.Error), loc),
e), loc)
in
e
diff --git a/src/sqlcache.sml b/src/sqlcache.sml
index dd851787..f3db5795 100644
--- a/src/sqlcache.sml
+++ b/src/sqlcache.sml
@@ -604,62 +604,64 @@ fun factorOutNontrivial text =
(newText, wrapLets, numArgs)
end
+fun cacheQuery effs env (queryInfo as (tableToIndices, indexToQueryNumArgs, index)) =
+ fn e' as EQuery {query = origQueryText,
+ state = resultTyp,
+ initial, body, tables, exps} =>
+ let
+ val (newQueryText, wrapLets, numArgs) = factorOutNontrivial origQueryText
+ (* Increment once for each new variable just made. *)
+ val queryExp = incRels numArgs
+ (EQuery {query = newQueryText,
+ state = resultTyp,
+ initial = initial,
+ body = body,
+ tables = tables,
+ exps = exps},
+ dummyLoc)
+ (* DEBUG *)
+ (* val () = Print.preface ("sqlcache> ", MonoPrint.p_exp MonoEnv.empty queryText) *)
+ val args = List.tabulate (numArgs, fn n => (ERel n, dummyLoc))
+ fun bind x f = Option.mapPartial f x
+ fun guard b x = if b then x else NONE
+ (* We use dummyTyp here. I think this is okay because databases don't
+ store (effectful) functions, but perhaps there's some pathalogical
+ corner case missing.... *)
+ fun safe bound =
+ not
+ o effectful effs
+ (iterate (fn env => MonoEnv.pushERel env "_" dummyTyp NONE)
+ bound
+ env)
+ val textOfQuery = fn (EQuery {query, ...}, _) => SOME query | _ => NONE
+ val attempt =
+ (* Ziv misses Haskell's do notation.... *)
+ bind (textOfQuery queryExp) (fn queryText =>
+ guard (safe 0 queryText andalso safe 0 initial andalso safe 2 body) (
+ bind (Sql.parse Sql.query queryText) (fn queryParsed =>
+ bind (cacheWrap (env, queryExp, resultTyp, args, index)) (fn cachedExp =>
+ SOME (wrapLets cachedExp,
+ (SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, index))
+ tableToIndices
+ (tablesQuery queryParsed),
+ IM.insert (indexToQueryNumArgs, index, (queryParsed, numArgs)),
+ index + 1))))))
+ in
+ case attempt of
+ SOME pair => pair
+ (* We have to increment index conservatively. *)
+ (* TODO: just use a reference for current index.... *)
+ | NONE => (e', (tableToIndices, indexToQueryNumArgs, index + 1))
+ end
+ | e' => (e', queryInfo)
+
fun addChecking file =
let
val effs = effectfulDecls file
- fun doExp env (queryInfo as (tableToIndices, indexToQueryNumArgs, index)) =
- fn e' as EQuery {query = origQueryText,
- state = resultTyp,
- initial, body, tables, exps} =>
- let
- val (newQueryText, wrapLets, numArgs) = factorOutNontrivial origQueryText
- (* Increment once for each new variable just made. *)
- val queryExp = incRels numArgs
- (EQuery {query = newQueryText,
- state = resultTyp,
- initial = initial,
- body = body,
- tables = tables,
- exps = exps},
- dummyLoc)
- val (EQuery {query = queryText, ...}, _) = queryExp
- (* DEBUG *)
- (* val () = Print.preface ("sqlcache> ", MonoPrint.p_exp MonoEnv.empty queryText) *)
- val args = List.tabulate (numArgs, fn n => (ERel n, dummyLoc))
- fun bind x f = Option.mapPartial f x
- fun guard b x = if b then x else NONE
- (* We use dummyTyp here. I think this is okay because databases
- don't store (effectful) functions, but perhaps there's some
- pathalogical corner case missing.... *)
- fun safe bound =
- not
- o effectful effs
- (iterate (fn env => MonoEnv.pushERel env "_" dummyTyp NONE)
- bound
- env)
- val attempt =
- (* Ziv misses Haskell's do notation.... *)
- guard (safe 0 queryText andalso safe 0 initial andalso safe 2 body) (
- bind (Sql.parse Sql.query queryText) (fn queryParsed =>
- bind (cacheWrap (env, queryExp, resultTyp, args, index)) (fn cachedExp =>
- SOME (wrapLets cachedExp,
- (SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, index))
- tableToIndices
- (tablesQuery queryParsed),
- IM.insert (indexToQueryNumArgs, index, (queryParsed, numArgs)),
- index + 1)))))
- in
- case attempt of
- SOME pair => pair
- (* We have to increment index conservatively. *)
- (* TODO: just use a reference for current index.... *)
- | NONE => (e', (tableToIndices, indexToQueryNumArgs, index + 1))
- end
- | e' => (e', queryInfo)
in
- (fileAllMapfoldB (fn env => fn exp => fn state => doExp env state exp)
- file
- (SIMM.empty, IM.empty, 0),
+ (fileAllMapfoldB (fn env => fn exp => fn state => cacheQuery effs env state exp)
+ file
+ (SIMM.empty, IM.empty, 0),
effs)
end
@@ -725,7 +727,7 @@ fun addFlushing ((file, (tableToIndices, indexToQueryNumArgs, index)), effs) =
val dmlText = incRels numArgs newDmlText
val dmlExp = EDml (dmlText, failureMode)
(* DEBUG *)
- (* val () = Print.preface ("SQLCACHE: ", (MonoPrint.p_exp MonoEnv.empty origDmlText)) *)
+ val () = Print.preface ("SQLCACHE: ", (MonoPrint.p_exp MonoEnv.empty origDmlText))
val inval =
case Sql.parse Sql.dml dmlText of
SOME dmlParsed =>