diff --git a/Haxl/Core.hs b/Haxl/Core.hs
--- a/Haxl/Core.hs
+++ b/Haxl/Core.hs
@@ -63,7 +63,16 @@
   , AllocCount
   , LabelHitCount
 
-    -- ** Tracing flags
+    -- * Report flags
+  , ReportFlag(..)
+  , ReportFlags
+  , defaultReportFlags
+  , profilingReportFlags
+  , setReportFlag
+  , clearReportFlag
+  , testReportFlag
+
+    -- ** Flags
   , Flags(..)
   , defaultFlags
   , ifTrace
@@ -88,6 +97,9 @@
   , putResult
   , putSuccess
   , putResultFromChildThread
+  , putResultWithStats
+  , putResultWithStatsFromChildThread
+  , DataSourceStats(..)
 
     -- ** Default fetch implementations
   , asyncFetch, asyncFetchWithDispatch, asyncFetchAcquireRelease
diff --git a/Haxl/Core/DataCache.hs b/Haxl/Core/DataCache.hs
--- a/Haxl/Core/DataCache.hs
+++ b/Haxl/Core/DataCache.hs
@@ -50,8 +50,8 @@
 -- 'Hashable' and 'Eq' once per request type.
 --
 data SubCache res =
-  forall req a . (Hashable (req a), Eq (req a), Typeable (req a)) =>
-       SubCache (req a -> String) (a -> String) ! (HashTable (req a) (res a))
+  forall req a . (Hashable (req a), Eq (req a)) =>
+       SubCache (req a -> String) (a -> String) !(HashTable (req a) (res a))
        -- NB. the inner HashMap is strict, to avoid building up
        -- a chain of thunks during repeated insertions.
 
diff --git a/Haxl/Core/DataSource.hs b/Haxl/Core/DataSource.hs
--- a/Haxl/Core/DataSource.hs
+++ b/Haxl/Core/DataSource.hs
@@ -36,6 +36,8 @@
   , putResult
   , putResultFromChildThread
   , putSuccess
+  , putResultWithStats
+  , putResultWithStatsFromChildThread
 
   -- * Default fetch implementations
   , asyncFetch, asyncFetchWithDispatch
@@ -55,12 +57,14 @@
 import Control.Monad
 import Data.Hashable
 import Data.Text (Text)
+import Data.Kind (Type)
 import Data.Typeable
 
 import Haxl.Core.Exception
 import Haxl.Core.Flags
 import Haxl.Core.ShowP
 import Haxl.Core.StateStore
+import Haxl.Core.Stats
 
 
 import GHC.Conc ( newStablePtrPrimMVar
@@ -70,7 +74,6 @@
                           , myThreadId )
 import Control.Concurrent.MVar
 import Foreign.StablePtr
-import System.Mem (setAllocationCounter)
 
 -- ---------------------------------------------------------------------------
 -- DataSource class
@@ -107,7 +110,7 @@
   classifyFailure :: u -> req a -> SomeException -> FailureClassification
   classifyFailure _ _ _ = StandardFailure
 
-class DataSourceName (req :: * -> *) where
+class DataSourceName (req :: Type -> Type) where
   -- | The name of this 'DataSource', used in tracing and stats. Must
   -- take a dummy request.
   dataSourceName :: Proxy req -> Text
@@ -128,7 +131,7 @@
   )
 
 -- | Hints to the scheduler about this data source
-data SchedulerHint (req :: * -> *)
+data SchedulerHint (req :: Type -> Type)
   = TryToBatch
     -- ^ Hold data-source requests while we execute as much as we can, so
     -- that we can hopefully collect more requests to batch.
@@ -183,12 +186,15 @@
 -- ResultVar
 
 -- | A sink for the result of a data fetch in 'BlockedFetch'
-newtype ResultVar a = ResultVar (Either SomeException a -> Bool -> IO ())
+newtype ResultVar a =
+  ResultVar (Either SomeException a -> Bool -> Maybe DataSourceStats -> IO ())
   -- The Bool here is True if result was returned by a child thread,
   -- rather than the main runHaxl thread.  see Note [tracking allocation in
   -- child threads]
 
-mkResultVar :: (Either SomeException a -> Bool -> IO ()) -> ResultVar a
+mkResultVar
+  :: (Either SomeException a -> Bool -> Maybe DataSourceStats -> IO ())
+  -> ResultVar a
 mkResultVar = ResultVar
 
 putFailure :: (Exception e) => ResultVar a -> e -> IO ()
@@ -198,8 +204,16 @@
 putSuccess r = putResult r . Right
 
 putResult :: ResultVar a -> Either SomeException a -> IO ()
-putResult (ResultVar io) res = io res False
+putResult (ResultVar io) res = io res False Nothing
 
+putResultWithStats
+  :: ResultVar a -> Either SomeException a -> DataSourceStats -> IO ()
+putResultWithStats (ResultVar io) res st = io res False (Just st)
+
+putResultWithStatsFromChildThread
+  :: ResultVar a -> Either SomeException a -> DataSourceStats -> IO ()
+putResultWithStatsFromChildThread (ResultVar io) res st = io res True (Just st)
+
 -- | Like `putResult`, but used to get correct accounting when work is
 -- being done in child threads.  This is particularly important for
 -- data sources that are using 'BackgroundFetch', The allocation performed
@@ -216,7 +230,7 @@
 -- 'putResultFromChildThread', so that allocation is not counted
 -- multiple times.
 putResultFromChildThread :: ResultVar a -> Either SomeException a -> IO ()
-putResultFromChildThread (ResultVar io) res =  io res True
+putResultFromChildThread (ResultVar io) res =  io res True Nothing
   -- see Note [tracking allocation in child threads]
 
 -- | Function for easily setting a fetch to a particular exception
diff --git a/Haxl/Core/Exception.hs b/Haxl/Core/Exception.hs
--- a/Haxl/Core/Exception.hs
+++ b/Haxl/Core/Exception.hs
@@ -81,6 +81,7 @@
 import Data.Binary (Binary)
 import Data.Typeable
 import Data.Text (Text)
+import qualified Data.Text as Text
 
 import Haxl.Core.Util
 import GHC.Stack
@@ -113,11 +114,12 @@
          e
   deriving (Typeable)
 
-type Stack = [String]
+type Stack = [Text]
   -- hopefully this will get more informative in the future
 
 instance Show HaxlException where
-  show (HaxlException (Just stk@(_:_)) e) = show e ++ '\n' : renderStack stk
+  show (HaxlException (Just stk@(_:_)) e) =
+    show e ++ '\n' : renderStack (reverse $ map Text.unpack stk)
   show (HaxlException _ e) = show e
 
 instance Exception HaxlException
@@ -126,7 +128,7 @@
 instance ToJSON HaxlException where
   toJSON (HaxlException stk e) = object fields
     where
