Add writes to IORef in Env

Summary:
Here I try to populate the writes done as part of a Haxl computation
in an IORef inside the Environment.

`IVar` which is the synchornisation point,
also acts as the point where we store intermediate writes for Haxl
computations, so they can be memoized and reused whenever a memoized
computation is done again. This is done inside `getIVarWithWrites` function.

This works, because we create new IVars when running a memo computation
or a data fetch, and it is only at these places where we need to create a new
environment with empty writes to run the computation in. So I run every memoized
computation in a new environment (with empty writes) and populate the writes in this new
environment. At the end of the memoized computation, I look up these writes from the `IVar`
and also add them to the original environment. This way ultimately all writes are correctly
propagated upwards to the top level environment user passes to `runHaxl`.
This logic lives inside `execMemoNow`.

Reviewed By: simonmar

Differential Revision: D14342181

fbshipit-source-id: a410dae1a477f27b480804b67b2212e7500997ab

Haxl/Core.hs

@@ -20,6 +20,9 @@ module Haxl.Core (
     -- *** Building the StateStore
   , StateStore, stateGet, stateSet, stateEmpty
 
+    -- ** Writes inside the monad
+  , tellWrite
+
     -- ** Exceptions
   , throw, catch, catchIf, try, tryToHaxlException
 

Haxl/Core/Fetch.hs

@@ -64,20 +64,20 @@ import Haxl.Core.Util
 -- Data fetching and caching
 
 -- | Possible responses when checking the cache.
-data CacheResult u a
+data CacheResult u w a
   -- | The request hadn't been seen until now.
   = Uncached
        (ResultVar a)
-       {-# UNPACK #-} !(IVar u a)
+       {-# UNPACK #-} !(IVar u w a)
 
   -- | The request has been seen before, but its result has not yet been
   -- fetched.
   | CachedNotFetched
-      {-# UNPACK #-} !(IVar u a)
+      {-# UNPACK #-} !(IVar u w a)
 
   -- | The request has been seen before, and its result has already been
   -- fetched.
-  | Cached (ResultVal a)
+  | Cached (ResultVal a w)
 
 
 -- | Show functions for request and its result.
@@ -93,11 +93,11 @@ type ShowReq r a = (r a -> String, a -> String)
 -- hidden from the Haxl user.
 
 cachedWithInsert
-  :: forall r a u .
+  :: forall r a u w.
      Typeable (r a)
   => (r a -> String)    -- See Note [showFn]
-  -> (r a -> IVar u a -> DataCache (IVar u) -> DataCache (IVar u))
+  -> (r a -> IVar u w a -> DataCache (IVar u w) -> DataCache (IVar u w))
-  -> Env u -> r a -> IO (CacheResult u a)
+  -> Env u w -> r a -> IO (CacheResult u w a)
 cachedWithInsert showFn insertFn Env{..} req = do
   cache <- readIORef cacheRef
   let
@@ -114,15 +114,15 @@ cachedWithInsert showFn insertFn Env{..} req = do
         IVarEmpty _ -> return (CachedNotFetched (IVar cr))
         IVarFull r -> do
           ifTrace flags 3 $ putStrLn $ case r of
-            ThrowIO _ -> "Cached error: " ++ showFn req
+            ThrowIO{} -> "Cached error: " ++ showFn req
-            ThrowHaxl _ -> "Cached error: " ++ showFn req
+            ThrowHaxl{} -> "Cached error: " ++ showFn req
-            Ok _ -> "Cached request: " ++ showFn req
+            Ok{} -> "Cached request: " ++ showFn req
           return (Cached r)
 
 
 -- | Make a ResultVar with the standard function for sending a CompletionReq
 -- to the scheduler.
-stdResultVar :: IVar u a -> TVar [CompleteReq u] -> ResultVar a
+stdResultVar :: IVar u w a -> TVar [CompleteReq u w] -> ResultVar a
 stdResultVar ivar completions = mkResultVar $ \r isChildThread -> do
   allocs <- if isChildThread
     then
@@ -139,7 +139,7 @@ stdResultVar ivar completions = mkResultVar $ \r isChildThread -> do
 
 -- | Record the call stack for a data fetch in the Stats.  Only useful
 -- when profiling.
-logFetch :: Env u -> (r a -> String) -> r a -> IO ()
+logFetch :: Env u w -> (r a -> String) -> r a -> IO ()
 #ifdef PROFILING
 logFetch env showFn req = do
   ifReport (flags env) 5 $ do
@@ -151,7 +151,7 @@ logFetch _ _ _ = return ()
 #endif
 
 -- | Performs actual fetching of data for a 'Request' from a 'DataSource'.
-dataFetch :: (DataSource u r, Request r a) => r a -> GenHaxl u a
+dataFetch :: (DataSource u r, Request r a) => r a -> GenHaxl u w a
 dataFetch = dataFetchWithInsert show DataCache.insert
 
 -- | Performs actual fetching of data for a 'Request' from a 'DataSource', using
@@ -159,19 +159,19 @@ dataFetch = dataFetchWithInsert show DataCache.insert
 dataFetchWithShow
   :: (DataSource u r, Eq (r a), Hashable (r a), Typeable (r a))
   => ShowReq r a
-  -> r a -> GenHaxl u a
+  -> r a -> GenHaxl u w a
 dataFetchWithShow (showReq, showRes) = dataFetchWithInsert showReq
   (DataCache.insertWithShow showReq showRes)
 
 -- | Performs actual fetching of data for a 'Request' from a 'DataSource', using
 -- the given function to insert requests in the cache.
 dataFetchWithInsert
-  :: forall u r a
+  :: forall u w r a
    . (DataSource u r, Eq (r a), Hashable (r a), Typeable (r a))
   => (r a -> String)    -- See Note [showFn]
-  -> (r a -> IVar u a -> DataCache (IVar u) -> DataCache (IVar u))
+  -> (r a -> IVar u w a -> DataCache (IVar u w) -> DataCache (IVar u w))
   -> r a
-  -> GenHaxl u a
+  -> GenHaxl u w a
 dataFetchWithInsert showFn insertFn req =
   GenHaxl $ \env@Env{..} -> do
   -- First, check the cache
@@ -220,7 +220,7 @@ dataFetchWithInsert showFn insertFn req =
 -- This allows us to store the request in the cache when recording, which
 -- allows a transparent run afterwards. Without this, the test would try to
 -- call the datasource during testing and that would be an exception.
-uncachedRequest :: (DataSource u r, Request r a) => r a -> GenHaxl u a
+uncachedRequest :: (DataSource u r, Request r a) => r a -> GenHaxl u w a
 uncachedRequest req = do
   isRecordingFlag <- env (recording . flags)
   if isRecordingFlag /= 0
@@ -238,14 +238,14 @@ uncachedRequest req = do
 -- the IO operation (except for asynchronous exceptions) are
 -- propagated into the Haxl monad and can be caught by 'catch' and
 -- 'try'.
-cacheResult :: Request r a => r a -> IO a -> GenHaxl u a
+cacheResult :: Request r a => r a -> IO a -> GenHaxl u w a
 cacheResult = cacheResultWithInsert show DataCache.insert
 
 -- | Transparently provides caching in the same way as 'cacheResult', but uses
 -- the given functions to show requests and their results.
 cacheResultWithShow
   :: (Eq (r a), Hashable (r a), Typeable (r a))
-  => ShowReq r a -> r a -> IO a -> GenHaxl u a
+  => ShowReq r a -> r a -> IO a -> GenHaxl u w a
 cacheResultWithShow (showReq, showRes) = cacheResultWithInsert showReq
   (DataCache.insertWithShow showReq showRes)
 
@@ -254,8 +254,8 @@ cacheResultWithShow (showReq, showRes) = cacheResultWithInsert showReq
 cacheResultWithInsert
   :: Typeable (r a)
   => (r a -> String)    -- See Note [showFn]
-  -> (r a -> IVar u a -> DataCache (IVar u) -> DataCache (IVar u)) -> r a
+  -> (r a -> IVar u w a -> DataCache (IVar u w) -> DataCache (IVar u w)) -> r a
-  -> IO a -> GenHaxl u a
+  -> IO a -> GenHaxl u w a
 cacheResultWithInsert showFn insertFn req val = GenHaxl $ \env -> do
   let !ref = cacheRef env
   cache <- readIORef ref
@@ -292,7 +292,7 @@ cacheResultWithInsert showFn insertFn req val = GenHaxl $ \env -> do
 -- deterministic.
 --
 cacheRequest
-  :: Request req a => req a -> Either SomeException a -> GenHaxl u ()
+  :: Request req a => req a -> Either SomeException a -> GenHaxl u w ()
 cacheRequest request result = GenHaxl $ \env -> do
   cache <- readIORef (cacheRef env)
   case DataCache.lookup request cache of
@@ -308,7 +308,7 @@ cacheRequest request result = GenHaxl $ \env -> do
       DataSourceError "cacheRequest: request is already in the cache"
 
 performRequestStore
-   :: forall u. Int -> Env u -> RequestStore u -> IO (Int, [IO ()])
+   :: forall u w. Int -> Env u w -> RequestStore u -> IO (Int, [IO ()])
 performRequestStore n env reqStore =
   performFetches n env (contents reqStore)
 
@@ -316,7 +316,7 @@ performRequestStore n env reqStore =
 -- 'performFetches', all the requests in the 'RequestStore' are
 -- complete, and all of the 'ResultVar's are full.
 performFetches
-  :: forall u. Int -> Env u -> [BlockedFetches u] -> IO (Int, [IO ()])
+  :: forall u w. Int -> Env u w -> [BlockedFetches u] -> IO (Int, [IO ()])
 performFetches n env@Env{flags=f, statsRef=sref} jobs = do
   let !n' = n + length jobs
 

Haxl/Core/Memo.hs

@@ -69,18 +69,18 @@ import Haxl.Core.Profile
 -- of 'dumpCacheAsHaskell'.
 --
 cachedComputation
-   :: forall req u a.
+   :: forall req u w a.
       ( Eq (req a)
       , Hashable (req a)
       , Typeable (req a))
-   => req a -> GenHaxl u a -> GenHaxl u a
+   => req a -> GenHaxl u w a -> GenHaxl u w a
 
 cachedComputation req haxl = GenHaxl $ \env@Env{..} -> do
   cache <- readIORef memoRef
   ifProfiling flags $
      modifyIORef' profRef (incrementMemoHitCounterFor profLabel)
   case DataCache.lookup req cache of
-    Just ivar -> unHaxl (getIVar ivar) env
+    Just ivar -> unHaxl (getIVarWithWrites ivar) env
     Nothing -> do
       ivar <- newIVar
       writeIORef memoRef $! DataCache.insertNotShowable req ivar cache
@@ -96,11 +96,11 @@ cachedComputation req haxl = GenHaxl $ \env@Env{..} -> do
 -- silently succeed if the cache is already populated.
 --
 preCacheComputation
-  :: forall req u a.
+  :: forall req u w a.
      ( Eq (req a)
      , Hashable (req a)
      , Typeable (req a))
-  => req a -> GenHaxl u a -> GenHaxl u a
+  => req a -> GenHaxl u w a -> GenHaxl u w a
 preCacheComputation req haxl = GenHaxl $ \env@Env{..} -> do
   cache <- readIORef memoRef
   ifProfiling flags $
@@ -116,29 +116,29 @@ preCacheComputation req haxl = GenHaxl $ \env@Env{..} -> do
 -- -----------------------------------------------------------------------------
 -- Memoization
 
-newtype MemoVar u a = MemoVar (IORef (MemoStatus u a))
+newtype MemoVar u w a = MemoVar (IORef (MemoStatus u w a))
 
-data MemoStatus u a
+data MemoStatus u w a
   = MemoEmpty
-  | MemoReady (GenHaxl u a)
+  | MemoReady (GenHaxl u w a)
-  | MemoRun {-# UNPACK #-} !(IVar u a)
+  | MemoRun {-# UNPACK #-} !(IVar u w a)
 
 -- | Create a new @MemoVar@ for storing a memoized computation. The created
 -- @MemoVar@ is initially empty, not tied to any specific computation. Running
 -- this memo (with @runMemo@) without preparing it first (with @prepareMemo@)
 -- will result in an exception.
-newMemo :: GenHaxl u (MemoVar u a)
+newMemo :: GenHaxl u w (MemoVar u w a)
 newMemo = unsafeLiftIO $ MemoVar <$> newIORef MemoEmpty
 
 -- | Store a computation within a supplied @MemoVar@. Any memo stored within the
 -- @MemoVar@ already (regardless of completion) will be discarded, in favor of
 -- the supplied computation. A @MemoVar@ must be prepared before it is run.
-prepareMemo :: MemoVar u a -> GenHaxl u a -> GenHaxl u ()
+prepareMemo :: MemoVar u w a -> GenHaxl u w a -> GenHaxl u w ()
 prepareMemo (MemoVar memoRef) memoCmp
   = unsafeLiftIO $ writeIORef memoRef (MemoReady memoCmp)
 
 -- | Convenience function, combines @newMemo@ and @prepareMemo@.
-newMemoWith :: GenHaxl u a -> GenHaxl u (MemoVar u a)
+newMemoWith :: GenHaxl u w a -> GenHaxl u w (MemoVar u w a)
 newMemoWith memoCmp = do
   memoVar <- newMemo
   prepareMemo memoVar memoCmp
@@ -192,7 +192,7 @@ newMemoWith memoCmp = do
 -- >   b <- g
 -- >   return (a + b)
 --
-runMemo :: MemoVar u a -> GenHaxl u a
+runMemo :: MemoVar u w a -> GenHaxl u w a
 runMemo (MemoVar memoRef) = GenHaxl $ \env -> do
   stored <- readIORef memoRef
   case stored of
@@ -204,55 +204,70 @@ runMemo (MemoVar memoRef) = GenHaxl $ \env -> do
       writeIORef memoRef (MemoRun ivar)
       unHaxl (execMemoNow cont ivar) env
     -- The memo has already been run, get (or wait for) for the result
-    MemoRun ivar -> unHaxl (getIVar ivar) env
+    MemoRun ivar -> unHaxl (getIVarWithWrites ivar) env
 
 
-execMemoNow :: GenHaxl u a -> IVar u a -> GenHaxl u a
+execMemoNow :: GenHaxl u w a -> IVar u w a -> GenHaxl u w a
 execMemoNow cont ivar = GenHaxl $ \env -> do
-  let !ienv = imperative env   -- don't speculate under memoized things
+  wlogs <- newIORef NilWrites
+  let
+    !ienv = imperative env { writeLogsRef = wlogs }
+    -- don't speculate under memoized things
+    -- also we won't an env with empty writes, so we can memoize the extra
+    -- writes done as part of 'cont'
   r <- Exception.try $ unHaxl cont ienv
+
   case r of
     Left e -> do
       rethrowAsyncExceptions e
       putIVar ivar (ThrowIO e) env
       throwIO e
     Right (Done a) -> do
-      putIVar ivar (Ok a) env
+      wt <- readIORef wlogs
+      putIVar ivar (Ok a wt) env
+      mbModifyWLRef wt (writeLogsRef env)
       return (Done a)
     Right (Throw ex) -> do
-      putIVar ivar (ThrowHaxl ex) env
+      wt <- readIORef wlogs
+      putIVar ivar (ThrowHaxl ex wt) env
+      mbModifyWLRef wt (writeLogsRef env)
       return (Throw ex)
     Right (Blocked ivar' cont) -> do
-      addJob env (toHaxl cont) ivar ivar'
+      -- We "block" this memoized computation in the new environment 'ienv', so
-      return (Blocked ivar (Cont (getIVar ivar)))
+      -- that when it finishes, we can store all the write logs from the env
+      -- in the IVar.
+      addJob ienv (toHaxl cont) ivar ivar'
+      -- Now we call @getIVarWithWrites@ to populate the writes in the original
+      -- environment 'env'.
+      return (Blocked ivar (Cont (getIVarWithWrites ivar)))
 
 -- -----------------------------------------------------------------------------
 -- 1-ary and 2-ary memo functions
 
-newtype MemoVar1 u a b = MemoVar1 (IORef (MemoStatus1 u a b))
+newtype MemoVar1 u w a b = MemoVar1 (IORef (MemoStatus1 u w a b))
-newtype MemoVar2 u a b c = MemoVar2 (IORef (MemoStatus2 u a b c))
+newtype MemoVar2 u w a b c = MemoVar2 (IORef (MemoStatus2 u w a b c))
 
-data MemoStatus1 u a b
+data MemoStatus1 u w a b
   = MemoEmpty1
-  | MemoTbl1 (a -> GenHaxl u b) (HashMap.HashMap a (MemoVar u b))
+  | MemoTbl1 (a -> GenHaxl u w b) (HashMap.HashMap a (MemoVar u w b))
 
-data MemoStatus2 u a b c
+data MemoStatus2 u w a b c
   = MemoEmpty2
   | MemoTbl2
-      (a -> b -> GenHaxl u c)
+      (a -> b -> GenHaxl u w c)
-      (HashMap.HashMap a (HashMap.HashMap b (MemoVar u c)))
+      (HashMap.HashMap a (HashMap.HashMap b (MemoVar u w c)))
 
-newMemo1 :: GenHaxl u (MemoVar1 u a b)
+newMemo1 :: GenHaxl u w (MemoVar1 u w a b)
 newMemo1 = unsafeLiftIO $ MemoVar1 <$> newIORef MemoEmpty1
 
-newMemoWith1 :: (a -> GenHaxl u b) -> GenHaxl u (MemoVar1 u a b)
+newMemoWith1 :: (a -> GenHaxl u w b) -> GenHaxl u w (MemoVar1 u w a b)
 newMemoWith1 f = newMemo1 >>= \r -> prepareMemo1 r f >> return r
 
-prepareMemo1 :: MemoVar1 u a b -> (a -> GenHaxl u b) -> GenHaxl u ()
+prepareMemo1 :: MemoVar1 u w a b -> (a -> GenHaxl u w b) -> GenHaxl u w ()
 prepareMemo1 (MemoVar1 r) f
   = unsafeLiftIO $ writeIORef r (MemoTbl1 f HashMap.empty)
 
-runMemo1 :: (Eq a, Hashable a) => MemoVar1 u a b -> a -> GenHaxl u b
+runMemo1 :: (Eq a, Hashable a) => MemoVar1 u w a b -> a -> GenHaxl u w b
 runMemo1 (MemoVar1 r) k = unsafeLiftIO (readIORef r) >>= \case
   MemoEmpty1 -> throw $ CriticalError "Attempting to run empty memo."
   MemoTbl1 f h -> case HashMap.lookup k h of
@@ -262,19 +277,19 @@ runMemo1 (MemoVar1 r) k = unsafeLiftIO (readIORef r) >>= \case
       runMemo x
     Just v -> runMemo v
 
-newMemo2 :: GenHaxl u (MemoVar2 u a b c)
+newMemo2 :: GenHaxl u w (MemoVar2 u w a b c)
 newMemo2 = unsafeLiftIO $ MemoVar2 <$> newIORef MemoEmpty2
 
-newMemoWith2 :: (a -> b -> GenHaxl u c) -> GenHaxl u (MemoVar2 u a b c)
+newMemoWith2 :: (a -> b -> GenHaxl u w c) -> GenHaxl u w (MemoVar2 u w a b c)
 newMemoWith2 f = newMemo2 >>= \r -> prepareMemo2 r f >> return r
 
-prepareMemo2 :: MemoVar2 u a b c -> (a -> b -> GenHaxl u c) -> GenHaxl u ()
+prepareMemo2 :: MemoVar2 u w a b c -> (a -> b -> GenHaxl u w c) -> GenHaxl u w ()
 prepareMemo2 (MemoVar2 r) f
   = unsafeLiftIO $ writeIORef r (MemoTbl2 f HashMap.empty)
 
 runMemo2 :: (Eq a, Hashable a, Eq b, Hashable b)
-         => MemoVar2 u a b c
+         => MemoVar2 u w a b c
-         -> a -> b -> GenHaxl u c
+         -> a -> b -> GenHaxl u w c
 runMemo2 (MemoVar2 r) k1 k2 = unsafeLiftIO (readIORef r) >>= \case
   MemoEmpty2 -> throw $ CriticalError "Attempting to run empty memo."
   MemoTbl2 f h1 -> case HashMap.lookup k1 h1 of
@@ -301,12 +316,12 @@ runMemo2 (MemoVar2 r) k1 k2 = unsafeLiftIO (readIORef r) >>= \case
 -- they compute the same result.
 memo
   :: (Typeable a, Typeable k, Hashable k, Eq k)
-  => k -> GenHaxl u a -> GenHaxl u a
+  => k -> GenHaxl u w a -> GenHaxl u w a
 memo key = cachedComputation (MemoKey key)
 
 {-# RULES
 "memo/Text" memo = memoText :: (Typeable a) =>
-            Text -> GenHaxl u a -> GenHaxl u a
+            Text -> GenHaxl u w a -> GenHaxl u w a
  #-}
 
 {-# NOINLINE memo #-}
@@ -315,7 +330,7 @@ memo key = cachedComputation (MemoKey key)
 -- uniqueness across computations.
 memoUnique
   :: (Typeable a, Typeable k, Hashable k, Eq k)
-  => MemoFingerprintKey a -> Text -> k -> GenHaxl u a -> GenHaxl u a
+  => MemoFingerprintKey a -> Text -> k -> GenHaxl u w a -> GenHaxl u w a
 memoUnique fp label key = withLabel label . memo (fp, key)
 
 {-# NOINLINE memoUnique #-}
@@ -341,7 +356,7 @@ deriving instance Eq (MemoTextKey a)
 instance Hashable (MemoTextKey a) where
   hashWithSalt s (MemoText t) = hashWithSalt s t
 
-memoText :: (Typeable a) => Text -> GenHaxl u a -> GenHaxl u a
+memoText :: (Typeable a) => Text -> GenHaxl u w a -> GenHaxl u w a
 memoText key = withLabel key . cachedComputation (MemoText key)
 
 -- | A memo key derived from a 128-bit MD5 hash.  Do not use this directly,
@@ -371,7 +386,7 @@ instance Hashable (MemoFingerprintKey a) where
 --
 {-# NOINLINE memoFingerprint #-}
 memoFingerprint
-  :: Typeable a => MemoFingerprintKey a -> GenHaxl u a -> GenHaxl u a
+  :: Typeable a => MemoFingerprintKey a -> GenHaxl u w a -> GenHaxl u w a
 memoFingerprint key@(MemoFingerprintKey _ _ mnPtr nPtr) =
   withFingerprintLabel mnPtr nPtr . cachedComputation key
 
@@ -383,19 +398,19 @@ memoFingerprint key@(MemoFingerprintKey _ _ mnPtr nPtr) =
 -- in a @MemoVar@ (which @memoize@ creates), and returns the stored result on
 -- subsequent invocations. This permits the creation of local memos, whose
 -- lifetimes are scoped to the current function, rather than the entire request.
-memoize :: GenHaxl u a -> GenHaxl u (GenHaxl u a)
+memoize :: GenHaxl u w a -> GenHaxl u w (GenHaxl u w a)
 memoize a = runMemo <$> newMemoWith a
 
 -- | Transform a 1-argument function returning a Haxl computation into a
 -- memoized version of itself.
 --
--- Given a function @f@ of type @a -> GenHaxl u b@, @memoize1@ creates a version
+-- Given a function @f@ of type @a -> GenHaxl u w b@, @memoize1@ creates a version
 -- which memoizes the results of @f@ in a table keyed by its argument, and
 -- returns stored results on subsequent invocations with the same argument.
 --
 -- e.g.:
 --
--- > allFriends :: [Int] -> GenHaxl u [Int]
+-- > allFriends :: [Int] -> GenHaxl u w [Int]
 -- > allFriends ids = do
 -- >   memoizedFriendsOf <- memoize1 friendsOf
 -- >   concat <$> mapM memoizeFriendsOf ids
@@ -403,8 +418,8 @@ memoize a = runMemo <$> newMemoWith a
 -- The above implementation will not invoke the underlying @friendsOf@
 -- repeatedly for duplicate values in @ids@.
 memoize1 :: (Eq a, Hashable a)
-         => (a -> GenHaxl u b)
+         => (a -> GenHaxl u w b)
-         -> GenHaxl u (a -> GenHaxl u b)
+         -> GenHaxl u w (a -> GenHaxl u w b)
 memoize1 f = runMemo1 <$> newMemoWith1 f
 
 -- | Transform a 2-argument function returning a Haxl computation, into a
@@ -412,6 +427,6 @@ memoize1 f = runMemo1 <$> newMemoWith1 f
 --
 -- The 2-ary version of @memoize1@, see its documentation for details.
 memoize2 :: (Eq a, Hashable a, Eq b, Hashable b)
-         => (a -> b -> GenHaxl u c)
+         => (a -> b -> GenHaxl u w c)
-         -> GenHaxl u (a -> b -> GenHaxl u c)
+         -> GenHaxl u w (a -> b -> GenHaxl u w c)
 memoize2 f = runMemo2 <$> newMemoWith2 f

Haxl/Core/Monad.hs

@@ -41,6 +41,14 @@ module Haxl.Core.Monad
     GenHaxl(..)
   , Result(..)
 
+    -- * Writes (for debugging only)
+  , WriteTree(..)
+  , tellWrite
+  , write
+  , flattenWT
+  , appendWTs
+  , mbModifyWLRef
+
     -- * Cont
   , Cont(..)
   , toHaxl
@@ -51,6 +59,7 @@ module Haxl.Core.Monad
   , newIVar
   , newFullIVar
   , getIVar
+  , getIVarWithWrites
   , putIVar
 
     -- * ResultVal
@@ -138,11 +147,11 @@ trace_ _ = id
 -- The environment
 
 -- | The data we carry around in the Haxl monad.
-data Env u = Env
+data Env u w = Env
-  { cacheRef     :: {-# UNPACK #-} !(IORef (DataCache (IVar u)))
+  { cacheRef     :: {-# UNPACK #-} !(IORef (DataCache (IVar u w)))
       -- ^ cached data fetches
 
-  , memoRef      :: {-# UNPACK #-} !(IORef (DataCache (IVar u)))
+  , memoRef      :: {-# UNPACK #-} !(IORef (DataCache (IVar u w)))
       -- ^ memoized computations
 
   , flags        :: !Flags
@@ -169,13 +178,13 @@ data Env u = Env
        -- ^ The set of requests that we have not submitted to data sources yet.
        -- Owned by the scheduler.
 
-  , runQueueRef :: {-# UNPACK #-} !(IORef (JobList u))
+  , runQueueRef :: {-# UNPACK #-} !(IORef (JobList u w))
        -- ^ runnable computations. Things get added to here when we wake up
        -- a computation that was waiting for something.  When the list is
        -- empty, either we're finished, or we're waiting for some data fetch
        -- to return.
 
-  , completions :: {-# UNPACK #-} !(TVar [CompleteReq u])
+  , completions :: {-# UNPACK #-} !(TVar [CompleteReq u w])
        -- ^ Requests that have completed.  Modified by data sources
        -- (via putResult) and the scheduler.  Waiting for this list to
        -- become non-empty is how the scheduler blocks waiting for
@@ -187,21 +196,27 @@ data Env u = Env
        -- some data fetch.
 
   , speculative :: {-# UNPACK #-} !Int
+
+  , writeLogsRef :: {-# UNPACK #-} !(IORef (WriteTree w))
+       -- ^ A log of all writes done as part of this haxl computation. Any
+       -- haxl computation that needs to be memoized runs in its own
+       -- environment so
   }
 
-type Caches u = (IORef (DataCache (IVar u)), IORef (DataCache (IVar u)))
+type Caches u w = (IORef (DataCache (IVar u w)), IORef (DataCache (IVar u w)))
 
-caches :: Env u -> Caches u
+caches :: Env u w -> Caches u w
 caches env = (cacheRef env, memoRef env)
 
 -- | Initialize an environment with a 'StateStore', an input map, a
 -- preexisting 'DataCache', and a seed for the random number generator.
-initEnvWithData :: StateStore -> u -> Caches u -> IO (Env u)
+initEnvWithData :: StateStore -> u -> Caches u w -> IO (Env u w)
 initEnvWithData states e (cref, mref) = do
   sref <- newIORef emptyStats
   pref <- newIORef emptyProfile
   rs <- newIORef noRequests          -- RequestStore
   rq <- newIORef JobNil
+  wl <- newIORef NilWrites
   comps <- newTVarIO []              -- completion queue
   return Env
     { cacheRef = cref
@@ -217,29 +232,65 @@ initEnvWithData states e (cref, mref) = do
     , completions = comps
     , pendingWaits = []
     , speculative = 0
+    , writeLogsRef = wl
     }
 
 -- | Initializes an environment with 'StateStore' and an input map.
-initEnv :: StateStore -> u -> IO (Env u)
+initEnv :: StateStore -> u -> IO (Env u w)
 initEnv states e = do
   cref <- newIORef emptyDataCache
   mref <- newIORef emptyDataCache
   initEnvWithData states e (cref,mref)
 
 -- | A new, empty environment.
-emptyEnv :: u -> IO (Env u)
+emptyEnv :: u -> IO (Env u w)
 emptyEnv = initEnv stateEmpty
 
-speculate :: Env u -> Env u
+speculate :: Env u w -> Env u w
 speculate env@Env{..}
   | speculative == 0 = env { speculative = 1 }
   | otherwise = env
 
-imperative :: Env u -> Env u
+imperative :: Env u w -> Env u w
 imperative env@Env{..}
   | speculative == 1 = env { speculative = 0 }
   | otherwise = env
 
+-- -----------------------------------------------------------------------------
+-- WriteTree
+
+-- | A tree of writes done during a Haxl computation. We could use a simple
+-- list, but this allows us to avoid multiple mappends when concatenating
+-- writes from two haxl computations.
+--
+-- Users should try to treat this data type as opaque, and prefer
+-- to use @flattenWT@ to get a simple list of writes from a @WriteTree@.
+data WriteTree w
+  = NilWrites
+  | SomeWrite w
+  | MergeWrites (WriteTree w) (WriteTree w)
+  deriving (Show)
+
+appendWTs :: WriteTree w -> WriteTree w -> WriteTree w
+appendWTs NilWrites w = w
+appendWTs w NilWrites = w
+appendWTs w1 w2 = MergeWrites w1 w2
+
+-- This function must be called at the end of the Haxl computation to get
+-- a list of writes.
+flattenWT :: WriteTree w -> [w]
+flattenWT = go []
+  where
+    go !ws NilWrites = ws
+    go !ws (SomeWrite w) = w : ws
+    go !ws (MergeWrites w1 w2) = go (go ws w2) w1
+
+-- This is a convenience wrapper over modifyIORef, which only modifies
+-- writeLogsRef IORef, for non NilWrites.
+mbModifyWLRef :: WriteTree w -> IORef (WriteTree w) -> IO ()
+mbModifyWLRef NilWrites _ = return ()
+mbModifyWLRef !wt ref = modifyIORef' ref (`appendWTs` wt)
+
 -- -----------------------------------------------------------------------------
 -- | The Haxl monad, which does several things:
 --
@@ -247,6 +298,11 @@ imperative env@Env{..}
 --    of the scheduler, including unfetched requests and the run queue
 --    of computations.
 --
+-- * It is a writer monad for 'WriteTree'. We strongly advise these be
+--   used only for logs used for debugging. These are not memoized.
+--   Other relevant writes should be returned as function output,
+--   which is the more "functional" way.
+
 --  * It is a concurrency, or resumption, monad. A computation may run
 --    partially and return 'Blocked', in which case the framework should
 --    perform the outstanding requests in the 'RequestStore', and then
@@ -258,11 +314,18 @@ imperative env@Env{..}
 --
 --  * It contains IO, so that we can perform real data fetching.
 --
-newtype GenHaxl u a = GenHaxl
+newtype GenHaxl u w a = GenHaxl
-  { unHaxl :: Env u -> IO (Result u a) }
+  { unHaxl :: Env u w -> IO (Result u w a) }
 
+tellWrite :: w -> GenHaxl u w ()
+tellWrite = write . SomeWrite
 
-instance IsString a => IsString (GenHaxl u a) where
+write :: WriteTree w -> GenHaxl u w ()
+write wt = GenHaxl $ \Env{..} -> do
+  mbModifyWLRef wt writeLogsRef
+  return $ Done ()
+
+instance IsString a => IsString (GenHaxl u w a) where
   fromString s = return (fromString s)
 
 -- -----------------------------------------------------------------------------
@@ -274,13 +337,13 @@ instance IsString a => IsString (GenHaxl u a) where
 -- This could be an ordinary list, but the optimised representation
 -- saves space and time.
 --
-data JobList u
+data JobList u w
  = JobNil
  | forall a . JobCons
-     (Env u)          -- See Note [make withEnv work] below.
+     (Env u w)          -- See Note [make withEnv work] below.
-     (GenHaxl u a)
+     (GenHaxl u w a)
-     {-# UNPACK #-} !(IVar u a)
+     {-# UNPACK #-} !(IVar u w a)
-     (JobList u)
+     (JobList u w)
 
 -- Note [make withEnv work]
 --
@@ -292,12 +355,12 @@ data JobList u
 -- restart it with the correct Env.  So we stash the Env along with
 -- the continuation in the JobList.
 
-appendJobList :: JobList u -> JobList u -> JobList u
+appendJobList :: JobList u w -> JobList u w -> JobList u w
 appendJobList JobNil c = c
 appendJobList c JobNil = c
 appendJobList (JobCons a b c d) e = JobCons a b c $! appendJobList d e
 
-lengthJobList :: JobList u -> Int
+lengthJobList :: JobList u w -> Int
 lengthJobList JobNil = 0
 lengthJobList (JobCons _ _ _ j) = 1 + lengthJobList j
 
@@ -307,43 +370,58 @@ lengthJobList (JobCons _ _ _ j) = 1 + lengthJobList j
 
 -- | A synchronisation point.  It either contains a value, or a list
 -- of computations waiting for the value.
-newtype IVar u a = IVar (IORef (IVarContents u a))
+newtype IVar u w a = IVar (IORef (IVarContents u w a))
 
-data IVarContents u a
+data IVarContents u w a
-  = IVarFull (ResultVal a)
+  = IVarFull (ResultVal a w)
-  | IVarEmpty (JobList u)
+  | IVarEmpty (JobList u w)
-    -- morally this is a list of @a -> GenHaxl u ()@, but instead of
+    -- morally this is a list of @a -> GenHaxl u w ()@, but instead of
     -- using a function, each computation begins with `getIVar` to grab
     -- the value it is waiting for.  This is less type safe but a little
     -- faster (benchmarked with tests/MonadBench.hs).
 
-newIVar :: IO (IVar u a)
+newIVar :: IO (IVar u w a)
 newIVar = IVar <$> newIORef (IVarEmpty JobNil)
 
-newFullIVar :: ResultVal a -> IO (IVar u a)
+newFullIVar :: ResultVal a w -> IO (IVar u w a)
 newFullIVar r = IVar <$> newIORef (IVarFull r)
 
-getIVar :: IVar u a -> GenHaxl u a
+getIVar :: IVar u w a -> GenHaxl u w a
-getIVar (IVar !ref) = GenHaxl $ \_env -> do
+getIVar (IVar !ref) = GenHaxl $ \Env{..} -> do
   e <- readIORef ref
   case e of
-    IVarFull (Ok a) -> return (Done a)
+    IVarFull (Ok a _wt) -> return (Done a)
-    IVarFull (ThrowHaxl e) -> return (Throw e)
+    IVarFull (ThrowHaxl e _wt) -> return (Throw e)
     IVarFull (ThrowIO e) -> throwIO e
     IVarEmpty _ -> return (Blocked (IVar ref) (Cont (getIVar (IVar ref))))
 
 -- Just a specialised version of getIVar, for efficiency in <*>
-getIVarApply :: IVar u (a -> b) -> a -> GenHaxl u b
+getIVarApply :: IVar u w (a -> b) -> a -> GenHaxl u w b
-getIVarApply (IVar !ref) a = GenHaxl $ \_env -> do
+getIVarApply (IVar !ref) a = GenHaxl $ \Env{..} -> do
   e <- readIORef ref
   case e of
-    IVarFull (Ok f) -> return (Done (f a))
+    IVarFull (Ok f _wt) -> return (Done (f a))
-    IVarFull (ThrowHaxl e) -> return (Throw e)
+    IVarFull (ThrowHaxl e _wt) -> return (Throw e)
     IVarFull (ThrowIO e) -> throwIO e
     IVarEmpty _ ->
       return (Blocked (IVar ref) (Cont (getIVarApply (IVar ref) a)))
 
-putIVar :: IVar u a -> ResultVal a -> Env u -> IO ()
+-- Another specialised version of getIVar, for efficiency in cachedComputation
+getIVarWithWrites :: IVar u w a -> GenHaxl u w a
+getIVarWithWrites (IVar !ref) = GenHaxl $ \Env{..} -> do
+  e <- readIORef ref
+  case e of
+    IVarFull (Ok a wt) -> do
+      mbModifyWLRef wt writeLogsRef
+      return (Done a)
+    IVarFull (ThrowHaxl e wt) -> do
+      mbModifyWLRef wt writeLogsRef
+      return  (Throw e)
+    IVarFull (ThrowIO e) -> throwIO e
+    IVarEmpty _ ->
+      return (Blocked (IVar ref) (Cont (getIVarWithWrites (IVar ref))))
+
+putIVar :: IVar u w a -> ResultVal a w -> Env u w -> IO ()
 putIVar (IVar ref) a Env{..} = do
   e <- readIORef ref
   case e of
@@ -353,7 +431,7 @@ putIVar (IVar ref) a Env{..} = do
     IVarFull{} -> error "putIVar: multiple put"
 
 {-# INLINE addJob #-}
-addJob :: Env u -> GenHaxl u b -> IVar u b -> IVar u a -> IO ()
+addJob :: Env u w -> GenHaxl u w b -> IVar u w b -> IVar u w a -> IO ()
 addJob env !haxl !resultIVar (IVar !ref) =
   modifyIORef' ref $ \contents ->
     case contents of
@@ -371,25 +449,26 @@ addJobPanic = error "addJob: not empty"
 -- thrown in the IO monad from exceptions thrown in the Haxl monad, so
 -- that when the result is fetched using getIVar, we can throw the
 -- exception in the right way.
-data ResultVal a
+data ResultVal a w
-  = Ok a
+  = Ok a (WriteTree w)
-  | ThrowHaxl SomeException
+  | ThrowHaxl SomeException (WriteTree w)
   | ThrowIO SomeException
+    -- we get no write logs when an IO exception occurs
 
-done :: ResultVal a -> IO (Result u a)
+done :: ResultVal a w -> IO (Result u w a)
-done (Ok a) = return (Done a)
+done (Ok a _) = return (Done a)
-done (ThrowHaxl e) = return (Throw e)
+done (ThrowHaxl e _) = return (Throw e)
 done (ThrowIO e) = throwIO e
 
-eitherToResultThrowIO :: Either SomeException a -> ResultVal a
+eitherToResultThrowIO :: Either SomeException a -> ResultVal a w
-eitherToResultThrowIO (Right a) = Ok a
+eitherToResultThrowIO (Right a) = Ok a NilWrites
 eitherToResultThrowIO (Left e)
-  | Just HaxlException{} <- fromException e = ThrowHaxl e
+  | Just HaxlException{} <- fromException e = ThrowHaxl e NilWrites
   | otherwise = ThrowIO e
 
-eitherToResult :: Either SomeException a -> ResultVal a
+eitherToResult :: Either SomeException a -> ResultVal a w
-eitherToResult (Right a) = Ok a
+eitherToResult (Right a) = Ok a NilWrites
-eitherToResult (Left e) = ThrowHaxl e
+eitherToResult (Left e) = ThrowHaxl e NilWrites
 
 
 -- -----------------------------------------------------------------------------
@@ -400,10 +479,10 @@ eitherToResult (Left e) = ThrowHaxl e
 -- data source is just to add these to a queue ('completions') using
 -- 'putResult'; the scheduler collects them from the queue and unblocks
 -- the relevant computations.
-data CompleteReq u
+data CompleteReq u w
   = forall a . CompleteReq
       (Either SomeException a)
-      !(IVar u a)  -- IVar because the result is cached
+      !(IVar u w a)  -- IVar because the result is cached
       {-# UNPACK #-} !Int64 -- see Note [tracking allocation in child threads]
 
 
@@ -452,19 +531,19 @@ allocation limit itself, and changing the counter would mess it up.
 -- | The result of a computation is either 'Done' with a value, 'Throw'
 -- with an exception, or 'Blocked' on the result of a data fetch with
 -- a continuation.
-data Result u a
+data Result u w a
   = Done a
   | Throw SomeException
   | forall b . Blocked
-      {-# UNPACK #-} !(IVar u b)
+      {-# UNPACK #-} !(IVar u w b)
-      (Cont u a)
+      (Cont u w a)
          -- ^ The 'IVar' is what we are blocked on; 'Cont' is the
          -- continuation.  This might be wrapped further if we're
          -- nested inside multiple '>>=', before finally being added
-         -- to the 'IVar'.  Morally @b -> GenHaxl u a@, but see
+         -- to the 'IVar'.  Morally @b -> GenHaxl u w a@, but see
          -- 'IVar',
 
-instance (Show a) => Show (Result u a) where
+instance (Show a) => Show (Result u w a) where
   show (Done a) = printf "Done(%s)" $ show a
   show (Throw e) = printf "Throw(%s)" $ show e
   show Blocked{} = "Blocked"
@@ -518,22 +597,22 @@ turn it into a Haxl exception:
 -- O(n^2) complexity for some pathalogical cases - see the "seql" benchmark
 -- in tests/MonadBench.hs.
 -- See "A Smart View on Datatypes", Jaskelioff/Rivas, ICFP'15
-data Cont u a
+data Cont u w a
-  = Cont (GenHaxl u a)
+  = Cont (GenHaxl u w a)
-  | forall b. Cont u b :>>= (b -> GenHaxl u a)
+  | forall b. Cont u w b :>>= (b -> GenHaxl u w a)
-  | forall b. (b -> a) :<$> (Cont u b)
+  | forall b. (b -> a) :<$> (Cont u w b)
 
-toHaxl :: Cont u a -> GenHaxl u a
+toHaxl :: Cont u w a -> GenHaxl u w a
 toHaxl (Cont haxl) = haxl
 toHaxl (m :>>= k) = toHaxlBind m k
 toHaxl (f :<$> x) = toHaxlFmap f x
 
-toHaxlBind :: Cont u b -> (b -> GenHaxl u a) -> GenHaxl u a
+toHaxlBind :: Cont u w b -> (b -> GenHaxl u w a) -> GenHaxl u w a
 toHaxlBind (m :>>= k) k2 = toHaxlBind m (k >=> k2)
 toHaxlBind (Cont haxl) k = haxl >>= k
 toHaxlBind (f :<$> x) k = toHaxlBind x (k . f)
 
-toHaxlFmap :: (a -> b) -> Cont u a -> GenHaxl u b
+toHaxlFmap :: (a -> b) -> Cont u w a -> GenHaxl u w b
 toHaxlFmap f (m :>>= k) = toHaxlBind m (k >=> return . f)
 toHaxlFmap f (Cont haxl) = f <$> haxl
 toHaxlFmap f (g :<$> x) = toHaxlFmap (f . g) x
@@ -542,7 +621,7 @@ toHaxlFmap f (g :<$> x) = toHaxlFmap (f . g) x
 -- -----------------------------------------------------------------------------
 -- Monad/Applicative instances
 
-instance Monad (GenHaxl u) where
+instance Monad (GenHaxl u w) where
   return a = GenHaxl $ \_env -> return (Done a)
   GenHaxl m >>= k = GenHaxl $ \env -> do
     e <- m env
@@ -557,7 +636,7 @@ instance Monad (GenHaxl u) where
   -- We really want the Applicative version of >>
   (>>) = (*>)
 
-instance Functor (GenHaxl u) where
+instance Functor (GenHaxl u w) where
   fmap f (GenHaxl m) = GenHaxl $ \env -> do
     r <- m env
     case r of
@@ -566,7 +645,7 @@ instance Functor (GenHaxl u) where
       Blocked ivar cont -> trace_ "fmap Blocked" $
         return (Blocked ivar (f :<$> cont))
 
-instance Applicative (GenHaxl u) where
+instance Applicative (GenHaxl u w) where
   pure = return
   GenHaxl ff <*> GenHaxl aa = GenHaxl $ \env -> do
     rf <- ff env
@@ -628,12 +707,12 @@ instance Applicative (GenHaxl u) where
 -- Env utils
 
 -- | Extracts data from the 'Env'.
-env :: (Env u -> a) -> GenHaxl u a
+env :: (Env u w -> a) -> GenHaxl u w a
 env f = GenHaxl $ \env -> return (Done (f env))
 
 -- | Returns a version of the Haxl computation which always uses the
 -- provided 'Env', ignoring the one specified by 'runHaxl'.
-withEnv :: Env u -> GenHaxl u a -> GenHaxl u a
+withEnv :: Env u w -> GenHaxl u w a -> GenHaxl u w a
 withEnv newEnv (GenHaxl m) = GenHaxl $ \_env -> do
   r <- m newEnv
   case r of
@@ -647,10 +726,10 @@ withEnv newEnv (GenHaxl m) = GenHaxl $ \_env -> do
 -- Exceptions
 
 -- | Throw an exception in the Haxl monad
-throw :: (Exception e) => e -> GenHaxl u a
+throw :: (Exception e) => e -> GenHaxl u w a
 throw e = GenHaxl $ \_env -> raise e
 
-raise :: (Exception e) => e -> IO (Result u a)
+raise :: (Exception e) => e -> IO (Result u w a)
 raise e
 #ifdef PROFILING
   | Just (HaxlException Nothing h) <- fromException somex = do
@@ -663,7 +742,7 @@ raise e
     somex = toException e
 
 -- | Catch an exception in the Haxl monad
-catch :: Exception e => GenHaxl u a -> (e -> GenHaxl u a) -> GenHaxl u a
+catch :: Exception e => GenHaxl u w a -> (e -> GenHaxl u w a) -> GenHaxl u w a
 catch (GenHaxl m) h = GenHaxl $ \env -> do
    r <- m env
    case r of
@@ -674,20 +753,20 @@ catch (GenHaxl m) h = GenHaxl $ \env -> do
 
 -- | Catch exceptions that satisfy a predicate
 catchIf
-  :: Exception e => (e -> Bool) -> GenHaxl u a -> (e -> GenHaxl u a)
+  :: Exception e => (e -> Bool) -> GenHaxl u w a -> (e -> GenHaxl u w a)
-  -> GenHaxl u a
+  -> GenHaxl u w a
 catchIf cond haxl handler =
   catch haxl $ \e -> if cond e then handler e else throw e
 
 -- | Returns @'Left' e@ if the computation throws an exception @e@, or
 -- @'Right' a@ if it returns a result @a@.
-try :: Exception e => GenHaxl u a -> GenHaxl u (Either e a)
+try :: Exception e => GenHaxl u w a -> GenHaxl u w (Either e a)
 try haxl = (Right <$> haxl) `catch` (return . Left)
 
 -- | @since 0.3.1.0
-instance Catch.MonadThrow (GenHaxl u) where throwM = Haxl.Core.Monad.throw
+instance Catch.MonadThrow (GenHaxl u w) where throwM = Haxl.Core.Monad.throw
 -- | @since 0.3.1.0
-instance Catch.MonadCatch (GenHaxl u) where catch = Haxl.Core.Monad.catch
+instance Catch.MonadCatch (GenHaxl u w) where catch = Haxl.Core.Monad.catch
 
 
 -- -----------------------------------------------------------------------------
@@ -695,14 +774,14 @@ instance Catch.MonadCatch (GenHaxl u) where catch = Haxl.Core.Monad.catch
 
 -- | Under ordinary circumstances this is unnecessary; users of the Haxl
 -- monad should generally /not/ perform arbitrary IO.
-unsafeLiftIO :: IO a -> GenHaxl u a
+unsafeLiftIO :: IO a -> GenHaxl u w a
 unsafeLiftIO m = GenHaxl $ \_env -> Done <$> m
 
 -- | Convert exceptions in the underlying IO monad to exceptions in
 -- the Haxl monad.  This is morally unsafe, because you could then
 -- catch those exceptions in Haxl and observe the underlying execution
 -- order.  Not to be exposed to user code.
-unsafeToHaxlException :: GenHaxl u a -> GenHaxl u a
+unsafeToHaxlException :: GenHaxl u w a -> GenHaxl u w a
 unsafeToHaxlException (GenHaxl m) = GenHaxl $ \env -> do
   r <- m env `Exception.catch` \e -> return (Throw e)
   case r of
@@ -714,7 +793,7 @@ unsafeToHaxlException (GenHaxl m) = GenHaxl $ \env -> do
 -- hierarchy.  Uses 'unsafeToHaxlException' internally.  Typically
 -- this is used at the top level of a Haxl computation, to ensure that
 -- all exceptions are caught.
-tryToHaxlException :: GenHaxl u a -> GenHaxl u (Either HaxlException a)
+tryToHaxlException :: GenHaxl u w a -> GenHaxl u w (Either HaxlException a)
 tryToHaxlException h = left asHaxlException <$> try (unsafeToHaxlException h)
 
 
@@ -724,19 +803,20 @@ tryToHaxlException h = left asHaxlException <$> try (unsafeToHaxlException h)
 -- compiled and run, will recreate the same cache contents.  For
 -- example, the generated code looks something like this:
 --
--- > loadCache :: GenHaxl u ()
+-- > loadCache :: GenHaxl u w ()
 -- > loadCache = do
 -- >   cacheRequest (ListWombats 3) (Right ([1,2,3]))
 -- >   cacheRequest (CountAardvarks "abcabc") (Right (2))
 --
-dumpCacheAsHaskell :: GenHaxl u String
+dumpCacheAsHaskell :: GenHaxl u w String
-dumpCacheAsHaskell = dumpCacheAsHaskellFn "loadCache" "GenHaxl u ()"
+dumpCacheAsHaskell = dumpCacheAsHaskellFn "loadCache" "GenHaxl u w ()"
 
 -- | Dump the contents of the cache as Haskell code that, when
 -- compiled and run, will recreate the same cache contents.
+-- Does not take into account the writes done as part of the computation.
 --
 -- Takes the name and type for the resulting function as arguments.
-dumpCacheAsHaskellFn :: String -> String -> GenHaxl u String
+dumpCacheAsHaskellFn :: String -> String -> GenHaxl u w String
 dumpCacheAsHaskellFn fnName fnType = do
   ref <- env cacheRef  -- NB. cacheRef, not memoRef.  We ignore memoized
                        -- results when dumping the cache.
@@ -744,8 +824,8 @@ dumpCacheAsHaskellFn fnName fnType = do
     readIVar (IVar ref) = do
       r <- readIORef ref
       case r of
-        IVarFull (Ok a) -> return (Just (Right a))
+        IVarFull (Ok a _) -> return (Just (Right a))
-        IVarFull (ThrowHaxl e) -> return (Just (Left e))
+        IVarFull (ThrowHaxl e _) -> return (Just (Left e))
         IVarFull (ThrowIO e) -> return (Just (Left e))
         IVarEmpty _ -> return Nothing
 

Haxl/Core/Parallel.hs

@@ -35,7 +35,7 @@ infixr 4 `pOr`
 -- returns 'True' immediately, ignoring a possible exception that
 -- the other argument may have produced if it had been allowed to
 -- complete.
-pOr :: GenHaxl u Bool -> GenHaxl u Bool -> GenHaxl u Bool
+pOr :: GenHaxl u w Bool -> GenHaxl u w Bool -> GenHaxl u w Bool
 GenHaxl a `pOr` GenHaxl b = GenHaxl $ \env@Env{..} -> do
   let !senv = speculate env
   ra <- a senv
@@ -66,7 +66,7 @@ GenHaxl a `pOr` GenHaxl b = GenHaxl $ \env@Env{..} -> do
 -- returns 'False' immediately, ignoring a possible exception that
 -- the other argument may have produced if it had been allowed to
 -- complete.
-pAnd :: GenHaxl u Bool -> GenHaxl u Bool -> GenHaxl u Bool
+pAnd :: GenHaxl u w Bool -> GenHaxl u w Bool -> GenHaxl u w Bool
 GenHaxl a `pAnd` GenHaxl b = GenHaxl $ \env@Env{..} -> do
   let !senv = speculate env
   ra <- a senv

Haxl/Core/Profile.hs

@@ -43,7 +43,7 @@ import Haxl.Core.Monad
 -- Profiling
 
 -- | Label a computation so profiling data is attributed to the label.
-withLabel :: ProfileLabel -> GenHaxl u a -> GenHaxl u a
+withLabel :: ProfileLabel -> GenHaxl u w a -> GenHaxl u w a
 withLabel l (GenHaxl m) = GenHaxl $ \env ->
   if report (flags env) < 4
      then m env
@@ -51,7 +51,7 @@ withLabel l (GenHaxl m) = GenHaxl $ \env ->
 
 -- | Label a computation so profiling data is attributed to the label.
 -- Intended only for internal use by 'memoFingerprint'.
-withFingerprintLabel :: Addr# -> Addr# -> GenHaxl u a -> GenHaxl u a
+withFingerprintLabel :: Addr# -> Addr# -> GenHaxl u w a -> GenHaxl u w a
 withFingerprintLabel mnPtr nPtr (GenHaxl m) = GenHaxl $ \env ->
   if report (flags env) < 4
      then m env
@@ -62,9 +62,9 @@ withFingerprintLabel mnPtr nPtr (GenHaxl m) = GenHaxl $ \env ->
 -- | Collect profiling data and attribute it to given label.
 collectProfileData
   :: ProfileLabel
-  -> (Env u -> IO (Result u a))
+  -> (Env u w -> IO (Result u w a))
-  -> Env u
+  -> Env u w
-  -> IO (Result u a)
+  -> IO (Result u w a)
 collectProfileData l m env = do
    a0 <- getAllocationCounter
    r <- m env{profLabel=l} -- what if it throws?
@@ -78,7 +78,7 @@ collectProfileData l m env = do
      Blocked ivar k -> return (Blocked ivar (Cont (withLabel l (toHaxl k))))
 {-# INLINE collectProfileData #-}
 
-modifyProfileData :: Env u -> ProfileLabel -> AllocCount -> IO ()
+modifyProfileData :: Env u w -> ProfileLabel -> AllocCount -> IO ()
 modifyProfileData env label allocs =
   modifyIORef' (profRef env) $ \ p ->
     p { profile =
@@ -113,9 +113,9 @@ modifyProfileData env label allocs =
 --   will call profileCont the next time this cont runs)
 --
 profileCont
-  :: (Env u -> IO (Result u a))
+  :: (Env u w -> IO (Result u w a))
-  -> Env u
+  -> Env u w
-  -> IO (Result u a)
+  -> IO (Result u w a)
 profileCont m env = do
   a0 <- getAllocationCounter
   r <- m env
@@ -143,8 +143,8 @@ incrementMemoHitCounter pd = pd { profileMemoHits = succ (profileMemoHits pd) }
 
 {-# NOINLINE addProfileFetch #-}
 addProfileFetch
-  :: forall r u a . (DataSourceName r, Eq (r a), Hashable (r a), Typeable (r a))
+  :: forall r u w a . (DataSourceName r, Eq (r a), Hashable (r a), Typeable (r a))
-  => Env u -> r a -> IO ()
+  => Env u w -> r a -> IO ()
 addProfileFetch env _req = do
   c <- getAllocationCounter
   modifyIORef' (profRef env) $ \ p ->

Haxl/Core/Run.hs

@@ -44,13 +44,13 @@ import Haxl.Core.Stats
 --
 -- However, multiple 'Env's may share a single 'StateStore', and thereby
 -- use the same set of datasources.
-runHaxl :: forall u a. Env u -> GenHaxl u a -> IO a
+runHaxl :: forall u w a. Env u w -> GenHaxl u w a -> IO (a, [w])
 runHaxl env@Env{..} haxl = do
 
   result@(IVar resultRef) <- newIVar -- where to put the final result
   let
     -- Run a job, and put its result in the given IVar
-    schedule :: Env u -> JobList u -> GenHaxl u b -> IVar u b -> IO ()
+    schedule :: Env u w -> JobList u w -> GenHaxl u w b -> IVar u w b -> IO ()
     schedule env@Env{..} rq (GenHaxl run) (IVar !ref) = do
       ifTrace flags 3 $ printf "schedule: %d\n" (1 + lengthJobList rq)
       let {-# INLINE result #-}
@@ -82,8 +82,12 @@ runHaxl env@Env{..} haxl = do
         Left e -> do
           rethrowAsyncExceptions e
           result (ThrowIO e)
-        Right (Done a) -> result (Ok a)
+        Right (Done a) -> do
-        Right (Throw ex) -> result (ThrowHaxl ex)
+          wt <- readIORef writeLogsRef
+          result (Ok a wt)
+        Right (Throw ex) -> do
+          wt <- readIORef writeLogsRef
+          result (ThrowHaxl ex wt)
         Right (Blocked ivar fn) -> do
           addJob env (toHaxl fn) (IVar ref) ivar
           reschedule env rq
@@ -103,7 +107,7 @@ runHaxl env@Env{..} haxl = do
     -- individual data sources can request that their requests are
     -- sent eagerly by using schedulerHint.
     --
-    reschedule :: Env u -> JobList u -> IO ()
+    reschedule :: Env u w -> JobList u w -> IO ()
     reschedule env@Env{..} haxls = do
       case haxls of
         JobNil -> do
@@ -116,7 +120,7 @@ runHaxl env@Env{..} haxl = do
         JobCons env' a b c ->
           schedule env' c a b
 
-    emptyRunQueue :: Env u -> IO ()
+    emptyRunQueue :: Env u w -> IO ()
     emptyRunQueue env@Env{..} = do
       ifTrace flags 3 $ printf "emptyRunQueue\n"
       haxls <- checkCompletions env
@@ -130,7 +134,7 @@ runHaxl env@Env{..} haxl = do
               emptyRunQueue env { pendingWaits = waits } -- check completions
         _ -> reschedule env haxls
 
-    checkRequestStore :: Env u -> IO ()
+    checkRequestStore :: Env u w -> IO ()
     checkRequestStore env@Env{..} = do
       reqStore <- readIORef reqStoreRef
       if RequestStore.isEmpty reqStore
@@ -146,7 +150,7 @@ runHaxl env@Env{..} haxl = do
             writeIORef cacheRef emptyDataCache
           emptyRunQueue env{ pendingWaits = waits ++ pendingWaits }
 
-    checkCompletions :: Env u -> IO (JobList u)
+    checkCompletions :: Env u w -> IO (JobList u w)
     checkCompletions Env{..} = do
       ifTrace flags 3 $ printf "checkCompletions\n"
       comps <- atomically $ do
@@ -179,7 +183,7 @@ runHaxl env@Env{..} haxl = do
           jobs <- mapM getComplete comps
           return (foldr appendJobList JobNil jobs)
 
-    waitCompletions :: Env u -> IO ()
+    waitCompletions :: Env u w -> IO ()
     waitCompletions env@Env{..} = do
       ifTrace flags 3 $ printf "waitCompletions\n"
       atomically $ do
@@ -192,8 +196,10 @@ runHaxl env@Env{..} haxl = do
   r <- readIORef resultRef
   case r of
     IVarEmpty _ -> throwIO (CriticalError "runHaxl: missing result")
-    IVarFull (Ok a)  -> return a
+    IVarFull (Ok a wt)  -> return (a, flattenWT wt)
-    IVarFull (ThrowHaxl e)  -> throwIO e
+    IVarFull (ThrowHaxl e _wt)  -> throwIO e
+      -- The written logs are discarded when there's a Haxl exception. We
+      -- can change this behavior if we need to get access to partial logs.
     IVarFull (ThrowIO e)  -> throwIO e
 
 

Haxl/DataSource/ConcurrentIO.hs

@@ -21,7 +21,7 @@
 --
 -- For example, to make a concurrent sleep operation:
 --
--- > sleep :: Int -> GenHaxl u Int
+-- > sleep :: Int -> GenHaxl u w Int
 -- > sleep n = dataFetch (Sleep n)
 -- >
 -- > data Sleep

Haxl/Prelude.hs

@@ -106,12 +106,12 @@ instance IfThenElse Bool a where
 --
 -- > if ipGetCountry ip .== "us" then ... else ...
 --
-instance (u1 ~ u2) => IfThenElse (GenHaxl u1 Bool) (GenHaxl u2 a) where
+instance (u1 ~ u2) => IfThenElse (GenHaxl u1 w Bool) (GenHaxl u2 w a) where
   ifThenElse fb t e = do
     b <- fb
     if b then t else e
 
-instance Num a => Num (GenHaxl u a) where
+instance Num a => Num (GenHaxl u w a) where
   (+)         = liftA2 (+)
   (-)         = liftA2 (-)
   (*)         = liftA2 (*)
@@ -120,7 +120,7 @@ instance Num a => Num (GenHaxl u a) where
   signum      = liftA signum
   negate      = liftA negate
 
-instance Fractional a => Fractional (GenHaxl u a) where
+instance Fractional a => Fractional (GenHaxl u w a) where
   (/) = liftA2 (/)
   recip = liftA recip
   fromRational = return . fromRational
@@ -131,35 +131,35 @@ instance Fractional a => Fractional (GenHaxl u a) where
 -- convention is to prefix the name with a '.'.  We could change this,
 -- or even just not provide these at all.
 
-(.>) :: Ord a => GenHaxl u a -> GenHaxl u a -> GenHaxl u Bool
+(.>) :: Ord a => GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool
 (.>) = liftA2 (Prelude.>)
 
-(.<) :: Ord a => GenHaxl u a -> GenHaxl u a -> GenHaxl u Bool
+(.<) :: Ord a => GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool
 (.<) = liftA2 (Prelude.<)
 
-(.>=) :: Ord a => GenHaxl u a -> GenHaxl u a -> GenHaxl u Bool
+(.>=) :: Ord a => GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool
 (.>=) = liftA2 (Prelude.>=)
 
-(.<=) :: Ord a => GenHaxl u a -> GenHaxl u a -> GenHaxl u Bool
+(.<=) :: Ord a => GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool
 (.<=) = liftA2 (Prelude.<=)
 
-(.==) :: Eq a => GenHaxl u a -> GenHaxl u a -> GenHaxl u Bool
+(.==) :: Eq a => GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool
 (.==) = liftA2 (Prelude.==)
 
-(./=) :: Eq a => GenHaxl u a -> GenHaxl u a -> GenHaxl u Bool
+(./=) :: Eq a => GenHaxl u w a -> GenHaxl u w a -> GenHaxl u w Bool
 (./=) = liftA2 (Prelude./=)
 
-(.++) :: GenHaxl u [a] -> GenHaxl u [a] -> GenHaxl u [a]
+(.++) :: GenHaxl u w [a] -> GenHaxl u w [a] -> GenHaxl u w [a]
 (.++) = liftA2 (Prelude.++)
 
 -- short-circuiting Bool operations
-(.&&):: GenHaxl u Bool -> GenHaxl u Bool -> GenHaxl u Bool
+(.&&):: GenHaxl u w Bool -> GenHaxl u w Bool -> GenHaxl u w Bool
 fa .&& fb = do a <- fa; if a then fb else return False
 
-(.||):: GenHaxl u Bool -> GenHaxl u Bool -> GenHaxl u Bool
+(.||):: GenHaxl u w Bool -> GenHaxl u w Bool -> GenHaxl u w Bool
 fa .|| fb = do a <- fa; if a then return True else fb
 
-pair :: GenHaxl u a -> GenHaxl u b -> GenHaxl u (a, b)
+pair :: GenHaxl u w a -> GenHaxl u w b -> GenHaxl u w (a, b)
 pair = liftA2 (,)
 
 -- -----------------------------------------------------------------------------
@@ -203,14 +203,14 @@ filterM predicate xs =
 -- 'TransientError' or 'LogicError' exception (see
 -- "Haxl.Core.Exception"), the exception is ignored and the supplied
 -- default value is returned instead.
-withDefault :: a -> GenHaxl u a -> GenHaxl u a
+withDefault :: a -> GenHaxl u w a -> GenHaxl u w a
 withDefault d a = catchAny a (return d)
 
 -- | Catch 'LogicError's and 'TransientError's and perform an alternative action
 catchAny
-  :: GenHaxl u a   -- ^ run this first
+  :: GenHaxl u w a   -- ^ run this first
-  -> GenHaxl u a   -- ^ if it throws 'LogicError' or 'TransientError', run this
+  -> GenHaxl u w a   -- ^ if it throws 'LogicError' or 'TransientError', run this
-  -> GenHaxl u a
+  -> GenHaxl u w a
 catchAny haxl handler =
   haxl `catch` \e ->
     if isJust (fromException e :: Maybe LogicError) ||

changelog.md

@@ -1,3 +1,14 @@
+# Changes in version 2.1.0.0
+
+  * Add a new 'w' parameter to 'GenHaxl' to allow arbitrary writes during
+    a computation. These writes are stored as a running log in the Env,
+    and are not memoized. This allows users to extract information from
+    a Haxl computation which throws. Our advise is to limit these writes to
+    monitoring and debugging logs.
+
+  * A 'WriteTree' constructor to maintain log of writes inside the Environment.
+    This is defined to allow O(1) mappend.
+
 # Changes in version 2.0.1.1
 
   * Support for GHC 8.6.1

example/facebook/FB.hs

@@ -12,14 +12,14 @@ import Facebook (Id(..), Friend(..), User(..))
 import Haxl.Core
 
 -- | Fetch an arbitrary object in the Facebook graph.
-getObject :: Id -> GenHaxl u Object
+getObject :: Id -> GenHaxl u w Object
 getObject id = dataFetch (GetObject id)
 
 -- | Fetch a Facebook user.
-getUser :: Id -> GenHaxl u User
+getUser :: Id -> GenHaxl u w User
 getUser id = dataFetch (GetUser id)
 
 -- | Fetch the friends of a Facebook user that are registered with the
 -- current app.
-getUserFriends :: Id -> GenHaxl u [Friend]
+getUserFriends :: Id -> GenHaxl u w [Friend]
 getUserFriends id = dataFetch (GetUserFriends id)

example/facebook/readme.md

@@ -256,13 +256,13 @@ import Facebook (Id(..), Friend(..), User(..))
 
 import Haxl.Core
 
-getObject :: Id -> GenHaxl u Object
+getObject :: Id -> GenHaxl u w Object
 getObject id = dataFetch (GetObject id)
 
-getUser :: Id -> GenHaxl u User
+getUser :: Id -> GenHaxl u w User
 getUser id = dataFetch (GetUser id)
 
-getUserFriends :: Id -> GenHaxl u [Friend]
+getUserFriends :: Id -> GenHaxl u w [Friend]
 getUserFriends id = dataFetch (GetUserFriends id)
 ```
 

example/sql/readme.md

@@ -159,7 +159,7 @@ getUsernameById userId = dataFetch (GetNameById userId)
 `GenHaxl` action to fetch it concurrently with others.
 
 ```haskell
-dataFetch :: (DataSource u r, Request r a) => r a -> GenHaxl u a
+dataFetch :: (DataSource u r, Request r a) => r a -> GenHaxl u w a
 ```
 
 Like magic, the naïve code that *looks* like it will do N+1 fetches will now do just two.

tests/CoreTests.hs

@@ -35,7 +35,7 @@ testEnv = do
   -- Create the Env:
   initEnv st ()
 
-useless :: String -> GenHaxl u Bool
+useless :: String -> GenHaxl u w Bool
 useless _ = throw (NotFound "ha ha")
 
 exceptions :: Assertion

tests/DataCacheTest.hs

@@ -32,10 +32,10 @@ deriving instance Show (TestReq a)
 instance Hashable (TestReq a) where
   hashWithSalt salt (Req i) = hashWithSalt salt i
 
-newResult :: a -> IO (IVar u a)
+newResult :: a -> IO (IVar u w a)
 newResult a = IVar <$> newIORef (IVarFull (Ok a))
 
-takeResult :: IVar u a -> IO (ResultVal a)
+takeResult :: IVar u w a -> IO (ResultVal a w)
 takeResult (IVar ref) = do
   e <- readIORef ref
   case e of

tests/ExampleDataSource.hs

@@ -155,8 +155,8 @@ fetch1 (BlockedFetch (ListWombats a) r) =
 -- Normally a data source will provide some convenient wrappers for
 -- its requests:
 
-countAardvarks :: String -> GenHaxl u Int
+countAardvarks :: String -> GenHaxl u w Int
 countAardvarks str = dataFetch (CountAardvarks str)
 
-listWombats :: Id -> GenHaxl u [Id]
+listWombats :: Id -> GenHaxl u w [Id]
 listWombats i = dataFetch (ListWombats i)

tests/FullyAsyncTest.hs

@@ -48,7 +48,7 @@ sleepTest = TestCase $ do
   print stats
   assertEqual "FullyAsyncTest: stats" 5 (numFetches stats)
 
-andThen :: GenHaxl u a -> GenHaxl u b -> GenHaxl u b
+andThen :: GenHaxl u w a -> GenHaxl u w b -> GenHaxl u w b
 andThen a b = a >>= \_ -> b
 
 {-

tests/LoadCache.txt

@@ -1,4 +1,4 @@
-loadCache :: GenHaxl u ()
+loadCache :: GenHaxl u w ()
 loadCache = do
   cacheRequest (CountAardvarks "yyy") (except (LogicError (NotFound "yyy")))
   cacheRequest (CountAardvarks "xxx") (Right (3))

tests/MonadBench.hs

@@ -25,7 +25,7 @@ import Haxl.Core
 
 import ExampleDataSource
 
-testEnv :: IO (Env ())
+testEnv :: IO (Env () ())
 testEnv = do
   exstate <- ExampleDataSource.initGlobalState
   let st = stateSet exstate stateEmpty
@@ -118,18 +118,18 @@ main = do
   -- can't use >>, it is aliased to *> and we want the real bind here
   andThen x y = x >>= const y
 
-tree :: Int -> GenHaxl () [Id]
+tree :: Int -> GenHaxl () () [Id]
 tree 0 = listWombats 0
 tree n = concat <$> Haxl.sequence
   [ tree (n-1)
   , listWombats (fromIntegral n), tree (n-1)
   ]
 
-unionWombats :: GenHaxl () [Id]
+unionWombats :: GenHaxl () () [Id]
 unionWombats = foldl List.union [] <$> Haxl.mapM listWombats [1..1000]
 
-unionWombatsTo :: Id -> GenHaxl () [Id]
+unionWombatsTo :: Id -> GenHaxl () () [Id]
 unionWombatsTo x = foldl List.union [] <$> Haxl.mapM listWombats [1..x]
 
-unionWombatsFromTo :: Id -> Id -> GenHaxl () [Id]
+unionWombatsFromTo :: Id -> Id -> GenHaxl () () [Id]
 unionWombatsFromTo x y = foldl List.union [] <$> Haxl.mapM listWombats [x..y]

tests/SleepDataSource.hs

@@ -27,7 +27,7 @@ import Control.Concurrent
 import Data.Hashable
 import Data.Typeable
 
-sleep :: Int -> GenHaxl u Int
+sleep :: Int -> GenHaxl u w Int
 sleep n = dataFetch (Sleep n)
 
 data Sleep deriving Typeable

tests/WorkDataSource.hs

@@ -25,7 +25,7 @@ import Control.Exception
 import Data.Hashable
 import Data.Typeable
 
-work :: Integer -> GenHaxl u Integer
+work :: Integer -> GenHaxl u w Integer
 work n = dataFetch (Work n)
 
 data Work deriving Typeable