--- a/src/sqlcache.sml	Tue Oct 14 18:07:09 2014 -0400
+++ b/src/sqlcache.sml	Fri Oct 31 09:25:03 2014 -0400
@@ -15,10 +15,127 @@
 
 fun getFfiInfo () = !ffiInfo
 
-(* Program analysis. *)
+(* Some FFIs have writing as their only effect, which the caching records. *)
+val ffiEffectful =
+    let
+        val fs = SS.fromList ["htmlifyInt_w",
+                              "htmlifyFloat_w",
+                              "htmlifyString_w",
+                              "htmlifyBool_w",
+                              "htmlifyTime_w",
+                              "attrifyInt_w",
+                              "attrifyFloat_w",
+                              "attrifyString_w",
+                              "attrifyChar_w",
+                              "urlifyInt_w",
+                              "urlifyFloat_w",
+                              "urlifyString_w",
+                              "urlifyBool_w",
+                              "urlifyChannel_w"]
+    in
+        fn (m, f) => Settings.isEffectful (m, f)
+                     andalso not (m = "Basis" andalso SS.member (fs, f))
+    end
+
+
+(* Effect analysis. *)
+
+(* Makes an exception for EWrite (which is recorded when caching). *)
+fun effectful doPrint (effs : IS.set) (inFunction : bool) (bound : int) : Mono.exp -> bool =
+    (* If result is true, expression is definitely effectful. If result is
+       false, then expression is definitely not effectful if effs is fully
+       populated. The intended pattern is to use this a number of times equal
+       to the number of declarations in a file, Bellman-Ford style. *)
+    (* TODO: make incrementing of bound less janky, probably by using MonoUtil
+       instead of all this. *)
+    let
+        (* DEBUG: remove printing when done. *)
+        fun tru msg = if doPrint then (print (msg ^ "\n"); true) else true
+        val rec eff' =
+         (* ASK: is there a better way? *)
+         fn EPrim _ => false
+          (* We don't know if local functions have effects when applied. *)
+          | ERel idx => if inFunction andalso idx >= bound
+                        then tru ("rel" ^ Int.toString idx) else false
+          | ENamed name => if IS.member (effs, name) then tru "named" else false
+          | ECon (_, _, NONE) => false
+          | ECon (_, _, SOME e) => eff e
+          | ENone _ => false
+          | ESome (_, e) => eff e
+          (* TODO: use FFI whitelist. *)
+          | EFfi (m, f) => if ffiEffectful (m, f) then tru "ffi" else false
+          | EFfiApp (m, f, _) => if ffiEffectful (m, f) then tru "ffiapp" else false
+          (* ASK: we're calling functions effectful if they have effects when
+             applied or if the function expressions themselves have effects.
+             Is that okay? *)
+          (* This is okay because the values we ultimately care about aren't
+             functions, and this is a conservative approximation, anyway. *)
+          | EApp (eFun, eArg) => effectful doPrint effs true bound eFun orelse eff eArg
+          | EAbs (_, _, _, e) => effectful doPrint effs inFunction (bound+1) e
+          | EUnop (_, e) => eff e
+          | EBinop (_, _, e1, e2) => eff e1 orelse eff e2
+          | ERecord xs => List.exists (fn (_, e, _) => eff e) xs
+          | EField (e, _) => eff e
+          (* If any case could be effectful, consider it effectful. *)
+          | ECase (e, xs, _) => eff e orelse List.exists (fn (_, e) => eff e) xs
+          | EStrcat (e1, e2) => eff e1 orelse eff e2
+          (* ASK: how should we treat these three? *)
+          | EError _ => tru "error"
+          | EReturnBlob _ => tru "blob"
+          | ERedirect _ => tru "redirect"
+          (* EWrite is a special exception because we record writes when caching. *)
+          | EWrite _ => false
+          | ESeq (e1, e2) => eff e1 orelse eff e2
+          (* TODO: keep context of which local variables aren't effectful? Only
+             makes a difference for function expressions, though. *)
+          | ELet (_, _, eBind, eBody) => eff eBind orelse
+                                         effectful doPrint effs inFunction (bound+1) eBody
+          | EClosure (_, es) => List.exists eff es
+          (* TODO: deal with EQuery. *)
+          | EQuery _ => tru "query"
+          | EDml _ => tru "dml"
+          | ENextval _ => tru "nextval"
+          | ESetval _ => tru "setval"
+          | EUnurlify (e, _, _) => eff e
+          (* ASK: how should we treat this? *)
+          | EJavaScript _ => tru "javascript"
+          (* ASK: these are all effectful, right? *)
+          | ESignalReturn _ => tru "signalreturn"
+          | ESignalBind _ => tru "signalbind"
+          | ESignalSource _ => tru "signalsource"
+          | EServerCall _ => tru "servercall"
+          | ERecv _ => tru "recv"
+          | ESleep _ => tru "sleep"
+          | ESpawn _ => tru "spawn"
+        and eff = fn (e', _) => eff' e'
+    in
+        eff
+    end
+
+(* TODO: test this. *)
+val effectfulMap =
+    let
+        fun doVal ((_, name, _, e, _), effMap) =
+            if effectful false effMap false 0 e
+            then IS.add (effMap, name)
+            else effMap
+        val doDecl =
+         fn (DVal v, effMap) => doVal (v, effMap)
+          (* Repeat the list of declarations a number of times equal to its size. *)
+          | (DValRec vs, effMap) =>
+            List.foldl doVal effMap (List.concat (List.map (fn _ => vs) vs))
+          (* ASK: any other cases? *)
+          | (_, effMap) => effMap
+    in
+        MonoUtil.File.fold {typ = #2, exp = #2, decl = doDecl} IS.empty
+    end
+
+
+(* SQL analysis. *)
 
 val useInjIfPossible =
- fn SqConst prim => Inj (EPrim (Prim.String (Prim.Normal, Prim.toString prim)), ErrorMsg.dummySpan)
+ fn SqConst prim => Inj (EPrim (Prim.String (Prim.Normal, Prim.toString prim)),
+                         ErrorMsg.dummySpan)
   | sqexp => sqexp
 
 fun equalities (canonicalTable : string -> string) :
@@ -89,6 +206,7 @@
 
 (* Program instrumentation. *)
 
+fun stringExp s = (EPrim (Prim.String (Prim.Normal, s)), ErrorMsg.dummySpan)
 val stringTyp = (TFfi ("Basis", "string"), ErrorMsg.dummySpan)
 
 val sequence =
@@ -103,7 +221,7 @@
 fun ffiAppCache' (func, index, args) : Mono.exp' =
     EFfiApp ("Sqlcache", func ^ Int.toString index, args)
 
-fun ffiAppCache (func, index, args) : Mono. exp =
+fun ffiAppCache (func, index, args) : Mono.exp =
     (ffiAppCache' (func, index, args), ErrorMsg.dummySpan)
 
 val varPrefix = "queryResult"
@@ -113,7 +231,17 @@
     then Int.fromString (String.extract (varName, String.size varPrefix, NONE))
     else NONE
 
-val incRels = MonoUtil.Exp.map {typ = fn x => x, exp = fn ERel n => ERel (n + 1) | x => x}
+(* Always increments negative indices because that's what we need later. *)
+fun incRelsBound bound inc =
+    MonoUtil.Exp.mapB
+        {typ = fn x => x,
+         exp = fn level =>
+                  (fn ERel n => ERel (if n >= level orelse n < 0 then n + inc else n)
+                    | x => x),
+         bind = fn (level, MonoUtil.Exp.RelE _) => level + 1 | (level, _) => level}
+        bound
+
+val incRels = incRelsBound 0
 
 (* Filled in by instrumentQuery during Monoize, used during Sqlcache. *)
 val urlifiedRel0s : Mono.exp IM.map ref = ref IM.empty
@@ -129,12 +257,11 @@
                     val i = !nextQuery before nextQuery := !nextQuery + 1
                 in
                     urlifiedRel0s := IM.insert (!urlifiedRel0s, i, urlifiedRel0);
-                    (* ASK: name variables properly? *)
                     (ELet (varPrefix ^ Int.toString i, typ, query,
                            (* Uses a dummy FFI call to keep the urlified expression around, which
                               in turn keeps the declarations required for urlification safe from
                               MonoShake. The dummy call is removed during Sqlcache. *)
-                           (* ASK: is there a better way? *)
+                           (* TODO: thread a Monoize.Fm.t through this module. *)
                            (ESeq ((EFfiApp ("Sqlcache", "dummy", [(urlifiedRel0, stringTyp)]), loc),
                                   (ERel 0, loc)),
                             loc)),
@@ -145,28 +272,26 @@
         iq
     end
 
-val gunk : ((string * string) * Mono.exp) list list ref = ref [[]]
-
 fun cacheWrap (query, i, urlifiedRel0, eqs) =
     case query of
         (EQuery {state = typ, ...}, _) =>
         let
+            val () = ffiInfo := {index = i, params = length eqs} :: !ffiInfo
             val loc = ErrorMsg.dummySpan
-            (* TODO: deal with effectful injected expressions. *)
-            val args = (ffiInfo := {index = i, params = length eqs} :: !ffiInfo;
-                        map (fn (_, e) => (e, stringTyp)) eqs) before gunk := eqs :: !gunk
-            val argsInc = map (fn (e, t) => (incRels e, t)) args
+            (* We ensure before this step that all arguments aren't effectful.
+               by turning them into local variables as needed. *)
+            val args = map (fn (_, e) => (e, stringTyp)) eqs
+            val argsInc = map (fn (e, typ) => (incRels 1 e, typ)) args
+            val check = ffiAppCache ("check", i, args)
+            val store = ffiAppCache ("store", i, (urlifiedRel0, stringTyp) :: argsInc)
+            val rel0 = (ERel 0, loc)
         in
-            (ECase (ffiAppCache ("check", i, args),
+            (ECase (check,
                     [((PNone stringTyp, loc),
-                      (ELet ("q", typ, query,
-                             (ESeq (ffiAppCache ("store", i, (urlifiedRel0, stringTyp) :: argsInc),
-                                    (ERel 0, loc)),
-                              loc)),
-                       loc)),
+                      (ELet ("q", typ, query, (ESeq (store, rel0), loc)), loc)),
                      ((PSome (stringTyp, (PVar ("hit", stringTyp), loc)), loc),
-                      (* ASK: what does this bool do? *)
-                      (EUnurlify ((ERel 0, loc), typ, false), loc))],
+                      (* Boolean is false because we're not unurlifying from a cookie. *)
+                      (EUnurlify (rel0, typ, false), loc))],
                     {disc = stringTyp, result = typ}),
              loc)
         end
@@ -181,20 +306,66 @@
 
 fun fileMap doExp file = #1 (fileMapfold (fn x => fn _ => (doExp x, ())) file ())
 
-val addChecking =
+fun addChecking file =
     let
         fun doExp queryInfo =
-         fn e' as ELet (v, t, queryExp as (EQuery {query = queryText, ...}, _), body) =>
+         fn e' as ELet (v, t,
+                        queryExp' as (EQuery {query = origQueryText,
+                                              initial, body, state, tables, exps}, queryLoc),
+                        letBody) =>
             let
+                val loc = ErrorMsg.dummySpan
+                val chunks = chunkify origQueryText
+                fun strcat (e1, e2) = (EStrcat (e1, e2), loc)
+                val (newQueryText, newVariables) =
+                    (* Important that this is foldr (to oppose foldl below). *)
+                    List.foldr
+                        (fn (chunk, (qText, newVars)) =>
+                            case chunk of
+                                Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars)
+                              | Exp (e as (ERel _, _)) => (strcat (e, qText), newVars)
+                              | Exp (e as (ENamed _, _)) => (strcat (e, qText), newVars)
+                              (* Head of newVars has lowest index. *)
+                              | Exp e =>
+                                let
+                                    val n = length newVars
+                                in
+                                    (* This is the (n + 1)th new variable, so
+                                       there are already n new variables bound,
+                                       so we increment indices by n. *)
+                                    (strcat ((ERel (~(n+1)), loc), qText), incRels n e :: newVars)
+                                end
+                              | String s => (strcat (stringExp s, qText), newVars))
+                        (stringExp "", [])
+                        chunks
+                fun wrapLets e' =
+                    (* Important that this is foldl (to oppose foldr above). *)
+                    List.foldl (fn (v, e') => ELet ("sqlArgz", stringTyp, v, (e', loc))) e' newVariables
+                (* Increment once for each new variable just made. *)
+                val queryExp = incRels (length newVariables)
+                                       (EQuery {query = newQueryText,
+                                                initial = initial,
+                                                body = body,
+                                                state = state,
+                                                tables = tables,
+                                                exps = exps},
+                                        queryLoc)
+                val (EQuery {query = queryText, ...}, _) = queryExp
+                (* val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty queryText)); *)
                 fun bind x f = Option.mapPartial f x