-      fields | Just s@(_:_) <- stk = ("stack" .= reverse s) : rest
+      fields | Just s@(_:_) <- stk = ("stack" .= s) : rest
              | otherwise = rest
       rest =
         [ "type" .= show (typeOf e)
@@ -362,9 +364,6 @@
 rethrowAsyncExceptions :: SomeException -> IO ()
 rethrowAsyncExceptions e
   | Just SomeAsyncException{} <- fromException e = Exception.throw e
-  | Just AllocationLimitExceeded{} <- fromException e = Exception.throw e
-    -- AllocationLimitExceeded is not a child of SomeAsyncException,
-    -- but it should be.
   | otherwise = return ()
 
 tryWithRethrow :: IO a -> IO (Either SomeException a)
diff --git a/Haxl/Core/Fetch.hs b/Haxl/Core/Fetch.hs
--- a/Haxl/Core/Fetch.hs
+++ b/Haxl/Core/Fetch.hs
@@ -23,6 +23,7 @@
 module Haxl.Core.Fetch
   ( dataFetch
   , dataFetchWithShow
+  , dataFetchWithInsert
   , uncachedRequest
   , cacheResult
   , dupableCacheRequest
@@ -47,6 +48,7 @@
 import Data.Proxy
 import Data.Typeable
 import Data.Text (Text)
+import Data.Kind (Type)
 import qualified Data.Text as Text
 import Text.Printf
 #ifdef PROFILING
@@ -111,8 +113,7 @@
     doFetch = do
       ivar <- newIVar
       k <- nextCallId env
-      let !rvar = stdResultVar ivar completions submittedReqsRef flags
-            (Proxy :: Proxy r)
+      let !rvar = stdResultVar env ivar (Proxy :: Proxy r)
       insertFn req (DataCacheItem ivar k) dataCache
       return (Uncached rvar ivar k)
   mbRes <- DataCache.lookup req dataCache
@@ -137,14 +138,12 @@
 -- completes.
 stdResultVar
   :: forall r a u w. (DataSourceName r, Typeable r)
-  => IVar u w a
-  -> TVar [CompleteReq u w]
-  -> IORef ReqCountMap
-  -> Flags
+  => Env u w
+  -> IVar u w a
   -> Proxy r
   -> ResultVar a
-stdResultVar ivar completions ref flags p =
-  mkResultVar $ \r isChildThread -> do
+stdResultVar Env{..} ivar p =
+  mkResultVar $ \r isChildThread _ -> do
     allocs <- if isChildThread
       then
         -- In a child thread, return the current allocation counter too,
@@ -155,12 +154,12 @@
     atomicallyOnBlocking
       (LogicBug (ReadingCompletionsFailedFetch (dataSourceName p))) $ do
       cs <- readTVar completions
-      writeTVar completions (CompleteReq r ivar allocs : cs)
+      writeTVar completions (CompleteReq (eitherToResult r) ivar allocs : cs)
     -- Decrement the counter as request has finished. Do this after updating the
     -- completions TVar so that if the scheduler is tracking what was being
     -- waited on it gets a consistent view.
-    ifReport flags 1 $
-      atomicModifyIORef' ref (\m -> (subFromCountMap p 1 m, ()))
+    ifReport flags ReportOutgoneFetches $
+      atomicModifyIORef' submittedReqsRef (\m -> (subFromCountMap p 1 m, ()))
 {-# INLINE stdResultVar #-}
 
 
@@ -169,7 +168,7 @@
 logFetch :: Env u w -> (r a -> String) -> r a -> CallId -> IO ()
 #ifdef PROFILING
 logFetch env showFn req fid = do
-  ifReport (flags env) 5 $ do
+  ifReport (flags env) ReportFetchStack $ do
     stack <- currentCallStack
     modifyIORef' (statsRef env) $ \(Stats s) ->
       Stats (FetchCall (showFn req) stack fid : s)
@@ -177,6 +176,55 @@
 logFetch _ _ _ _ = return ()
 #endif
 
+calcFailure
+  :: forall u req a . DataSource u req
+  => u
+  -> req a
+  -> Either SomeException a
+  -> FailureCount
+calcFailure _u _r Right{} = mempty
+calcFailure u r (Left e) = case classifyFailure u r e of
+  StandardFailure -> mempty { failureCountStandard = 1 }
+  IgnoredForStatsFailure -> mempty { failureCountIgnored = 1 }
+
+addFallbackFetchStats
+  :: forall u w req a . DataSource u req
+  => Env u w
+  -> CallId
+  -> req a
+  -> ResultVal a w
+  -> IO ()
+addFallbackFetchStats Env{..} fid req res = do
+  bid <- atomicModifyIORef' statsBatchIdRef $ \x -> (x+1,x+1)
+  start <- getTimestamp
+  let
+    dsName = dataSourceName (Proxy :: Proxy req)
+    FailureCount{..} = case res of
+      Ok{} -> mempty
+      (ThrowHaxl e _) -> calcFailure userEnv req (Left e)
+      (ThrowIO e) -> calcFailure userEnv req (Left e)
+    this = FetchStats { fetchDataSource = dsName
+                      , fetchBatchSize = 1
+                      , fetchStart = start
+                      , fetchDuration = 0
+                      , fetchSpace = 0
+                      , fetchFailures = failureCountStandard
+                      , fetchIgnoredFailures = failureCountIgnored
+                      , fetchBatchId = bid
+                      , fetchIds = [fid] }
+  atomicModifyIORef' statsRef $ \(Stats fs) -> (Stats (this : fs), ())
+
+addFallbackResult
+  :: Env u w
+  -> ResultVal a w
+  -> IVar u w a
+  -> IO ()
+addFallbackResult Env{..} res ivar = do
+  atomicallyOnBlocking
+    (LogicBug (ReadingCompletionsFailedFetch "addFallbackResult")) $ do
+    cs <- readTVar completions
+    writeTVar completions (CompleteReq res ivar 0 : cs)
+
 -- | Performs actual fetching of data for a 'Request' from a 'DataSource'.
 dataFetch :: (DataSource u r, Request r a) => r a -> GenHaxl u w a
 dataFetch = dataFetchWithInsert show DataCache.insert
@@ -212,18 +260,36 @@
       -- Check whether the data source wants to submit requests
       -- eagerly, or batch them up.
       --
-      let blockedFetch = BlockedFetch req rvar
-      let blockedFetchI = BlockedFetchInternal fid
-      case schedulerHint userEnv :: SchedulerHint r of
-        SubmitImmediately ->
-          performFetches env [BlockedFetches [blockedFetch] [blockedFetchI]]
-        TryToBatch ->
-          -- add the request to the RequestStore and continue
-          modifyIORef' reqStoreRef $ \bs ->
-            addRequest blockedFetch blockedFetchI bs
-      --
-      return $ Blocked ivar (Return ivar)
+      let
+        blockedFetch = BlockedFetch req rvar
+        blockedFetchI = BlockedFetchInternal fid
+        submitFetch = do
+          case schedulerHint userEnv :: SchedulerHint r of
+            SubmitImmediately ->
+              performFetches env [BlockedFetches [blockedFetch] [blockedFetchI]]
+            TryToBatch ->
+              -- add the request to the RequestStore and continue
+              modifyIORef' reqStoreRef $ \bs ->
+                addRequest blockedFetch blockedFetchI bs
+          return $ Blocked ivar (Return ivar)
 
+      -- if there is a fallback configured try that,
+      -- else dispatch the fetch
+      case dataCacheFetchFallback of
+        Nothing -> submitFetch
+        Just (DataCacheLookup dcl) -> do
+          mbFallbackRes <- dcl req
+          case mbFallbackRes of
+            Nothing -> submitFetch
+            Just fallbackRes -> do
+              addFallbackResult env fallbackRes ivar
+              ifReport flags ReportFetchStats $ addFallbackFetchStats
+                env
+                fid
+                req
+                fallbackRes
+              return $ Blocked ivar (Return ivar)
+
     -- Seen before but not fetched yet.  We're blocked, but we don't have
     -- to add the request to the RequestStore.
     CachedNotFetched ivar fid -> do
@@ -233,7 +299,7 @@
     -- Cached: either a result, or an exception
     Cached r fid -> do
       ifProfiling flags $ addProfileFetch env req fid True
-      done r
+      done env r
 
 -- | A data request that is not cached.  This is not what you want for
 -- normal read requests, because then multiple identical requests may
@@ -251,17 +317,16 @@
 -- allows a transparent run afterwards. Without this, the test would try to
 -- call the datasource during testing and that would be an exception.
 uncachedRequest
- :: forall a u w (r :: * -> *). (DataSource u r, Request r a)
+ :: forall a u w (r :: Type -> Type). (DataSource u r, Request r a)
  => r a -> GenHaxl u w a
 uncachedRequest req = do
   flg <- env flags
-  subRef <- env submittedReqsRef
   if recording flg /= 0
     then dataFetch req
     else GenHaxl $ \e@Env{..} -> do
       ivar <- newIVar
       k <- nextCallId e
-      let !rvar = stdResultVar ivar completions subRef flg (Proxy :: Proxy r)
+      let !rvar = stdResultVar e ivar (Proxy :: Proxy r)
       modifyIORef' reqStoreRef $ \bs ->
         addRequest (BlockedFetch req rvar) (BlockedFetchInternal k) bs
       return $ Blocked ivar (Return ivar)
@@ -292,26 +357,34 @@
   -> r a
   -> IO a
   -> GenHaxl u w a
-cacheResultWithInsert showFn insertFn req val = GenHaxl $ \e@Env{..} -> do
+cacheResultWithInsert showFn insertFn req val = GenHaxl $ \env@Env{..} -> do
   mbRes <- DataCache.lookup req dataCache
   case mbRes of
     Nothing -> do
-      eitherResult <- Exception.try val
-      case eitherResult of
-        Left e -> rethrowAsyncExceptions e
-        _ -> return ()
-      let result = eitherToResultThrowIO eitherResult
+      let
+        getResult = do
+          eitherResult <- Exception.try val
+          case eitherResult of
+            Left e -> rethrowAsyncExceptions e
+            _ -> return ()
+          return $ eitherToResultThrowIO eitherResult
+      -- if there is a fallback configured try that
+      result <- case dataCacheFetchFallback of
+        Nothing -> getResult
+        Just (DataCacheLookup dcl) -> do
+          mbFallbackRes <- dcl req
+          maybe getResult return mbFallbackRes
       ivar <- newFullIVar result
-      k <- nextCallId e
+      k <- nextCallId env
       insertFn req (DataCacheItem ivar k) dataCache
-      done result
+      done env result
     Just (DataCacheItem IVar{ivarRef = cr} _) -> do
       e <- readIORef cr
       case e of
-        IVarEmpty _ -> corruptCache
-        IVarFull r -> done r
+        IVarEmpty _ -> raise env corruptCache
+        IVarFull r -> done env r
   where
-    corruptCache = raise . DataSourceError $ Text.concat
+    corruptCache = DataSourceError $ Text.concat
       [ Text.pack (showFn req)
       , " has a corrupted cache value: these requests are meant to"
       , " return immediately without an intermediate value. Either"
@@ -341,7 +414,7 @@
     -- It is an error if the request is already in the cache.
     -- We can't test whether the cached result is the same without adding an
     -- Eq constraint, and we don't necessarily have Eq for all results.
-    _other -> raise $
+    _other -> raise e $
       DataSourceError "cacheRequest: request is already in the cache"
 
 -- | Similar to @cacheRequest@ but doesn't throw an exception if the key
@@ -386,7 +459,7 @@
                   <> Text.pack (showp req)
         Just state ->
           return $ FetchToDo reqs
-            $ (if report f >= 2
+            $ (if testReportFlag ReportFetchStats $ report f
                 then wrapFetchInStats
                         (userEnv env)
                         sref
@@ -413,7 +486,7 @@
 
 data FetchToDo where
   FetchToDo
-    :: forall (req :: * -> *). (DataSourceName req, Typeable req)
+    :: forall (req :: Type -> Type). (DataSourceName req, Typeable req)
     => [BlockedFetch req] -> PerformFetch req -> FetchToDo
 
 -- Catch exceptions arising from the data source and stuff them into
@@ -490,7 +563,8 @@
       SyncFetch $ \reqs -> do
         bid <- newBatchId
         fail_ref <- newIORef mempty
-        (t0,t,alloc,_) <- statsForIO (f (map (addFailureCount u fail_ref) reqs))
+        (t0,t,alloc,_) <- statsForIO (f (map (addFailureCount u fail_ref)
+          (reqsWithFetchDsStats bid reqs)))
         failures <- readIORef fail_ref
         updateFetchStats bid allFids t0 t alloc batchSize failures
     AsyncFetch f -> do
@@ -502,7 +576,8 @@
               (_,t,alloc,_) <- statsForIO inner
               writeIORef inner_r (t,alloc)
             reqs' = map (addFailureCount u fail_ref) reqs
-        (t0, totalTime, totalAlloc, _) <- statsForIO (f reqs' inner')
+            reqs'' = reqsWithFetchDsStats bid reqs'
+        (t0, totalTime, totalAlloc, _) <- statsForIO (f reqs'' inner')
         (innerTime, innerAlloc) <- readIORef inner_r
         failures <- readIORef fail_ref
         updateFetchStats bid allFids t0 (totalTime - innerTime)
@@ -511,7 +586,8 @@
       BackgroundFetch $ \reqs -> do
         bid <- newBatchId
         startTime <- getTimestamp
-        io (zipWith (addTimer u bid startTime) reqs reqsI)
+        io (reqsWithFetchDsStats bid
+          (zipWith (addTimer u bid startTime) reqs reqsI))
   where
     allFids = map (\(BlockedFetchInternal k) -> k) reqsI
     newBatchId = atomicModifyIORef' batchIdRef $ \x -> (x+1,x+1)
@@ -520,20 +596,15 @@
       (t0,t,a) <- time io
       postAlloc <- getAllocationCounter
       return (t0,t, fromIntegral $ prevAlloc - postAlloc, a)
-
-    calcFailure _u _r (Right _) = mempty
-    calcFailure u r (Left e) = case classifyFailure u r e of
-      StandardFailure -> mempty { failureCountStandard = 1 }
-      IgnoredForStatsFailure -> mempty { failureCountIgnored = 1 }
-
-
+    reqsWithFetchDsStats = \bid reqs
+      -> zipWith (addFetchDatasourceStats bid) reqs reqsI
     addTimer
       u
       bid
       t0
       (BlockedFetch req (ResultVar fn))
       (BlockedFetchInternal fid) =
-        BlockedFetch req $ ResultVar $ \result isChildThread -> do
+        BlockedFetch req $ ResultVar $ \result isChildThread stats -> do
           t1 <- getTimestamp
           -- We cannot measure allocation easily for BackgroundFetch. Here we
           -- just attribute all allocation to the last
@@ -546,8 +617,30 @@
             (negate allocs)
             1 -- batch size: we don't know if this is a batch or not
             (calcFailure u req result) -- failures
-          fn result isChildThread
+          fn result isChildThread stats
 
+    addFetchDatasourceStats
+      :: Int
+      -> BlockedFetch r
+      -> BlockedFetchInternal
+      -> BlockedFetch r
+    addFetchDatasourceStats bid
+      (BlockedFetch req (ResultVar fn))
+      (BlockedFetchInternal fid) = BlockedFetch req $ ResultVar
+        $ \result isChildThread stats -> do
+          let mkStats dss = FetchDataSourceStats
+                { fetchDsStatsCallId = fid
+                , fetchDsStatsDataSource = dataSource
+                , fetchDsStatsStats = dss
+                , fetchBatchId = bid
+                }
+          case stats of
+            Just dss -> atomicModifyIORef' statsRef
+              $ \(Stats fs) -> (Stats (mkStats dss : fs), ())
+            Nothing -> return ()
+          fn result isChildThread stats
+
+
     updateFetchStats
       :: Int
       -> [CallId]
@@ -572,10 +665,10 @@
     addFailureCount :: DataSource u r
       => u -> IORef FailureCount -> BlockedFetch r -> BlockedFetch r
     addFailureCount u ref (BlockedFetch req (ResultVar fn)) =
-      BlockedFetch req $ ResultVar $ \result isChildThread -> do
+      BlockedFetch req $ ResultVar $ \result isChildThread stats -> do
         let addFailures r = (r <> calcFailure u req result, ())
         when (isLeft result) $ atomicModifyIORef' ref addFailures
-        fn result isChildThread
+        fn result isChildThread stats
 
 wrapFetchInTrace
   :: Int
@@ -612,7 +705,7 @@
 scheduleFetches :: [FetchToDo] -> IORef ReqCountMap -> Flags -> IO ()
 scheduleFetches fetches ref flags = do
   -- update ReqCountmap for these fetches
-  ifReport flags 1 $ sequence_
+  ifReport flags ReportOutgoneFetches $ sequence_
     [ atomicModifyIORef' ref $
         \m -> (addToCountMap (Proxy :: Proxy r) (length reqs) m, ())
     | FetchToDo (reqs :: [BlockedFetch r]) _f <- fetches
diff --git a/Haxl/Core/Flags.hs b/Haxl/Core/Flags.hs
--- a/Haxl/Core/Flags.hs
+++ b/Haxl/Core/Flags.hs
@@ -4,6 +4,8 @@
 -- This source code is distributed under the terms of a BSD license,
 -- found in the LICENSE file.
 
+{-# LANGUAGE BangPatterns #-}
+
 -- |
 -- The 'Flags' type and related functions.  This module is provided
 -- for access to Haxl internals only; most users should import
@@ -11,8 +13,16 @@
 --
 module Haxl.Core.Flags
   (
-    -- * Tracing flags
-    Flags(..)
+    -- * Report flags
+    ReportFlag(..)
+  , ReportFlags
+  , defaultReportFlags
+  , profilingReportFlags
+  , setReportFlag
+  , clearReportFlag
+  , testReportFlag
+    -- * Flags
+  , Flags(..)
   , defaultFlags
   , ifTrace
   , ifReport
@@ -20,22 +30,72 @@
   ) where
 
 import Control.Monad
+import Data.Bits
+import Data.List (foldl')
+import Text.Printf (printf)
 
 -- ---------------------------------------------------------------------------
+-- ReportFlags
+data ReportFlag
+  = ReportOutgoneFetches  -- ^ outgone fetches, for debugging eg: timeouts
+  | ReportFetchStats  -- ^ data fetch stats & errors
+  | ReportProfiling   -- ^ enabling label stack and profiling
+  | ReportExceptionLabelStack  -- ^ include label stack in HaxlException
+  | ReportFetchStack  -- ^ log cost-center stack traces of dataFetch calls
+  deriving (Bounded, Enum, Eq, Show)
+
+profilingDependents :: [ReportFlag]
+profilingDependents =
+  [ ReportExceptionLabelStack
+  , ReportFetchStack
+  ]
+
+newtype ReportFlags = ReportFlags Int
+
+instance Show ReportFlags where
+  show (ReportFlags fs) = printf "%0*b" (fromEnum maxReportFlag + 1) fs
+    where
+      maxReportFlag = maxBound :: ReportFlag
+
+defaultReportFlags :: ReportFlags
+defaultReportFlags = ReportFlags 0
+
+profilingReportFlags :: ReportFlags
+profilingReportFlags = foldl' (flip setReportFlag) defaultReportFlags
+  [ ReportOutgoneFetches
+  , ReportFetchStats
+  , ReportProfiling
+  ]
+
+setReportFlag :: ReportFlag -> ReportFlags -> ReportFlags
+setReportFlag f (ReportFlags fs) =
+  ReportFlags $ setDependencies $ setBit fs $ fromEnum f
+  where
+    setDependencies
+      | f `elem` profilingDependents = flip setBit $ fromEnum ReportProfiling
+      | otherwise = id
+
+clearReportFlag :: ReportFlag -> ReportFlags -> ReportFlags
+clearReportFlag f (ReportFlags fs) =
+  ReportFlags $ clearDependents $ clearBit fs $ fromEnum f
+  where
+    clearDependents z = case f of
+      ReportProfiling -> foldl' clearBit z $ map fromEnum profilingDependents
+      _ -> z
+
+{-# INLINE testReportFlag #-}
+testReportFlag :: ReportFlag -> ReportFlags -> Bool
+testReportFlag !f (ReportFlags !fs) = testBit fs $ fromEnum f
+
+-- ---------------------------------------------------------------------------
 -- Flags
 
 -- | Flags that control the operation of the engine.
 data Flags = Flags
   { trace :: {-# UNPACK #-} !Int
     -- ^ Tracing level (0 = quiet, 3 = very verbose).
-  , report :: {-# UNPACK #-} !Int
-    -- ^ Report level:
-    --    * 0 = quiet
-    --    * 1 = outgone fetches, for debugging eg: timeouts
-    --    * 2 = data fetch stats & errors
-    --    * 3 = (same as 2, this used to enable errors)
-    --    * 4 = profiling
-    --    * 5 = log stack traces of dataFetch calls
+  , report :: {-# UNPACK #-} !ReportFlags
+    -- ^ Report flags
   , caching :: {-# UNPACK #-} !Int
     -- ^ Non-zero if caching is enabled.  If caching is disabled, then
     -- we still do batching and de-duplication, but do not cache
@@ -48,7 +108,7 @@
 defaultFlags :: Flags
 defaultFlags = Flags
   { trace = 0
-  , report = 0
+  , report = defaultReportFlags
   , caching = 1
   , recording = 0
   }
@@ -57,9 +117,9 @@
 ifTrace :: Monad m => Flags -> Int -> m a -> m ()
 ifTrace flags i = when (trace flags >= i) . void
 
--- | Runs an action if the report level is above the given threshold.
-ifReport :: Monad m => Flags -> Int -> m a -> m ()
-ifReport flags i = when (report flags >= i) . void
+-- | Runs an action if the ReportFlag is set.
+ifReport :: Monad m => Flags -> ReportFlag -> m a -> m ()
+ifReport flags i = when (testReportFlag i $ report flags) . void
 
 ifProfiling :: Monad m => Flags -> m a -> m ()
-ifProfiling flags = when (report flags >= 4) . void
+ifProfiling flags = ifReport flags ReportProfiling
diff --git a/Haxl/Core/Memo.hs b/Haxl/Core/Memo.hs
--- a/Haxl/Core/Memo.hs
+++ b/Haxl/Core/Memo.hs
@@ -202,7 +202,7 @@
   case stored of
     -- Memo was not prepared first; throw an exception.
     MemoEmpty -> trace_ "MemoEmpty " $
-      raise $ CriticalError "Attempting to run empty memo."
+      raise env $ CriticalError "Attempting to run empty memo."
     -- Memo has been prepared but not run yet
     MemoReady cont k -> trace_ "MemoReady" $ do
       ivar <- newIVar
@@ -220,7 +220,8 @@
   -> IVar u w a
   -> CallId
   -> IO (Result u w a)
-execMemoNowProfiled envOuter cont ivar cid = if report (flags envOuter) < 4
+execMemoNowProfiled envOuter cont ivar cid =
+  if not $ testReportFlag ReportProfiling $ report $ flags envOuter
   then execMemoNow envOuter cont ivar
   else do
     incrementMemoHitCounterFor envOuter cid False
diff --git a/Haxl/Core/Monad.hs b/Haxl/Core/Monad.hs
--- a/Haxl/Core/Monad.hs
+++ b/Haxl/Core/Monad.hs
@@ -48,6 +48,7 @@
   , flattenWT
   , appendWTs
   , mbModifyWLRef
+  , mapWrites
 
     -- * Cont
   , Cont(..)
@@ -75,6 +76,8 @@
     -- * Env
   , Env(..)
   , DataCacheItem(..)
+  , DataCacheLookup(..)
+  , HaxlDataCache
   , Caches
   , caches
   , initEnvWithData
@@ -125,7 +128,6 @@
 import Control.Applicative (liftA2)
 import Control.Arrow (left)
 import Control.Concurrent.STM
-import qualified Data.Text as Text
 import qualified Control.Monad.Catch as Catch
 import Control.Exception (Exception(..), SomeException, throwIO)
 #if __GLASGOW_HASKELL__ >= 808
@@ -135,12 +137,16 @@
 import Control.Monad
 #endif
 import qualified Control.Exception as Exception
+import Data.Either (rights)
 import Data.IORef
 import Data.Int
-import Data.Either (rights)
+import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.List.NonEmpty as NonEmpty
 #if __GLASGOW_HASKELL__ < 804
 import Data.Semigroup
 #endif
+import qualified Data.Text as Text
+import Data.Typeable
 import GHC.Exts (IsString(..))
 import Text.PrettyPrint hiding ((<>))
 import Text.Printf
@@ -152,7 +158,6 @@
 #ifdef PROFILING
 import qualified Data.Map as Map
 import Data.Text (Text)
-import Data.Typeable
 import Foreign.Ptr (Ptr)
 import GHC.Stack
 import Haxl.Core.CallGraph
@@ -164,12 +169,18 @@
 -- | The data we carry around in the Haxl monad.
 
 data DataCacheItem u w a = DataCacheItem (IVar u w a) {-# UNPACK #-} !CallId
+type HaxlDataCache u w = DataCache (DataCacheItem u w)
+newtype DataCacheLookup w =
+  DataCacheLookup
+    (forall req a . Typeable (req a)
+    => req a
+    -> IO (Maybe (ResultVal a w)))
 
 data Env u w = Env
-  { dataCache     :: {-# UNPACK #-} !(DataCache (DataCacheItem u w))
+  { dataCache     :: {-# UNPACK #-} !(HaxlDataCache u w)
       -- ^ cached data fetches
 
-  , memoCache      :: {-# UNPACK #-} !(DataCache (DataCacheItem u w))
+  , memoCache      :: {-# UNPACK #-} !(HaxlDataCache u w)
       -- ^ memoized computations
 
   , memoKey    :: {-# UNPACK #-} !CallId
@@ -233,6 +244,11 @@
        -- ^ This is just a specialized version of @writeLogsRef@, where we put
        -- logs that user doesn't want memoized. This is a better alternative to
        -- doing arbitrary IO from a (memoized) Haxl computation.
+
+  , dataCacheFetchFallback :: !(Maybe (DataCacheLookup w))
+       -- ^ Allows you to inject a DataCache lookup just before a dataFetch is
+       -- dispatched. This is useful for injecting fetch results in testing.
+
 #ifdef PROFILING
   , callGraphRef ::  Maybe (IORef CallGraph)
        -- ^ An edge list representing the current function call graph. The type
@@ -245,15 +261,15 @@
 
 data ProfileCurrent = ProfileCurrent
   { profCurrentKey ::  {-# UNPACK #-} !ProfileKey
-  , profCurrentLabel :: {-# UNPACK #-} !ProfileLabel
+  , profLabelStack :: {-# UNPACK #-} !(NonEmpty ProfileLabel)
   }
 
-type Caches u w = (DataCache (DataCacheItem u w), DataCache (DataCacheItem u w))
+type Caches u w = (HaxlDataCache u w, HaxlDataCache u w)
 
 caches :: Env u w -> Caches u w
 caches env = (dataCache env, memoCache env)
 
-getMaxCallId :: DataCache (DataCacheItem u w) -> IO (Maybe Int)
+getMaxCallId :: HaxlDataCache u w -> IO (Maybe Int)
 getMaxCallId c = do
   callIds  <- rights . concatMap snd <$>
               DataCache.readCache c (\(DataCacheItem _ i) -> return i)
@@ -288,7 +304,7 @@
     , states = states
     , statsRef = sref
     , statsBatchIdRef = sbref
-    , profCurrent = ProfileCurrent 0 "MAIN"
+    , profCurrent = ProfileCurrent 0 $ "MAIN" :| []
     , callIdRef = ciref
     , profRef = pref
     , reqStoreRef = rs
@@ -297,6 +313,7 @@
     , completions = comps
     , writeLogsRef = wl
     , writeLogsRefNoMemo = wlnm
+    , dataCacheFetchFallback = Nothing
 #ifdef PROFILING
     , callGraphRef = Nothing
     , currFunction = mainFunction
@@ -380,6 +397,12 @@
 mbModifyWLRef NilWrites _ = return ()
 mbModifyWLRef !wt ref = modifyIORef' ref (`appendWTs` wt)
 
+mapWriteTree :: (w -> w) -> WriteTree w -> WriteTree w
+mapWriteTree _ NilWrites = NilWrites
+mapWriteTree f (SomeWrite w) = SomeWrite (f w)
+mapWriteTree f (MergeWrites wt1 wt2) =
+  MergeWrites (mapWriteTree f wt1) (mapWriteTree f wt2)
+
 -- -----------------------------------------------------------------------------
 -- | The Haxl monad, which does several things:
 --
@@ -514,28 +537,28 @@
 #endif
 
 getIVar :: IVar u w a -> GenHaxl u w a
-getIVar i@IVar{ivarRef = !ref} = GenHaxl $ \Env{..} -> do
+getIVar i@IVar{ivarRef = !ref} = GenHaxl $ \env -> do
   e <- readIORef ref
   case e of
     IVarFull (Ok a _wt) -> return (Done a)
-    IVarFull (ThrowHaxl e _wt) -> raiseFromIVar i e
+    IVarFull (ThrowHaxl e _wt) -> raiseFromIVar env i e
     IVarFull (ThrowIO e) -> throwIO e
     IVarEmpty _ -> return (Blocked i (Return i))
 
 -- Just a specialised version of getIVar, for efficiency in <*>
 getIVarApply :: IVar u w (a -> b) -> a -> GenHaxl u w b
-getIVarApply i@IVar{ivarRef = !ref} a = GenHaxl $ \Env{..} -> do
+getIVarApply i@IVar{ivarRef = !ref} a = GenHaxl $ \env -> do
   e <- readIORef ref
   case e of
     IVarFull (Ok f _wt) -> return (Done (f a))
-    IVarFull (ThrowHaxl e _wt) -> raiseFromIVar i e
+    IVarFull (ThrowHaxl e _wt) -> raiseFromIVar env i e
     IVarFull (ThrowIO e) -> throwIO e
     IVarEmpty _ ->
       return (Blocked i (Cont (getIVarApply i a)))
 
 -- Another specialised version of getIVar, for efficiency in cachedComputation
 getIVarWithWrites :: IVar u w a -> GenHaxl u w a
-getIVarWithWrites i@IVar{ivarRef = !ref} = GenHaxl $ \Env{..} -> do
+getIVarWithWrites i@IVar{ivarRef = !ref} = GenHaxl $ \env@Env{..} -> do
   e <- readIORef ref
   case e of
     IVarFull (Ok a wt) -> do
@@ -543,7 +566,7 @@
       return (Done a)
     IVarFull (ThrowHaxl e wt) -> do
       mbModifyWLRef wt writeLogsRef
-      raiseFromIVar i e
+      raiseFromIVar env i e
     IVarFull (ThrowIO e) -> throwIO e
     IVarEmpty _ ->
       return (Blocked i (Cont (getIVarWithWrites i)))
@@ -586,10 +609,10 @@
   | ThrowIO SomeException
     -- we get no write logs when an IO exception occurs
 
-done :: ResultVal a w -> IO (Result u w a)
-done (Ok a _) = return (Done a)
-done (ThrowHaxl e _) = raise e
-done (ThrowIO e) = throwIO e
+done :: Env u w -> ResultVal a w -> IO (Result u w a)
+done _ (Ok a _) = return (Done a)
+done env (ThrowHaxl e _) = raise env e
+done _ (ThrowIO e) = throwIO e
 
 eitherToResultThrowIO :: Either SomeException a -> ResultVal a w
 eitherToResultThrowIO (Right a) = Ok a NilWrites
@@ -612,7 +635,7 @@
 -- the relevant computations.
 data CompleteReq u w
   = forall a . CompleteReq
-      (Either SomeException a)
+      (ResultVal a w)
       !(IVar u w a)  -- IVar because the result is cached
       {-# UNPACK #-} !Int64 -- see Note [tracking allocation in child threads]
 
@@ -874,6 +897,36 @@
 nextCallId :: Env u w -> IO CallId
 nextCallId env = atomicModifyIORef' (callIdRef env) $ \x -> (x+1,x+1)
 
+-- | Runs the Haxl computation, transforming the writes within using the
+-- provided function.
+--
+-- Memoization behavior is unchanged, meaning if a memoized computation is run
+-- once inside @mapWrites@ and then once without, the writes from the second run
+-- will NOT be transformed.
+mapWrites :: (w -> w) -> GenHaxl u w a -> GenHaxl u w a
+mapWrites f action = GenHaxl $ \curEnv -> do
+  wlogs <- newIORef NilWrites
+  wlogsNoMemo <- newIORef NilWrites
+  let
+    !newEnv = curEnv { writeLogsRef = wlogs, writeLogsRefNoMemo = wlogsNoMemo }
+  unHaxl (mapWritesImpl curEnv newEnv action) newEnv
+  where
+    mapWritesImpl oldEnv curEnv (GenHaxl m) = GenHaxl $ \_ -> do
+      let
+        pushTransformedWrites = do
+          wt <- readIORef $ writeLogsRef curEnv
+          mbModifyWLRef (mapWriteTree f wt) (writeLogsRef oldEnv)
+          wtNoMemo <- readIORef $ writeLogsRefNoMemo curEnv
+          mbModifyWLRef (mapWriteTree f wtNoMemo) (writeLogsRefNoMemo oldEnv)
+
+      r <- m curEnv
+
+      case r of
+        Done a -> pushTransformedWrites >> return (Done a)
+        Throw e -> pushTransformedWrites >> return (Throw e)
+        Blocked ivar k -> return
+          (Blocked ivar (Cont (mapWritesImpl oldEnv curEnv (toHaxl k))))
+
 #ifdef PROFILING
 -- -----------------------------------------------------------------------------
 -- CallGraph recording
@@ -909,34 +962,42 @@
 -- Exceptions
 
 -- | Throw an exception in the Haxl monad
-throw :: (Exception e) => e -> GenHaxl u w a
-throw e = GenHaxl $ \_env -> raise e
+throw :: Exception e => e -> GenHaxl u w a
+throw e = GenHaxl $ \env -> raise env e
 
-raise :: (Exception e) => e -> IO (Result u w a)
-raise e
+raise :: Exception e => Env u w -> e -> IO (Result u w a)
+raise env e = raiseImpl env (toException e)
 #ifdef PROFILING
-  | Just (HaxlException Nothing h) <- fromException somex = do
-    stk <- currentCallStack
-    return (Throw (toException (HaxlException (Just stk) h)))
-  | otherwise
+  currentCallStack
 #endif
-    = return (Throw somex)
-  where
-    somex = toException e
 
-raiseFromIVar :: Exception e => IVar u w a -> e -> IO (Result u w b)
+
+raiseFromIVar :: Exception e => Env u w -> IVar u w a -> e -> IO (Result u w b)
 #ifdef PROFILING
-raiseFromIVar ivar e
-  | Just (HaxlException Nothing h) <- fromException somex = do
-    stk <- ccsToStrings (ivarCCS ivar)
-    return (Throw (toException (HaxlException (Just stk) h)))
-  | otherwise
+raiseFromIVar env IVar{..} e =
+  raiseImpl env (toException e) (ccsToStrings ivarCCS)
 #else
-raiseFromIVar _ivar e
+raiseFromIVar env _ivar e = raiseImpl env (toException e)
 #endif
-    = return (Throw somex)
-  where
-    somex = toException e
+
+{-# INLINE raiseImpl #-}
+#ifdef PROFILING
+raiseImpl :: Env u w -> SomeException -> IO [String] -> IO (Result u w b)
+raiseImpl Env{..} e getCostCentreStack
+#else
+raiseImpl :: Env u w -> SomeException -> IO (Result u w b)
+raiseImpl Env{..} e
+#endif
+  | testReportFlag ReportExceptionLabelStack $ report flags
+  , Just (HaxlException Nothing h) <- fromException e = do
+    let stk = NonEmpty.toList $ profLabelStack profCurrent
+    return $ Throw $ toException $ HaxlException (Just stk) h
+#ifdef PROFILING
+  | Just (HaxlException Nothing h) <- fromException e = do
+    stk <- reverse . map Text.pack <$> getCostCentreStack
+    return $ Throw $ toException $ HaxlException (Just stk) h
+#endif
+  | otherwise = return $ Throw e
 
 -- | Catch an exception in the Haxl monad
 catch :: Exception e => GenHaxl u w a -> (e -> GenHaxl u w a) -> GenHaxl u w a
diff --git a/Haxl/Core/Parallel.hs b/Haxl/Core/Parallel.hs
--- a/Haxl/Core/Parallel.hs
+++ b/Haxl/Core/Parallel.hs
@@ -47,7 +47,7 @@
              -> GenHaxl u w r
              -> GenHaxl u w t
 biselect_opt discrimA discrimB left right haxla haxlb =
-  let go (GenHaxl haxla) (GenHaxl haxlb) = GenHaxl $ \env@Env{..} -> do
+  let go (GenHaxl haxla) (GenHaxl haxlb) = GenHaxl $ \env -> do
         ra <- haxla env
         case ra of
           Done ea ->
diff --git a/Haxl/Core/Profile.hs b/Haxl/Core/Profile.hs
--- a/Haxl/Core/Profile.hs
+++ b/Haxl/Core/Profile.hs
@@ -4,6 +4,7 @@
 -- This source code is distributed under the terms of a BSD license,
 -- found in the LICENSE file.
 
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE MagicHash #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -25,6 +26,7 @@
 
 import Data.IORef
 import Data.Hashable
+import Data.List.NonEmpty (NonEmpty(..), (<|))
 #if __GLASGOW_HASKELL__ < 804
 import Data.Monoid
 #endif
@@ -43,7 +45,7 @@
 -- | Label a computation so profiling data is attributed to the label.
 withLabel :: ProfileLabel -> GenHaxl u w a -> GenHaxl u w a
 withLabel l (GenHaxl m) = GenHaxl $ \env ->
-  if report (flags env) < 4
+  if not $ testReportFlag ReportProfiling $ report $ flags env
      then m env
      else collectProfileData l m env
 
@@ -51,7 +53,7 @@
 -- Intended only for internal use by 'memoFingerprint'.
 withFingerprintLabel :: Addr# -> Addr# -> GenHaxl u w a -> GenHaxl u w a
 withFingerprintLabel mnPtr nPtr (GenHaxl m) = GenHaxl $ \env ->
-  if report (flags env) < 4
+  if not $ testReportFlag ReportProfiling $ report $ flags env
      then m env
      else collectProfileData
             (Text.unpackCString# mnPtr <> "." <> Text.unpackCString# nPtr)
@@ -64,7 +66,7 @@
   -> Env u w
   -> IO (Result u w a)
 collectProfileData l m env = do
-  let (ProfileCurrent prevProfKey prevProfLabel) = profCurrent env
+  let ProfileCurrent prevProfKey (prevProfLabel :| _) = profCurrent env
   if prevProfLabel == l
   then
     -- do not add a new label if we are recursing
@@ -93,12 +95,22 @@
   t0 <- getTimestamp
   a0 <- getAllocationCounter
   let
+    ProfileCurrent caller stack = profCurrent env
     nextCurrent = ProfileCurrent
-                  { profCurrentKey = key
-                  , profCurrentLabel = l }
-    caller = profCurrentKey (profCurrent env)
+      { profCurrentKey = key
+      , profLabelStack = l <| stack
+      }
+    runCont (GenHaxl h) = GenHaxl $ runProfileData l key h True
 
   r <- m env{profCurrent=nextCurrent} -- what if it throws?
+
+  -- Make the result strict in Done/Throw so that if the user code
+  -- returns (force a), the force is evaluated *inside* the profile.
+  result <- case r of
+    Done !a -> return (Done a)
+    Throw !e -> return (Throw e)
+    Blocked ivar k -> return (Blocked ivar (Cont $ runCont (toHaxl k)))
+
   a1 <- getAllocationCounter
   t1 <- getTimestamp
 
@@ -111,12 +123,7 @@
 
   -- So we do not count the allocation overhead of modifyProfileData
   setAllocationCounter a1
-  case r of
-    Done a -> return (Done a)
-    Throw e -> return (Throw e)
-    Blocked ivar k -> return (Blocked ivar (Cont $ runCont (toHaxl k)))
-  where
-    runCont (GenHaxl h) = GenHaxl $ runProfileData l key h True
+  return result
 {-# INLINE runProfileData #-}
 
 modifyProfileData
@@ -180,7 +187,7 @@
   t1 <- getTimestamp
   let
     allocs = a0 - a1
-    t = t0 - t1
+    t = t1 - t0
     newEntry = emptyProfileData
       { profileAllocs = allocs
       , profileTime = t
diff --git a/Haxl/Core/RequestStore.hs b/Haxl/Core/RequestStore.hs
--- a/Haxl/Core/RequestStore.hs
+++ b/Haxl/Core/RequestStore.hs
@@ -44,6 +44,7 @@
 import qualified Data.Map.Strict as Map
 import Data.Proxy
 import Data.Text (Text)
+import Data.Kind (Type)
 import Data.Typeable
 import Unsafe.Coerce
 
@@ -110,7 +111,7 @@
 emptyReqCounts = ReqCountMap Map.empty
 
 addToCountMap
-  :: forall (r :: * -> *). (DataSourceName r, Typeable r)
+  :: forall (r :: Type -> Type). (DataSourceName r, Typeable r)
   => Proxy r
   -> Int -- type and number of requests
   -> ReqCountMap
@@ -118,7 +119,7 @@
 addToCountMap = updateCountMap (+)
 
 subFromCountMap
-  :: forall (r :: * -> *). (DataSourceName r, Typeable r)
+  :: forall (r :: Type -> Type). (DataSourceName r, Typeable r)
   => Proxy r
   -> Int -- type and number of requests
   -> ReqCountMap
@@ -126,7 +127,7 @@
 subFromCountMap = updateCountMap (-)
 
 updateCountMap
-  :: forall (r :: * -> *). (DataSourceName r, Typeable r)
+  :: forall (r :: Type -> Type). (DataSourceName r, Typeable r)
   => (Int -> Int -> Int)
   -> Proxy r
   -> Int -- type and number of requests
diff --git a/Haxl/Core/Run.hs b/Haxl/Core/Run.hs
--- a/Haxl/Core/Run.hs
+++ b/Haxl/Core/Run.hs
@@ -96,7 +96,7 @@
                        _ -> modifyIORef' runQueueRef (appendJobList rq)
                    else reschedule env (appendJobList haxls rq)
       r <-
-        if report flags >= 4          -- withLabel unfolded
+        if testReportFlag ReportProfiling $ report flags  -- withLabel unfolded
           then Exception.try $ profileCont run env
           else Exception.try $ run env
       case r of
@@ -142,7 +142,7 @@
           schedule env' c a b
 
     emptyRunQueue :: Env u w -> IO ()
-    emptyRunQueue env@Env{..} = do
+    emptyRunQueue env = do
       ifTraceLog $ printf "emptyRunQueue\n"
       haxls <- checkCompletions env
       case haxls of
@@ -195,7 +195,7 @@
                     -- pushed on the front of the completions list) and
                     -- therefore overrides it.
                   IVarEmpty cv -> do
-                    writeIORef cr (IVarFull (eitherToResult a))
+                    writeIORef cr (IVarFull a)
                     return cv
           jobs <- mapM getComplete comps
           return (foldr appendJobList JobNil jobs)
@@ -229,7 +229,7 @@
                         , fetchWaitDuration = (end-start)
                         }
               modifyIORef' statsRef $ \(Stats s) -> Stats (fw:s)
-      if report flags >= 2
+      if testReportFlag ReportFetchStats $ report flags
         then doWaitProfiled
         else doWait
       emptyRunQueue env
@@ -237,10 +237,12 @@
   --
   schedule env JobNil haxl result
   r <- readIORef resultRef
+  writeIORef writeLogsRef NilWrites
+  wtNoMemo <- atomicModifyIORef' writeLogsRefNoMemo
+    (\old_wrts -> (NilWrites , old_wrts))
   case r of
     IVarEmpty _ -> throwIO (CriticalError "runHaxl: missing result")
     IVarFull (Ok a wt) -> do
-      wtNoMemo <- readIORef writeLogsRefNoMemo
       return (a, flattenWT (wt `appendWTs` wtNoMemo))
     IVarFull (ThrowHaxl e _wt)  -> throwIO e
       -- The written logs are discarded when there's a Haxl exception. We
diff --git a/Haxl/Core/StateStore.hs b/Haxl/Core/StateStore.hs
--- a/Haxl/Core/StateStore.hs
+++ b/Haxl/Core/StateStore.hs
@@ -23,6 +23,7 @@
   ) where
 
 import Data.Map (Map)
+import Data.Kind (Type)
 import qualified Data.Map.Strict as Map
 #if __GLASGOW_HASKELL__ < 804
 import Data.Monoid
@@ -34,7 +35,7 @@
 -- instance of 'StateKey' can store and retrieve information from a
 -- 'StateStore'.
 --
-class Typeable f => StateKey (f :: * -> *) where
+class Typeable f => StateKey (f :: Type -> Type) where
   data State f
 
   -- | We default this to typeOf1, but if f is itself a complex type that is
diff --git a/Haxl/Core/Stats.hs b/Haxl/Core/Stats.hs
--- a/Haxl/Core/Stats.hs
+++ b/Haxl/Core/Stats.hs
@@ -6,6 +6,7 @@
 
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE CPP #-}
@@ -23,6 +24,7 @@
   , FetchStats(..)
   , Microseconds
   , Timestamp
+  , DataSourceStats(..)
   , getTimestamp
   , emptyStats
   , numFetches
@@ -59,6 +61,7 @@
 import Data.Ord (Down(..))
 import Data.Text (Text)
 import Data.Time.Clock.POSIX
+import Data.Typeable
 import Text.Printf
 import qualified Data.HashMap.Strict as HashMap
 import qualified Data.Text as Text
@@ -79,6 +82,16 @@
 -- ---------------------------------------------------------------------------
 -- Stats
 
+data DataSourceStats =
+  forall a. (Typeable a, Show a, Eq a, ToJSON a) => DataSourceStats a
+
+instance Show DataSourceStats where
+  show (DataSourceStats x) = printf "DataSourceStats %s" (show x)
+
+instance Eq DataSourceStats where
+  (==) (DataSourceStats a) (DataSourceStats b) =
+    cast a == Just b
+
 -- | Stats that we collect along the way.
 newtype Stats = Stats [FetchStats]
   deriving (Show, ToJSON, Semigroup, Monoid)
@@ -101,6 +114,7 @@
   where
     isFetchStats FetchStats{} = True
     isFetchStats FetchWait{} = True
+    isFetchStats FetchDataSourceStats{} = True
     isFetchStats _ = False
     validFetchStats = filter isFetchStats (reverse rss)
     numDashes = 50
@@ -159,6 +173,12 @@
     , fetchWaitStart :: {-# UNPACK #-} !Timestamp
     , fetchWaitDuration :: {-# UNPACK #-} !Microseconds
     }
+  | FetchDataSourceStats
+    { fetchDsStatsCallId :: CallId
+    , fetchDsStatsDataSource :: Text
+    , fetchDsStatsStats :: DataSourceStats
+    , fetchBatchId :: {-# UNPACK #-} !Int
+    }
   deriving (Eq, Show)
 
 -- | Pretty-print RoundStats.
@@ -183,6 +203,9 @@
     msg x = printf "%s (%.2fms)"
                 x
                 (fromIntegral fetchWaitDuration / 1000 :: Double)
+ppFetchStats FetchDataSourceStats{..} =
+  printf "%s (stats): %s" (Text.unpack fetchDsStatsDataSource)
+    (show fetchDsStatsStats)
 
 -- | Aggregate stats merging FetchStats from the same dispatched batch into one.
 aggregateFetchBatches :: ([FetchStats] -> a) -> Stats -> [a]
@@ -220,6 +243,14 @@
     [ "type" .= ("FetchWait" :: Text)
     , "duration" .= fetchWaitDuration
     ]
+  toJSON FetchDataSourceStats{..} = object
+    [ "type" .= ("FetchDataSourceStats" :: Text)
+    , "datasource" .= fetchDsStatsDataSource
+    , "stats" .= sjson fetchDsStatsStats
+    , "batchid" .= fetchBatchId
+    ]
+    where
+      sjson (DataSourceStats s) = toJSON s
 
 emptyStats :: Stats
 emptyStats = Stats []
diff --git a/changelog.md b/changelog.md
--- a/changelog.md
+++ b/changelog.md
@@ -1,6 +1,10 @@
-# Changes in version <next>
+# Changes in version 2.4.0.0
   * Added fetchBatchId to FetchStats
   * Profiling now tracks full stacks and links each label to memos/fetches
+  * Adds FetchDataSourceStats used to log stats/profiling data returned
+    from datasources. This is stored in statsRef like any other Stats.
+  * Report flag was changed from sequential numbers to bitmask.
+  * Add ReportExceptionLabelStack flag to include label stack in HaxlException.
 
 # Changes in version 2.3.0.0
   * Removed `FutureFetch`
diff --git a/haxl.cabal b/haxl.cabal
--- a/haxl.cabal
+++ b/haxl.cabal
@@ -1,5 +1,5 @@
 name:                haxl
-version:             2.3.0.0
+version:             2.4.0.0
 synopsis:            A Haskell library for efficient, concurrent,
                      and concise data access.
 homepage:            https://github.com/facebook/Haxl
@@ -43,7 +43,7 @@
 library
 
   build-depends:
-    aeson >= 0.6 && < 1.6,
+    aeson >= 0.6 && < 2.1,
     base >= 4.10 && < 5,
     binary >= 0.7 && < 0.10,
     bytestring >= 0.9 && < 0.11,
@@ -132,6 +132,7 @@
     CoreTests
     DataCacheTest
     ExampleDataSource
+    ExceptionStackTests
     FullyAsyncTest
     LoadCache
     MemoizationTests
@@ -148,6 +149,7 @@
     TestUtils
     WorkDataSource
     WriteTests
+    DataSourceDispatchTests
 
   type:
     exitcode-stdio-1.0
diff --git a/readme.md b/readme.md
--- a/readme.md
+++ b/readme.md
@@ -1,8 +1,8 @@
-![Haxl Logo](https://github.com/facebook/Haxl/raw/master/logo.png)
+![Haxl Logo](https://raw.githubusercontent.com/facebook/Haxl/main/logo.png)
 
 # Haxl
 
-[![Build Status](https://travis-ci.org/facebook/Haxl.svg?branch=master)](https://travis-ci.org/facebook/Haxl)
+[![Support Ukraine](https://img.shields.io/badge/Support-Ukraine-FFD500?style=flat&labelColor=005BBB)](https://opensource.fb.com/support-ukraine) [![Build Status](https://travis-ci.org/facebook/Haxl.svg?branch=master)](https://travis-ci.org/facebook/Haxl)
 
 Haxl is a Haskell library that simplifies access to remote data, such
 as databases or web-based services. Haxl can automatically
diff --git a/tests/AllTests.hs b/tests/AllTests.hs
--- a/tests/AllTests.hs
+++ b/tests/AllTests.hs
@@ -11,6 +11,7 @@
 import BatchTests
 import CoreTests
 import DataCacheTest
+import ExceptionStackTests
 import AdoTests
 import OutgoneFetchesTests
 import ProfileTests
@@ -21,6 +22,7 @@
 import WriteTests
 import ParallelTests
 import StatsTests
+import DataSourceDispatchTests
 
 import Test.HUnit
 
@@ -31,6 +33,7 @@
   , TestLabel "BatchTests-sync" $ BatchTests.tests False
   , TestLabel "CoreTests" CoreTests.tests
   , TestLabel "DataCacheTests" DataCacheTest.tests
+  , TestLabel "ExceptionStackTests" ExceptionStackTests.tests
   , TestLabel "AdoTests" $ AdoTests.tests False
   , TestLabel "OutgoneFetchesTest" OutgoneFetchesTests.tests
   , TestLabel "ProfileTests" ProfileTests.tests
@@ -41,4 +44,5 @@
   , TestLabel "WriteTest" WriteTests.tests
   , TestLabel "ParallelTest" ParallelTests.tests
   , TestLabel "StatsTests" StatsTests.tests
+  , TestLabel "DataSourceDispatchTests" DataSourceDispatchTests.tests
   ]
diff --git a/tests/DataCacheTest.hs b/tests/DataCacheTest.hs
--- a/tests/DataCacheTest.hs
+++ b/tests/DataCacheTest.hs
@@ -5,6 +5,10 @@
 -- found in the LICENSE file.
 
 {-# LANGUAGE StandaloneDeriving, GADTs, DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
 module DataCacheTest (tests, newResult, takeResult) where
 
 import Haxl.Core.DataCache as DataCache
@@ -12,12 +16,15 @@
 import Haxl.Core
 
 import Control.Exception
+import Data.Either
 import Data.Hashable
 import Data.Traversable
 import Data.Typeable
 import Prelude hiding (mapM)
 import Test.HUnit
 import Data.IORef
+import Data.Text
+import Unsafe.Coerce
 
 data TestReq a where
    Req :: Int -> TestReq a -- polymorphic result
@@ -29,11 +36,30 @@
 instance Hashable (TestReq a) where
   hashWithSalt salt (Req i) = hashWithSalt salt i
 
+instance DataSource u TestReq where
+  fetch = error "no fetch defined"
+
+instance DataSourceName TestReq where
+  dataSourceName _ = pack "TestReq"
+
+instance StateKey TestReq where
+  data State TestReq = TestReqState
+
+instance ShowP TestReq where showp = show
+
+data CacheableReq x where CacheableInt :: Int -> CacheableReq Int
+  deriving Typeable
+deriving instance Eq (CacheableReq x)
+deriving instance Show (CacheableReq x)
+instance Hashable (CacheableReq x) where
+  hashWithSalt s (CacheableInt val) = hashWithSalt s (0::Int, val)
+
+
 newResult :: a -> IO (IVar u w a)
-newResult a = IVar <$> newIORef (IVarFull (Ok a NilWrites))
+newResult a = newFullIVar (Ok a NilWrites)
 
 takeResult :: IVar u w a -> IO (ResultVal a w)
-takeResult (IVar ref) = do
+takeResult IVar{ivarRef = ref} = do
   e <- readIORef ref
   case e of
     IVarFull a -> return a
@@ -85,5 +111,90 @@
       Left (ErrorCall "BOOM") -> True
       _other -> False
 
+dcFallbackTest :: Test
+dcFallbackTest = TestLabel "DataCache fallback" $ TestList
+  [ TestLabel "Base" $ TestCase $ do
+      env <- mkEnv
+      (r,cached) <- runHaxl env (do
+                           a <- dataFetch req
+                           b <- cacheResult (CacheableInt 1234) (return 99999)
+                           return (a,b))
+      (Stats stats) <- readIORef (statsRef env)
+      assertEqual "fallback still has stats" 1
+        (Prelude.length [x | x@FetchStats{} <- stats])
+      assertEqual "dcFallbackTest found" 1 r
+      assertEqual "dcFallbackTest cached" 1234 cached
+  , TestLabel "Exception" $ TestCase $ do
+      env <- mkEnv
+      rbad <- Control.Exception.try $ runHaxl env (dataFetch reqBad)
+      assertBool "dcFallbackTest not found" $
+        case rbad of
+          Left (ErrorCall "no fetch defined") -> True
+          _ -> False
+  , TestLabel "Completions" $ TestCase $ do
+      -- check applicative still runs as it would have without a fallback
+      env <- mkEnv
+      let
+        fetchA = dataFetch reqEx
+        fetchB = tellWrite 7 >> dataFetch req
+      (rbad, writes) <- runHaxlWithWrites env $
+        Haxl.Core.try $ (,) <$> fetchA <*> fetchB
+      fetches <- countFetches env
+      assertEqual "dispatched 2 fetches" 2 fetches
+      assertBool "exception propogates" $
+        case rbad of
+          Left (NotFound _) -> True
+          _ -> False
+      assertEqual "write side effects happen" [7] writes
+  ]
+  where
+
+    mkEnv = addLookup <$> initEnv (stateSet TestReqState stateEmpty) ()
+
+    countFetches env = do
+      (Stats stats) <- readIORef (statsRef env)
+      let
+        c = sum [ fetchBatchSize x
+                | x@FetchStats{} <- stats
+                ]
+      return c
+
+    addLookup :: Env () Int -> Env () Int
+    addLookup e = e { dataCacheFetchFallback = Just (DataCacheLookup lookup)
+                    , flags = (flags e) { report = profilingReportFlags }
+                    }
+    lookup
+      :: forall req a . Typeable (req a)
+      => req a
+      -> IO (Maybe (ResultVal a Int))
+    lookup r
+      | typeOf r == typeRep (Proxy :: Proxy (TestReq Int)) =
+        -- have to coerce on the way out as results are not Typeable
+        -- so you better be sure you do it right!
+        return $ unsafeCoerce . doReq <$> cast r
+      | typeOf r == typeRep (Proxy :: Proxy (CacheableReq Int)) =
+          return $ unsafeCoerce . doCache <$> cast r
+      | otherwise = return Nothing
+
+    doReq :: TestReq Int -> ResultVal Int Int
+    doReq (Req 999) = ThrowHaxl (toException $ NotFound empty) NilWrites
+    doReq (Req r) = Ok r NilWrites
+
+    doCache :: CacheableReq Int -> ResultVal Int Int
+    doCache (CacheableInt i) = Ok i NilWrites
+
+    req :: TestReq Int
+    req = Req 1
+
+    reqEx :: TestReq Int
+    reqEx = Req 999
+
+    reqBad :: TestReq String
+    reqBad = Req 2
+
+
 -- tests :: Assertion
-tests = TestList [dcSoundnessTest, dcStrictnessTest]
+tests = TestList [ dcSoundnessTest
+                 , dcStrictnessTest
+                 , dcFallbackTest
+                 ]
diff --git a/tests/DataSourceDispatchTests.hs b/tests/DataSourceDispatchTests.hs
new file mode 100644
--- /dev/null
+++ b/tests/DataSourceDispatchTests.hs
@@ -0,0 +1,81 @@
+-- Copyright (c) 2014-present, Facebook, Inc.
+-- All rights reserved.
+--
+-- This source code is distributed under the terms of a BSD license,
+-- found in the LICENSE file.
+
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ApplicativeDo #-}
+
+module DataSourceDispatchTests (tests) where
+import Test.HUnit hiding (State)
+import Control.Monad
+import Haxl.Core
+import Data.Hashable
+
+data DataSourceDispatch ty where
+    GetBatchSize :: Int -> DataSourceDispatch Int
+
+deriving instance Eq (DataSourceDispatch ty)
+deriving instance Show (DataSourceDispatch ty)
+
+instance DataSourceName DataSourceDispatch where
+    dataSourceName _ = "DataSourceDispatch"
+
+instance StateKey DataSourceDispatch where
+    data State DataSourceDispatch = DataSourceDispatchState
+
+instance ShowP DataSourceDispatch where showp = show
+
+instance Hashable (DataSourceDispatch a) where
+  hashWithSalt s (GetBatchSize n) = hashWithSalt s n
+
+initDataSource :: IO (State DataSourceDispatch)
+initDataSource = return DataSourceDispatchState
+
+instance DataSource UserEnv DataSourceDispatch where
+    fetch _state _flags _u = SyncFetch $ \bfs -> forM_ bfs (fill $ length bfs)
+      where
+      fill :: Int -> BlockedFetch DataSourceDispatch -> IO ()
+      fill l (BlockedFetch (GetBatchSize _ ) rv) = putResult rv (Right l)
+
+    schedulerHint Batching = TryToBatch
+    schedulerHint NoBatching = SubmitImmediately
+
+data UserEnv = Batching | NoBatching deriving (Eq)
+
+makeTestEnv :: UserEnv -> IO (Env UserEnv ())
+makeTestEnv testUsrEnv = do
+  st <- initDataSource
+  e <- initEnv (stateSet st stateEmpty) testUsrEnv
+  return e { flags = (flags e) {
+    report = setReportFlag ReportFetchStats defaultReportFlags } }
+
+schedulerTest:: Test
+schedulerTest = TestCase $ do
+    let
+        fet = do
+          x <- dataFetch (GetBatchSize 0)
+          y <- dataFetch (GetBatchSize 1)
+          return [x,y]
+
+    e <- makeTestEnv Batching
+    r1 :: [Int] <- runHaxl e fet
+    assertEqual "Failed to create batches for data fetch" [2,2] r1
+
+    eNoBatching <- makeTestEnv NoBatching
+    r2 :: [Int] <- runHaxl eNoBatching fet
+    assertEqual "Unexpexted batches in SubmitImmediately" [1,1] r2
+
+    return ()
+
+tests :: Test
+tests = TestList
+  [ TestLabel "schedulerTest" schedulerTest
+  ]
diff --git a/tests/ExceptionStackTests.hs b/tests/ExceptionStackTests.hs
new file mode 100644
--- /dev/null
+++ b/tests/ExceptionStackTests.hs
@@ -0,0 +1,71 @@
+-- Copyright (c) 2014-present, Facebook, Inc.
+-- All rights reserved.
+--
+-- This source code is distributed under the terms of a BSD license,
+-- found in the LICENSE file.
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module ExceptionStackTests (tests) where
+
+import Prelude ()
+import Haxl.Core
+import Haxl.Prelude
+
+import Test.HUnit
+
+import qualified ExampleDataSource
+
+testEnv :: ReportFlags -> IO (Env () ())
+testEnv report = do
+  exstate <- ExampleDataSource.initGlobalState
+  let st = stateSet exstate stateEmpty
+  env <- initEnv st ()
+  return env{ flags = (flags env){ report = report } }
+
+reportFlags :: ReportFlags
+reportFlags = setReportFlag ReportExceptionLabelStack defaultReportFlags
+
+runHaxlTest
+  :: ReportFlags
+  -> String
+  -> (Int -> Int -> GenHaxl () () Int)
+  -> IO (Maybe [Text])
+runHaxlTest report str func = do
+  env <- testEnv report
+  result <- runHaxl env $
+    withLabel "try" $ tryToHaxlException $ withLabel "test" $ do
+      x <- withLabel "dummy" $ pure 1
+      y <- withLabel "fetch" $ ExampleDataSource.countAardvarks str
+      withLabel "func" $ func x y
+  case result of
+    Left (HaxlException stk _) -> return stk
+    Right{} -> assertFailure "expected: HaxlException"
+
+fetchException :: Test
+fetchException = TestCase $ do
+  result <- runHaxlTest reportFlags "BANG4" $ \i j -> return $ i + j
+  assertEqual "stack" (Just ["fetch", "test", "try", "MAIN"]) result
+
+userException :: Test
+userException = TestCase $ do
+  result <- runHaxlTest reportFlags "aaa" $ \_ _ -> withLabel "throw" $
+    throw $ InvalidParameter "throw"
+  assertEqual "stack" (Just ["throw", "func", "test", "try", "MAIN"]) result
+
+#ifndef PROFILING
+disabledExceptionStack :: Test
+disabledExceptionStack = TestCase $ do
+  result <- runHaxlTest defaultReportFlags "BANG4" $ \i j -> return $ i + j
+  assertEqual "stack" Nothing result
+#endif
+
+tests :: Test
+tests = TestList
+  [ TestLabel "FetchException" fetchException
+  , TestLabel "UserException" userException
+#ifndef PROFILING
+  , TestLabel "DisabledExceptionStack"  disabledExceptionStack
+#endif
+  ]
diff --git a/tests/FullyAsyncTest.hs b/tests/FullyAsyncTest.hs
--- a/tests/FullyAsyncTest.hs
+++ b/tests/FullyAsyncTest.hs
@@ -23,7 +23,8 @@
 testEnv = do
   st <- mkConcurrentIOState
   env <- initEnv (stateSet st stateEmpty) ()
-  return env { flags = (flags env) { report = 2 } }
+  return env { flags = (flags env) {
+    report = setReportFlag ReportFetchStats defaultReportFlags } }
 
 sleepTest :: Test
 sleepTest = TestCase $ do
diff --git a/tests/MonadBench.hs b/tests/MonadBench.hs
--- a/tests/MonadBench.hs
+++ b/tests/MonadBench.hs
@@ -21,8 +21,6 @@
 import Haxl.Prelude as Haxl
 import Prelude()
 
-import Haxl.Core.Memo (newMemoWith, runMemo)
-
 import Haxl.Core
 import Haxl.Core.Util
 
@@ -30,7 +28,7 @@
 
 newtype SimpleWrite = SimpleWrite Text deriving (Eq, Show)
 
-testEnv :: Int -> IO (Env () SimpleWrite)
+testEnv :: ReportFlags -> IO (Env () SimpleWrite)
 testEnv report = do
   exstate <- ExampleDataSource.initGlobalState
   let st = stateSet exstate stateEmpty
@@ -112,7 +110,7 @@
 data Options = Options
   { test :: String
   , nOverride :: Maybe Int
-  , reportFlag :: Int
+  , reportFlag :: ReportFlags
   }
 
 runTest :: Options -> Test -> IO ()
@@ -128,9 +126,14 @@
 optionsParser :: Parser Options
 optionsParser = do
   test <- argument str (metavar "TEST")
-  reportFlag <- option auto (long "report" <> value 0 <> metavar "REPORT")
+  reportFlag <- reportFlagParser
   nOverride <- optional $ argument auto (metavar "NUM")
   return Options{..}
+  where
+    reportFlagParser = foldl' (flip ($)) defaultReportFlags <$> sequenceA
+      [ flag id (setReportFlag i) $ long $ show i
+      | i <- enumFrom minBound
+      ]
 
 main :: IO ()
 main = do
diff --git a/tests/OutgoneFetchesTests.hs b/tests/OutgoneFetchesTests.hs
--- a/tests/OutgoneFetchesTests.hs
+++ b/tests/OutgoneFetchesTests.hs
@@ -13,11 +13,9 @@
 
 import Haxl.Core
 import Haxl.DataSource.ConcurrentIO
-import Haxl.Core.RequestStore (getMapFromRCMap)
 
 import Data.IORef
 import qualified Data.Map as Map
-import Data.Proxy (Proxy(..))
 import Data.Typeable
 import Test.HUnit
 import System.Timeout
@@ -31,7 +29,8 @@
   sleepState <- mkConcurrentIOState
   let st = stateSet exstate $ stateSet sleepState stateEmpty
   e <- initEnv st ()
-  return e { flags = (flags e) {report = 1} }
+  return e { flags = (flags e) {
+    report = setReportFlag ReportOutgoneFetches defaultReportFlags } }
     -- report=1 to enable fetches tracking
 
 -- A cheap haxl computation we interleave b/w the @sleep@ fetches.
diff --git a/tests/ProfileTests.hs b/tests/ProfileTests.hs
--- a/tests/ProfileTests.hs
+++ b/tests/ProfileTests.hs
@@ -7,6 +7,7 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE CPP #-}
 
 module ProfileTests where
 
@@ -23,6 +24,11 @@
 import Data.Aeson
 import Data.IORef
 import qualified Data.HashMap.Strict as HashMap
+#if MIN_VERSION_aeson(2,0,0)
+import qualified Data.Aeson.KeyMap as KeyMap
+#else
+import qualified Data.HashMap.Strict as KeyMap
+#endif
 import Data.Int
 
 import TestUtils
@@ -31,7 +37,7 @@
 
 mkProfilingEnv = do
   env <- makeTestEnv False
-  return env { flags = (flags env) { report = 4 } }
+  return env { flags = (flags env) { report = profilingReportFlags } }
 
 -- expects only one label to be shown
 labelToDataMap :: Profile -> HashMap.HashMap ProfileLabel ProfileData
@@ -53,7 +59,7 @@
               slp <- sum <$> mapM (\x -> withLabel "baz" $ return x) [1..5]
               -- do some non-trivial work that can't be lifted out
               -- first sleep though in order to force a Blocked result
-              sleep slp `andThen` case fromJSON <$> HashMap.lookup "A" u of
+              sleep slp `andThen` case fromJSON <$> KeyMap.lookup "A" u of
                 Just (Success n) | sum [n .. 1000::Integer] > 0 -> return 5
                 _otherwise -> return (4::Int)
   profCopy <- readIORef (profRef e)
@@ -87,6 +93,24 @@
   assertEqual "foo's parent is bar" (Just (head fooParents)) $
     HashMap.lookup ("bar", 0) (profileTree profCopy)
 
+
+collectsLazyData :: Assertion
+collectsLazyData = do
+  e <- mkProfilingEnv
+  _x <- runHaxl e $ withLabel "bar" $ do
+          u <- env userEnv
+          withLabel "foo" $ do
+             let start = if KeyMap.member "A" u
+                         then 10
+                         else 1
+             return $ sum [start..10000::Integer]
+  profCopy <- readIORef (profRef e)
+  -- check the allocations are attributed to foo
+  assertBool "foo has allocations" $
+    case profileAllocs <$> HashMap.lookup "foo" (labelToDataMap profCopy) of
+      Just x -> x > 10000
+      Nothing -> False
+
 exceptions :: Assertion
 exceptions = do
   env <- mkProfilingEnv
@@ -114,7 +138,8 @@
 threadAlloc :: Integer -> Assertion
 threadAlloc batches = do
   env' <- initEnv (stateSet mkWorkState stateEmpty) ()
-  let env = env'  { flags = (flags env') { report = 2 } }
+  let env = env'  { flags = (flags env') {
+    report = setReportFlag ReportFetchStats defaultReportFlags } }
   a0 <- getAllocationCounter
   let
     wsize = 100000
@@ -180,6 +205,7 @@
 
 tests = TestList
   [ TestLabel "collectsdata" $ TestCase collectsdata
+  , TestLabel "collectsdata - lazy" $ TestCase collectsLazyData
   , TestLabel "exceptions" $ TestCase exceptions
   , TestLabel "threads" $ TestCase (threadAlloc 1)
   , TestLabel "threads with batch" $ TestCase (threadAlloc 50)
diff --git a/tests/StatsTests.hs b/tests/StatsTests.hs
--- a/tests/StatsTests.hs
+++ b/tests/StatsTests.hs
@@ -77,7 +77,8 @@
 
   -- Create the Env:
   env <- initEnv st ()
-  return env{ flags = (flags env){ report = 5 } }
+  return env{ flags = (flags env){
+    report = setReportFlag ReportFetchStack profilingReportFlags } }
 
 
 fetchIdsSync :: Test
diff --git a/tests/TestExampleDataSource.hs b/tests/TestExampleDataSource.hs
--- a/tests/TestExampleDataSource.hs
+++ b/tests/TestExampleDataSource.hs
@@ -33,7 +33,8 @@
 
   -- Create the Env:
   env <- initEnv st ()
-  return env{ flags = (flags env){ report = 2 } }
+  return env{ flags = (flags env){
+    report = setReportFlag ReportFetchStats defaultReportFlags } }
 
 
 tests = TestList [
diff --git a/tests/TestTypes.hs b/tests/TestTypes.hs
--- a/tests/TestTypes.hs
+++ b/tests/TestTypes.hs
@@ -7,6 +7,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE CPP #-}
 
 module TestTypes
    ( UserEnv
@@ -18,29 +19,40 @@
 
 import Data.Aeson
 import Data.Binary (Binary)
-import Data.Text (Text)
 import qualified Data.Text as Text
-import qualified Data.HashMap.Strict as HashMap
+#if MIN_VERSION_aeson(2,0,0)
+import qualified Data.Aeson.KeyMap as KeyMap
+import Data.Aeson.Key (toText)
+#else
+import qualified Data.HashMap.Strict as KeyMap
+#endif
 import Data.Hashable
 import Data.Typeable
 
 import Haxl.Core
 
+#if !MIN_VERSION_aeson(2,0,0)
+type Key = Text.Text
+
+toText :: Key -> Text.Text
+toText = id
+#endif
+
 type UserEnv = Object
 type Haxl a = GenHaxl UserEnv () a
 type HaxlEnv = Env UserEnv ()
 
-lookupInput :: FromJSON a => Text -> Haxl a
+lookupInput :: FromJSON a => Key -> Haxl a
 lookupInput field = do
-  mb_val <- env (HashMap.lookup field . userEnv)
+  mb_val <- env (KeyMap.lookup field . userEnv)
   case mb_val of
     Nothing ->
-      throw (NotFound (Text.concat ["field ", field, " was not found."]))
+      throw (NotFound (Text.concat ["field ", toText field, " was not found."]))
     Just val ->
       case fromJSON val of
         Error str ->
           throw (UnexpectedType (Text.concat
-            ["field ", field, ": ", Text.pack str]))
+            ["field ", toText field, ": ", Text.pack str]))
         Success a -> return a
 
 
diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs
--- a/tests/TestUtils.hs
+++ b/tests/TestUtils.hs
@@ -5,6 +5,7 @@
 -- found in the LICENSE file.
 
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
 module TestUtils
   ( makeTestEnv
   , expectResultWithEnv
@@ -21,7 +22,11 @@
 import Data.IORef
 import Data.Aeson
 import Test.HUnit
-import qualified Data.HashMap.Strict as HashMap
+#if MIN_VERSION_aeson(2,0,0)
+import qualified Data.Aeson.KeyMap as KeyMap
+#else
+import qualified Data.HashMap.Strict as KeyMap
+#endif
 
 import Haxl.Core
 
@@ -29,7 +34,7 @@
 import Haxl.Prelude
 
 testinput :: Object
-testinput = HashMap.fromList [
+testinput = KeyMap.fromList [
   "A" .= (1 :: Int),
   "B" .= (2 :: Int),
   "C" .= (3 :: Int),
@@ -53,7 +58,8 @@
   stio <- mkConcurrentIOState
   let st = stateSet stio $ stateSet tao stateEmpty
   env <- initEnv st testinput
-  return env { flags = (flags env) { report = 2 } }
+  return env { flags = (flags env) {
+    report = setReportFlag ReportFetchStats defaultReportFlags } }
 
 expectResultWithEnv
   :: (Eq a, Show a) => a -> Haxl a -> HaxlEnv -> Assertion
diff --git a/tests/WriteTests.hs b/tests/WriteTests.hs
--- a/tests/WriteTests.hs
+++ b/tests/WriteTests.hs
@@ -4,19 +4,60 @@
 -- This source code is distributed under the terms of a BSD license,
 -- found in the LICENSE file.
 
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
 module WriteTests (tests) where
 
 import Test.HUnit
 
+import Control.Concurrent
+import Data.Either
 import Data.Foldable
+import Data.Hashable
+import Data.IORef
+import qualified Data.Text as Text
 
+import Haxl.Core.Monad (mapWrites, flattenWT)
 import Haxl.Core
 import Haxl.Prelude as Haxl
 
+-- A fake data source
+data SimpleDataSource a where
+  GetNumber :: SimpleDataSource Int
+
+deriving instance Eq (SimpleDataSource a)
+deriving instance Show (SimpleDataSource a)
+instance ShowP SimpleDataSource where showp = show
+
+instance Hashable (SimpleDataSource a) where
+  hashWithSalt s GetNumber = hashWithSalt s (0 :: Int)
+
+instance StateKey SimpleDataSource where
+  data State SimpleDataSource = DSState
+
+instance DataSourceName SimpleDataSource where
+  dataSourceName _ = "SimpleDataSource"
+
+instance DataSource u SimpleDataSource where
+  fetch _st _flags _usr  = SyncFetch $ Haxl.mapM_ fetch1
+    where
+    fetch1 :: BlockedFetch SimpleDataSource -> IO ()
+    fetch1 (BlockedFetch GetNumber m) =
+      threadDelay 1000 >> putSuccess m 37
+
 newtype SimpleWrite = SimpleWrite Text
-  deriving (Eq, Show)
+  deriving (Eq, Show, Ord)
 
+assertEqualIgnoreOrder ::
+  (Eq a, Show a, Ord a) => String -> [a] -> [a] -> Assertion
+assertEqualIgnoreOrder msg lhs rhs =
+  assertEqual msg (sort lhs) (sort rhs)
+
 doInnerWrite :: GenHaxl u SimpleWrite Int
 doInnerWrite = do
   tellWrite $ SimpleWrite "inner"
@@ -124,6 +165,129 @@
       [SimpleWrite "inner not memo"]
   assertBool "Write Soundness 12" $ memoRes == replicate numReps 0
 
+writeLogsCorrectnessTest :: Test
+writeLogsCorrectnessTest = TestLabel "writeLogs_correctness" $ TestCase $ do
+  e <- emptyEnv ()
+  (_ , wrts) <- runHaxlWithWrites e doNonMemoWrites
+  assertEqualIgnoreOrder "Expected writes" [SimpleWrite "inner",
+    SimpleWrite "inner not memo"] wrts
+  wrtsNoMemo <- readIORef $ writeLogsRefNoMemo e
+  wrtsMemo <- readIORef $ writeLogsRef e
+  assertEqualIgnoreOrder "WriteTree not empty" [] $ flattenWT wrtsNoMemo
+  assertEqualIgnoreOrder "WriteTree not empty" [] $ flattenWT wrtsMemo
 
+mapWritesTest :: Test
+mapWritesTest = TestLabel "mapWrites" $ TestCase $ do
+  let func (SimpleWrite s) = SimpleWrite $ Text.toUpper s
+  env0 <- emptyEnv ()
+  (res0, wrts0) <- runHaxlWithWrites env0 $ mapWrites func doNonMemoWrites
+  assertEqual "Expected computation result" 0 res0
+  assertEqualIgnoreOrder "Writes correctly transformed" [SimpleWrite "INNER",
+    SimpleWrite "INNER NOT MEMO"] wrts0
 
-tests = TestList [TestLabel "Write Soundness" writeSoundness]
+  -- Writes should behave the same inside and outside mapWrites
+  env1 <- emptyEnv ()
+  (res1, wrts1) <- runHaxlWithWrites env1 $ do
+    outer <- doOuterWrite
+    outerMapped <- mapWrites func doOuterWrite
+    return $ outer == outerMapped
+  assertBool "Results are identical" res1
+  assertEqualIgnoreOrder
+    "Writes correctly transformed, non-transformed writes preserved"
+    [ SimpleWrite "outer1", SimpleWrite "inner"
+    , SimpleWrite "inner", SimpleWrite "outer2"
+    , SimpleWrite "OUTER1", SimpleWrite "INNER"
+    , SimpleWrite "INNER", SimpleWrite "OUTER2"
+    ]
+    wrts1
+
+  -- Memoization behaviour should be unaffected
+  env2 <- emptyEnv ()
+  (_res2, wrts2) <- runHaxlWithWrites env2 $ do
+    writeMemo <- newMemoWith doNonMemoWrites
+    let doWriteMemo = runMemo writeMemo
+    _ <- mapWrites func doWriteMemo
+    _ <- doWriteMemo
+    return ()
+  -- "inner not memo" should appear only once
+  assertEqualIgnoreOrder
+    "Write correctly transformed under memoization"
+    [ SimpleWrite "INNER"
+    , SimpleWrite "inner"
+    , SimpleWrite "INNER NOT MEMO"
+    ]
+    wrts2
+
+  -- Same as previous, but the non-mapped computation is run first
+  env3 <- emptyEnv ()
+  (_res3, wrts3) <- runHaxlWithWrites env3 $ do
+    writeMemo <- newMemoWith doNonMemoWrites
+    let doWriteMemo = runMemo writeMemo
+    _ <- doWriteMemo
+    _ <- mapWrites func doWriteMemo
+    return ()
+  -- "inner not memo" should appear only once
+  assertEqualIgnoreOrder
+    "Flipped: Write correctly transformed under memoization"
+    [ SimpleWrite "inner"
+    , SimpleWrite "INNER"
+    , SimpleWrite "inner not memo"
+    ]
+    wrts3
+
+  -- inner computation performs no writes
+  env4 <- emptyEnv ()
+  (res4, wrts4) <- runHaxlWithWrites env4 $
+    mapWrites func (return (0 :: Int))
+  assertEqual "No Writes: Expected computation result" 0 res4
+  assertEqualIgnoreOrder "No writes" [] wrts4
+
+  -- inner computation throws an exception
+  env5 <- emptyEnv ()
+  (res5, wrts5) <- runHaxlWithWrites env5 $ mapWrites func $ try $ do
+    _ <- doNonMemoWrites
+    _ <- throw (NotFound "exception")
+    return 0
+  assertBool "Throw: Expected Computation Result" $ isLeft
+    (res5 :: Either HaxlException Int)
+  assertEqualIgnoreOrder
+    "Datasource writes correctly transformed"
+    [ SimpleWrite "INNER"
+    , SimpleWrite "INNER NOT MEMO"
+    ]
+    wrts5
+
+  -- inner computation calls a datasource
+  env6 <- initEnv (stateSet DSState stateEmpty) ()
+  (res6, wrts6) <- runHaxlWithWrites env6 $ mapWrites func $ do
+    _ <- doNonMemoWrites
+    dataFetch GetNumber
+
+  assertEqual "Datasource: Expected Computation Result" 37 res6
+  assertEqualIgnoreOrder
+    "Datasource writes correctly transformed"
+    [ SimpleWrite "INNER"
+    , SimpleWrite "INNER NOT MEMO"
+    ]
+    wrts6
+
+  -- inner computation calls a datasource, flipped calls
+  env7 <- initEnv (stateSet DSState stateEmpty) ()
+  (res7, wrts7) <- runHaxlWithWrites env7 $ mapWrites func $ do
+    df <- dataFetch GetNumber
+    _ <- doNonMemoWrites
+    return df
+
+  assertEqual "Flipped Datasource: Expected Computation Result" 37 res7
+  assertEqualIgnoreOrder
+    "Flipped: Datasource writes correctly transformed"
+    [ SimpleWrite "INNER"
+    , SimpleWrite "INNER NOT MEMO"
+    ]
+    wrts7
+
+tests = TestList
+  [ TestLabel "Write Soundness" writeSoundness,
+    TestLabel "writeLogs_correctness" writeLogsCorrectnessTest,
+    TestLabel "mapWrites" mapWritesTest
+  ]