+                fun guard b x = if b then x else NONE
+                (* DEBUG: set first boolean argument to true to turn on printing. *)
+                fun safe bound = not o effectful true (effectfulMap file) false bound
                 val attempt =
                     (* Ziv misses Haskell's do notation.... *)
+                    guard (safe 0 queryText andalso safe 0 initial andalso safe 2 body) (
                     bind (parse query queryText) (fn queryParsed =>
-                    (Print.preface ("gunk> ", (MonoPrint.p_exp MonoEnv.empty queryExp));
                     bind (indexOfName v) (fn i =>
                     bind (equalitiesQuery queryParsed) (fn eqs =>
                     bind (IM.find (!urlifiedRel0s, i)) (fn urlifiedRel0 =>
-                    SOME (ELet (v, t, cacheWrap (queryExp, i, urlifiedRel0, eqs), body),
+                    SOME (wrapLets (ELet (v, t,
+                                          cacheWrap (queryExp, i, urlifiedRel0, eqs),
+                                          incRelsBound 1 (length newVariables) letBody)),
                           SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, i))
                                    queryInfo
                                    (tablesQuery queryParsed)))))))
@@ -206,7 +377,7 @@
           | ESeq ((EFfiApp ("Sqlcache", "dummy", _), _), (e', _)) => (e', queryInfo)
           | e' => (e', queryInfo)
     in
-        fn file => fileMapfold (fn exp => fn state => doExp state exp) file SIMM.empty
+        fileMapfold (fn exp => fn state => doExp state exp) file SIMM.empty
     end
 
 fun addFlushing (file, queryInfo) =
@@ -231,8 +402,10 @@
 fun go file =
     let
         val () = Sql.sqlcacheMode := true
+        val file' = addFlushing (addChecking file)
+        val () = Sql.sqlcacheMode := false
     in
-        addFlushing (addChecking file) before Sql.sqlcacheMode := false
+         file'
     end