haxl 2.0.1.1 → 2.1.2.0

raw patch · 30 files changed

+880/−266 lines, 30 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Haxl/Core.hs +11/−1
• Haxl/Core/CallGraph.hs +38/−0
• Haxl/Core/DataSource.hs +2/−2
• Haxl/Core/Fetch.hs +90/−52
• Haxl/Core/Flags.hs +1/−1
• Haxl/Core/Memo.hs +63/−48
• Haxl/Core/Monad.hs +226/−87
• Haxl/Core/Parallel.hs +2/−2
• Haxl/Core/Profile.hs +14/−11
• Haxl/Core/RequestStore.hs +74/−2
• Haxl/Core/Run.hs +33/−12
• Haxl/DataSource/ConcurrentIO.hs +1/−1
• Haxl/Prelude.hs +17/−17
• changelog.md +22/−0
• haxl.cabal +4/−1
• readme.md +2/−2
• tests/AllTests.hs +4/−0
• tests/CoreTests.hs +1/−1
• tests/DataCacheTest.hs +9/−9
• tests/ExampleDataSource.hs +2/−2
• tests/FullyAsyncTest.hs +1/−1
• tests/LoadCache.txt +1/−1
• tests/MonadBench.hs +16/−6
• tests/OutgoneFetchesTests.hs +137/−0
• tests/SleepDataSource.hs +2/−2
• tests/TestBadDataSource.hs +1/−1
• tests/TestTypes.hs +3/−1
• tests/TestUtils.hs +2/−2
• tests/WorkDataSource.hs +1/−1
• tests/WriteTests.hs +100/−0

@@ -7,9 +7,10 @@ -- | Everything needed to define data sources and to invoke the -- engine. --+{-# LANGUAGE CPP #-} module Haxl.Core (     -- * The monad and operations-    GenHaxl (..), runHaxl+    GenHaxl (..), runHaxl, runHaxlWithWrites      -- ** Env   , Env(..), Caches, caches@@ -20,6 +21,9 @@     -- *** Building the StateStore   , StateStore, stateGet, stateSet, stateEmpty +    -- ** Writes inside the monad+  , tellWrite+     -- ** Exceptions   , throw, catch, catchIf, try, tryToHaxlException @@ -88,11 +92,16 @@     -- ** Utilities   , except   , setError+  , getMapFromRCMap      -- * Exceptions   , module Haxl.Core.Exception++    -- * Recording the function callgraph+  , module Haxl.Core.CallGraph   ) where +import Haxl.Core.CallGraph import Haxl.Core.DataSource import Haxl.Core.Flags import Haxl.Core.Memo@@ -103,5 +112,6 @@ import Haxl.Core.Run import Haxl.Core.Stats import Haxl.Core.Exception+import Haxl.Core.RequestStore (getMapFromRCMap) import Haxl.Core.ShowP (ShowP(..)) import Haxl.Core.StateStore

@@ -0,0 +1,38 @@+-- Copyright 2004-present Facebook. All Rights Reserved.+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}++module Haxl.Core.CallGraph where++import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+#if __GLASGOW_HASKELL__ < 804+import Data.Monoid+#endif+import Data.Text (Text)+import qualified Data.Text as Text++type ModuleName = Text++-- | An unqualified function+type Function = Text++-- | A qualified function+data QualFunction = QualFunction ModuleName Function deriving (Eq, Ord)++instance Show QualFunction where+  show (QualFunction mn nm) = Text.unpack $ mn <> Text.pack "." <> nm++-- | Represents an edge between a parent function which calls a child function+-- in the call graph+type FunctionCall = (QualFunction, QualFunction)++-- | An edge list which represents the dependencies between function calls+type CallGraph = ([FunctionCall], Map QualFunction Text)++-- | Used as the root of all function calls+mainFunction :: QualFunction+mainFunction = QualFunction "MAIN" "main"++emptyCallGraph :: CallGraph+emptyCallGraph = ([], Map.empty)

@@ -386,5 +386,5 @@   -> (forall a. service -> request a -> IO (IO (Either SomeException a)))   -> BlockedFetch request   -> IO (IO ())-submitFetch service fetch (BlockedFetch request result)-  = (putResult result =<<) <$> fetch service request+submitFetch service fetchFn (BlockedFetch request result)+  = (putResult result =<<) <$> fetchFn service request

@@ -13,6 +13,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE KindSignatures #-}  -- | Implementation of data-fetching operations.  Most users should -- import "Haxl.Core" instead.@@ -37,7 +38,10 @@ import Data.IORef import Data.Int import Data.List+#if __GLASGOW_HASKELL__ < 804 import Data.Monoid+#endif+import Data.Proxy import Data.Typeable import Data.Text (Text) import qualified Data.Text as Text@@ -62,20 +66,20 @@ -- 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.@@ -91,17 +95,18 @@ -- hidden from the Haxl user.  cachedWithInsert-  :: forall r a u .-     Typeable (r a)+  :: forall r a u w.+     (DataSource u r, Typeable (r a))   => (r a -> String)    -- See Note [showFn]-  -> (r a -> IVar u a -> DataCache (IVar u) -> DataCache (IVar u))-  -> Env u -> r a -> IO (CacheResult u a)+  -> (r a -> IVar u w a -> DataCache (IVar u w) -> DataCache (IVar u w))+  -> Env u w -> r a -> IO (CacheResult u w a) cachedWithInsert showFn insertFn Env{..} req = do   cache <- readIORef cacheRef   let     doFetch = do       ivar <- newIVar-      let !rvar = stdResultVar ivar completions+      let !rvar = stdResultVar ivar completions submittedReqsRef flags+            (Proxy :: Proxy r)       writeIORef cacheRef $! insertFn req ivar cache       return (Uncached rvar ivar)   case DataCache.lookup req cache of@@ -112,32 +117,44 @@         IVarEmpty _ -> return (CachedNotFetched (IVar cr))         IVarFull r -> do           ifTrace flags 3 $ putStrLn $ case r of-            ThrowIO _ -> "Cached error: " ++ showFn req-            ThrowHaxl _ -> "Cached error: " ++ showFn req-            Ok _ -> "Cached request: " ++ showFn req+            ThrowIO{} -> "Cached error: " ++ showFn req+            ThrowHaxl{} -> "Cached error: " ++ 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 completions = mkResultVar $ \r isChildThread -> do-  allocs <- if isChildThread-    then-      -- In a child thread, return the current allocation counter too,-      -- for correct tracking of allocation.-      getAllocationCounter-    else-      return 0-  atomically $ do-    cs <- readTVar completions-    writeTVar completions (CompleteReq r ivar allocs : cs)+-- to the scheduler. This is the function will be executed when the fetch+-- completes.+stdResultVar+  :: forall r a u w. (DataSourceName r, Typeable r)+  => IVar u w a+  -> TVar [CompleteReq u w]+  -> IORef ReqCountMap+  -> Flags+  -> Proxy r+  -> ResultVar a+stdResultVar ivar completions ref flags p =+  mkResultVar $ \r isChildThread -> do+    allocs <- if isChildThread+      then+        -- In a child thread, return the current allocation counter too,+        -- for correct tracking of allocation.+        getAllocationCounter+      else+        return 0+    -- Decrement the counter as request has finished+    ifReport flags 1 $+      atomicModifyIORef' ref (\m -> (subFromCountMap p 1 m, ()))+    atomically $ do+      cs <- readTVar completions+      writeTVar completions (CompleteReq r ivar allocs : cs) {-# INLINE stdResultVar #-}   -- | 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@@ -149,7 +166,7 @@ #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@@ -157,19 +174,19 @@ 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@@ -218,14 +235,17 @@ -- 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+ :: forall a u w (r :: * -> *). (DataSource u r, Request r a)+ => r a -> GenHaxl u w a uncachedRequest req = do-  isRecordingFlag <- env (recording . flags)-  if isRecordingFlag /= 0+  flg <- env flags+  subRef <- env submittedReqsRef+  if recording flg /= 0     then dataFetch req     else GenHaxl $ \Env{..} -> do       ivar <- newIVar-      let !rvar = stdResultVar ivar completions+      let !rvar = stdResultVar ivar completions subRef flg (Proxy :: Proxy r)       modifyIORef' reqStoreRef $ \bs ->         addRequest (BlockedFetch req rvar) bs       return $ Blocked ivar (Cont (getIVar ivar))@@ -236,14 +256,14 @@ -- 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) @@ -252,8 +272,8 @@ cacheResultWithInsert   :: Typeable (r a)   => (r a -> String)    -- See Note [showFn]-  -> (r a -> IVar u a -> DataCache (IVar u) -> DataCache (IVar u)) -> r a-  -> IO a -> GenHaxl u a+  -> (r a -> IVar u w a -> DataCache (IVar u w) -> DataCache (IVar u w)) -> r a+  -> IO a -> GenHaxl u w a cacheResultWithInsert showFn insertFn req val = GenHaxl $ \env -> do   let !ref = cacheRef env   cache <- readIORef ref@@ -290,7 +310,7 @@ -- 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@@ -306,7 +326,7 @@       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) @@ -314,7 +334,7 @@ -- '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 @@ -358,7 +378,7 @@    fetches <- zipWithM applyFetch [n..] jobs -  waits <- scheduleFetches fetches+  waits <- scheduleFetches fetches (submittedReqsRef env) (flags env)    t1 <- getTimestamp   let roundtime = fromIntegral (t1 - t0) / 1000000 :: Double@@ -369,7 +389,9 @@   return (n', waits)  data FetchToDo where-  FetchToDo :: [BlockedFetch req] -> PerformFetch req -> FetchToDo+  FetchToDo+    :: forall (req :: * -> *). (DataSourceName req, Typeable req)+    => [BlockedFetch req] -> PerformFetch req -> FetchToDo  -- Catch exceptions arising from the data source and stuff them into -- the appropriate requests.  We don't want any exceptions propagating@@ -462,8 +484,15 @@     addTimer t0 (BlockedFetch req (ResultVar fn)) =       BlockedFetch req $ ResultVar $ \result isChildThread -> do         t1 <- getTimestamp+        -- We cannot measure allocation easily for BackgroundFetch. Here we+        -- just attribute all allocation to the last `putResultFromChildThread`+        -- and use 0 for the others. While the individual allocations may not+        -- be correct, the total sum and amortized allocation are still+        -- meaningful.+        -- see Note [tracking allocation in child threads]+        allocs <- if isChildThread then getAllocationCounter else return 0         updateFetchStats t0 (t1 - t0)-          0 -- allocs: we can't measure this easily for BackgroundFetch+          (negate allocs)           1 -- batch size: we don't know if this is a batch or not           (if isLeft result then 1 else 0) -- failures         fn result isChildThread@@ -517,22 +546,31 @@  -- | Start all the async fetches first, then perform the sync fetches before -- getting the results of the async fetches.-scheduleFetches :: [FetchToDo] -> IO [IO ()]-scheduleFetches fetches = do+scheduleFetches :: [FetchToDo] -> IORef ReqCountMap -> Flags -> IO [IO ()]+scheduleFetches fetches ref flags = do+  -- update ReqCountmap for these fetches+  ifReport flags 1 $ sequence_+    [ atomicModifyIORef' ref $+        \m -> (addToCountMap (Proxy :: Proxy r) (length reqs) m, ())+    | FetchToDo (reqs :: [BlockedFetch r]) _f <- fetches+    ]   fully_async_fetches   waits <- future_fetches   async_fetches sync_fetches   return waits  where   fully_async_fetches :: IO ()-  fully_async_fetches =-    sequence_ [f reqs | FetchToDo reqs (BackgroundFetch f) <- fetches]+  fully_async_fetches = sequence_+    [f reqs | FetchToDo reqs (BackgroundFetch f) <- fetches]    future_fetches :: IO [IO ()]-  future_fetches = sequence [f reqs | FetchToDo reqs (FutureFetch f) <- fetches]+  future_fetches = sequence+    [f reqs | FetchToDo reqs (FutureFetch f) <- fetches]    async_fetches :: IO () -> IO ()-  async_fetches = compose [f reqs | FetchToDo reqs (AsyncFetch f) <- fetches]+  async_fetches = compose+    [f reqs | FetchToDo reqs (AsyncFetch f) <- fetches]    sync_fetches :: IO ()-  sync_fetches = sequence_ [f reqs | FetchToDo reqs (SyncFetch f) <- fetches]+  sync_fetches = sequence_+    [f reqs | FetchToDo reqs (SyncFetch f) <- fetches]

@@ -33,7 +33,7 @@   , report :: {-# UNPACK #-} !Int     -- ^ Report level:     --    * 0 = quiet-    --    * 1 = quiet (legacy, this used to do something)+    --    * 1 = outgone fetches, for debugging eg: timeouts     --    * 2 = data fetch stats & errors     --    * 3 = (same as 2, this used to enable errors)     --    * 4 = profiling

@@ -69,18 +69,18 @@ -- 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 @@ -- 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 @@ -- ----------------------------------------------------------------------------- -- 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)-  | MemoRun {-# UNPACK #-} !(IVar u a)+  | MemoReady (GenHaxl u w 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 @@ -- >   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 @@       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'-      return (Blocked ivar (Cont (getIVar ivar)))+      -- We "block" this memoized computation in the new environment 'ienv', so+      -- 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 MemoVar2 u a b c = MemoVar2 (IORef (MemoStatus2 u a b c))+newtype MemoVar1 u w a b = MemoVar1 (IORef (MemoStatus1 u w a b))+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)-      (HashMap.HashMap a (HashMap.HashMap b (MemoVar u c)))+      (a -> b -> GenHaxl u w 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 @@       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-         -> a -> b -> GenHaxl u c+         => MemoVar2 u w a b 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 @@ -- 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 @@ -- 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 @@ 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 @@ -- {-# 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 @@ -- 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 @@ -- The above implementation will not invoke the underlying @friendsOf@ -- repeatedly for duplicate values in @ids@. memoize1 :: (Eq a, Hashable a)-         => (a -> GenHaxl u b)-         -> GenHaxl u (a -> GenHaxl u b)+         => (a -> GenHaxl u w 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 @@ -- -- 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)-         -> GenHaxl u (a -> b -> GenHaxl u c)+         => (a -> b -> GenHaxl u w c)+         -> GenHaxl u w (a -> b -> GenHaxl u w c) memoize2 f = runMemo2 <$> newMemoWith2 f

@@ -41,6 +41,14 @@     GenHaxl(..)   , Result(..) +    -- * Writes (for debugging only)+  , WriteTree(..)+  , tellWrite+  , write+  , flattenWT+  , appendWTs+  , mbModifyWLRef+     -- * Cont   , Cont(..)   , toHaxl@@ -51,6 +59,7 @@   , newIVar   , newFullIVar   , getIVar+  , getIVarWithWrites   , putIVar      -- * ResultVal@@ -91,6 +100,11 @@   , dumpCacheAsHaskell   , dumpCacheAsHaskellFn +    -- * CallGraph+#ifdef PROFILING+  , withCallGraph+#endif+     -- * Unsafe operations   ,  unsafeLiftIO, unsafeToHaxlException   ) where@@ -126,7 +140,11 @@ #endif  #ifdef PROFILING+import qualified Data.Map as Map+import Data.Text (Text)+import Data.Typeable import GHC.Stack+import Haxl.Core.CallGraph #endif  @@ -138,11 +156,11 @@ -- The environment  -- | The data we carry around in the Haxl monad.-data Env u = Env-  { cacheRef     :: {-# UNPACK #-} !(IORef (DataCache (IVar u)))+data Env u w = Env+  { 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 +187,19 @@        -- ^ 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])+  , submittedReqsRef :: {-# UNPACK #-} !(IORef ReqCountMap)+       -- ^ all outgone fetches which haven't yet returned. Entries are+       -- removed from this map as the fetches finish. This field is+       -- useful for tracking outgone fetches to detect downstream+       -- failures.++  , 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,22 +211,37 @@        -- 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+#ifdef PROFILING+  , callGraphRef ::  Maybe (IORef CallGraph)+       -- ^ An edge list representing the current function call graph. The type+       -- is wrapped in a Maybe to avoid changing the existing callsites.++  , currFunction :: QualFunction+       -- ^ The most recent function call.+#endif   } -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+  sr <- newIORef emptyReqCounts   comps <- newTVarIO []              -- completion queue+  wl <- newIORef NilWrites   return Env     { cacheRef = cref     , memoRef = mref@@ -214,39 +253,85 @@     , profRef = pref     , reqStoreRef = rs     , runQueueRef = rq+    , submittedReqsRef = sr     , completions = comps     , pendingWaits = []     , speculative = 0+    , writeLogsRef = wl+#ifdef PROFILING+    , callGraphRef = Nothing+    , currFunction = mainFunction+#endif     }  -- | 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: -- --  * It is a reader monad for 'Env', which contains the current state --    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 +343,18 @@ -- --  * It contains IO, so that we can perform real data fetching. ---newtype GenHaxl u a = GenHaxl-  { unHaxl :: Env u -> IO (Result u a) }+newtype GenHaxl u w a = GenHaxl+  { 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 +366,13 @@ -- 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.-     (GenHaxl u a)-     {-# UNPACK #-} !(IVar u a)-     (JobList u)+     (Env u w)          -- See Note [make withEnv work] below.+     (GenHaxl u w a)+     {-# UNPACK #-} !(IVar u w a)+     (JobList u w)  -- Note [make withEnv work] --@@ -292,12 +384,12 @@ -- 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 +399,58 @@  -- | 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-  = IVarFull (ResultVal a)-  | IVarEmpty (JobList u)-    -- morally this is a list of @a -> GenHaxl u ()@, but instead of+data IVarContents u w a+  = IVarFull (ResultVal a w)+  | IVarEmpty (JobList u w)+    -- 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 !ref) = GenHaxl $ \_env -> do+getIVar :: IVar u w a -> GenHaxl u w a+getIVar (IVar !ref) = GenHaxl $ \Env{..} -> do   e <- readIORef ref   case e of-    IVarFull (Ok a) -> return (Done a)-    IVarFull (ThrowHaxl e) -> return (Throw e)+    IVarFull (Ok a _wt) -> return (Done a)+    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 !ref) a = GenHaxl $ \_env -> do+getIVarApply :: IVar u w (a -> b) -> a -> GenHaxl u w b+getIVarApply (IVar !ref) a = GenHaxl $ \Env{..} -> do   e <- readIORef ref   case e of-    IVarFull (Ok f) -> return (Done (f a))-    IVarFull (ThrowHaxl e) -> return (Throw e)+    IVarFull (Ok f _wt) -> return (Done (f a))+    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 +460,7 @@     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 +478,26 @@ -- 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-  = Ok a-  | ThrowHaxl SomeException+data ResultVal a w+  = Ok a (WriteTree w)+  | ThrowHaxl SomeException (WriteTree w)   | ThrowIO SomeException+    -- we get no write logs when an IO exception occurs -done :: ResultVal a -> IO (Result u a)-done (Ok a) = return (Done a)-done (ThrowHaxl e) = return (Throw e)+done :: ResultVal a w -> IO (Result u w a)+done (Ok a _) = return (Done a)+done (ThrowHaxl e _) = return (Throw e) done (ThrowIO e) = throwIO e -eitherToResultThrowIO :: Either SomeException a -> ResultVal a-eitherToResultThrowIO (Right a) = Ok a+eitherToResultThrowIO :: Either SomeException a -> ResultVal a w+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 (Right a) = Ok a-eitherToResult (Left e) = ThrowHaxl e+eitherToResult :: Either SomeException a -> ResultVal a w+eitherToResult (Right a) = Ok a NilWrites+eitherToResult (Left e) = ThrowHaxl e NilWrites   -- -----------------------------------------------------------------------------@@ -400,10 +508,10 @@ -- 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 +560,19 @@ -- | 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)-      (Cont u a)+      {-# UNPACK #-} !(IVar u w b)+      (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 +626,22 @@ -- 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-  = Cont (GenHaxl u a)-  | forall b. Cont u b :>>= (b -> GenHaxl u a)-  | forall b. (b -> a) :<$> (Cont u b)+data Cont u w a+  = Cont (GenHaxl u w a)+  | forall b. Cont u w b :>>= (b -> GenHaxl u w a)+  | 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 +650,7 @@ -- ----------------------------------------------------------------------------- -- 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 +665,7 @@   -- 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 +674,7 @@       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 +736,12 @@ -- 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@@ -642,15 +750,45 @@     Blocked ivar k ->       return (Blocked ivar (Cont (withEnv newEnv (toHaxl k)))) +#ifdef PROFILING+-- -----------------------------------------------------------------------------+-- CallGraph recording +-- | Returns a version of the Haxl computation which records function calls in+-- an edge list which is the function call graph. Each function that is to be+-- recorded must be wrapped with a call to @withCallGraph@.+withCallGraph+  :: Typeable a+  => (a -> Maybe Text)+  -> QualFunction+  -> GenHaxl u w a+  -> GenHaxl u w a+withCallGraph toText f a = do+  coreEnv <- env id+  -- TODO: Handle exceptions+  value <- withEnv coreEnv{currFunction = f} a+  case callGraphRef coreEnv of+    Just graph -> unsafeLiftIO $ modifyIORef' graph+      (updateCallGraph (f, currFunction coreEnv) (toText value))+    _ -> throw $ CriticalError+      "withCallGraph called without an IORef CallGraph"+  return value+  where+    updateCallGraph :: FunctionCall -> Maybe Text -> CallGraph -> CallGraph+    updateCallGraph fnCall@(childQFunc, _) (Just value) (edgeList, valueMap) =+      (fnCall : edgeList, Map.insert childQFunc value valueMap)+    updateCallGraph fnCall Nothing (edgeList, valueMap) =+      (fnCall : edgeList, valueMap)+#endif+ -- ----------------------------------------------------------------------------- -- 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 +801,7 @@     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 +812,20 @@  -- | Catch exceptions that satisfy a predicate catchIf-  :: Exception e => (e -> Bool) -> GenHaxl u a -> (e -> GenHaxl u a)-  -> GenHaxl u a+  :: Exception e => (e -> Bool) -> GenHaxl u w a -> (e -> GenHaxl u w 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 +833,14 @@  -- | 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 +852,7 @@ -- 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 +862,20 @@ -- 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 = dumpCacheAsHaskellFn "loadCache" "GenHaxl u ()"+dumpCacheAsHaskell :: GenHaxl u w String+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 +883,8 @@     readIVar (IVar ref) = do       r <- readIORef ref       case r of-        IVarFull (Ok a) -> return (Just (Right a))-        IVarFull (ThrowHaxl e) -> return (Just (Left e))+        IVarFull (Ok a _) -> return (Just (Right a))+        IVarFull (ThrowHaxl e _) -> return (Just (Left e))         IVarFull (ThrowIO e) -> return (Just (Left e))         IVarEmpty _ -> return Nothing 

@@ -35,7 +35,7 @@ -- 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 @@ -- 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

@@ -4,6 +4,7 @@ -- This source code is distributed under the terms of a BSD license, -- found in the LICENSE file. +{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}@@ -23,7 +24,9 @@  import Data.IORef import Data.Hashable+#if __GLASGOW_HASKELL__ < 804 import Data.Monoid+#endif import Data.Text (Text) import Data.Typeable import qualified Data.HashMap.Strict as HashMap@@ -40,7 +43,7 @@ -- 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@@ -48,7 +51,7 @@  -- | 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@@ -59,9 +62,9 @@ -- | Collect profiling data and attribute it to given label. collectProfileData   :: ProfileLabel-  -> (Env u -> IO (Result u a))-  -> Env u-  -> IO (Result u a)+  -> (Env u w -> IO (Result u w a))+  -> Env u w+  -> IO (Result u w a) collectProfileData l m env = do    a0 <- getAllocationCounter    r <- m env{profLabel=l} -- what if it throws?@@ -75,7 +78,7 @@      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 =@@ -110,9 +113,9 @@ --   will call profileCont the next time this cont runs) -- profileCont-  :: (Env u -> IO (Result u a))-  -> Env u-  -> IO (Result u a)+  :: (Env u w -> IO (Result u w a))+  -> Env u w+  -> IO (Result u w a) profileCont m env = do   a0 <- getAllocationCounter   r <- m env@@ -140,8 +143,8 @@  {-# NOINLINE addProfileFetch #-} addProfileFetch-  :: forall r u a . (DataSourceName r, Eq (r a), Hashable (r a), Typeable (r a))-  => Env u -> r a -> IO ()+  :: forall r u w a . (DataSourceName r, Eq (r a), Hashable (r a), Typeable (r a))+  => Env u w -> r a -> IO () addProfileFetch env _req = do   c <- getAllocationCounter   modifyIORef' (profRef env) $ \ p ->

@@ -7,7 +7,9 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} -- | Bucketing requests by 'DataSource'. -- -- When a request is issued by the client via 'dataFetch', it is placed@@ -25,11 +27,22 @@   , noRequests   , addRequest   , contents+  , ReqCountMap(..)+  , emptyReqCounts+  , filterRCMap+  , getMapFromRCMap+  , addToCountMap+  , subFromCountMap   ) where +#if __GLASGOW_HASKELL__ <= 708+import Control.Applicative ((<$>))+#endif import Haxl.Core.DataSource import Data.Map (Map) import qualified Data.Map.Strict as Map+import Data.Proxy+import Data.Text (Text) import Data.Typeable import Unsafe.Coerce @@ -72,8 +85,67 @@    -- The TypeRep of requests for this data source   ty :: TypeRep-  ty = typeOf1 (undefined :: r a)+  !ty = typeOf1 (undefined :: r a)  -- | Retrieves the whole contents of the 'RequestStore'. contents :: RequestStore u -> [BlockedFetches u] contents (RequestStore m) = Map.elems m++-- A counter to keep track of outgone requests. Entries are added to this+-- map as we send requests to datasources, and removed as these fetches+-- are completed.+-- This is a 2 level map: the 1st level stores requests for a particular+-- datasource, the 2nd level stores count of requests per type.+newtype ReqCountMap = ReqCountMap (Map Text (Map TypeRep Int))+  deriving (Show)++emptyReqCounts :: ReqCountMap+emptyReqCounts = ReqCountMap Map.empty++addToCountMap+  :: forall (r :: * -> *). (DataSourceName r, Typeable r)+  => Proxy r+  -> Int -- type and number of requests+  -> ReqCountMap+  -> ReqCountMap+addToCountMap = updateCountMap (+)++subFromCountMap+  :: forall (r :: * -> *). (DataSourceName r, Typeable r)+  => Proxy r+  -> Int -- type and number of requests+  -> ReqCountMap+  -> ReqCountMap+subFromCountMap = updateCountMap (-)++updateCountMap+  :: forall (r :: * -> *). (DataSourceName r, Typeable r)+  => (Int -> Int -> Int)+  -> Proxy r+  -> Int -- type and number of requests+  -> ReqCountMap+  -> ReqCountMap+updateCountMap op p n (ReqCountMap m) = ReqCountMap $ Map.insertWith+  (flip (Map.unionWith op)) -- flip is important as "op" is not commutative+  (dataSourceName p) (Map.singleton ty n)+  m+  where+    -- The TypeRep of requests for this data source+    -- The way this is implemented, all elements in the 2nd level map will be+    -- mapped to the same key, as all requests to a datasource have the same+    -- "type". It will be more beneficial to be able to instead map requests+    -- to their names (ie, data constructor) - but there's no cheap way of doing+    -- that.+    ty :: TypeRep+    !ty = typeOf1 (undefined :: r a)++-- Filter all keys with 0 fetches. Since ReqCountMap is a 2-level map, we need+-- nested filter operations.+filterRCMap :: ReqCountMap -> ReqCountMap+filterRCMap (ReqCountMap m) = ReqCountMap $+  Map.filter ((> 0) . Map.size) (Map.filter (> 0) <$> m)++-- Filters the ReqCountMap by default+getMapFromRCMap :: ReqCountMap -> Map Text (Map TypeRep Int)+getMapFromRCMap r+  | ReqCountMap m <- filterRCMap r = m

@@ -4,6 +4,7 @@ -- This source code is distributed under the terms of a BSD license, -- found in the LICENSE file. +{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}@@ -13,8 +14,12 @@ -- module Haxl.Core.Run   ( runHaxl+  , runHaxlWithWrites   ) where +#if __GLASGOW_HASKELL__ <= 708+import Control.Applicative ((<$>))+#endif import Control.Concurrent.STM import Control.Exception as Exception import Control.Monad@@ -36,13 +41,23 @@ -- runHaxl  -- | Runs a 'Haxl' computation in the given 'Env'.-runHaxl :: forall u a. Env u -> GenHaxl u a -> IO a-runHaxl env@Env{..} haxl = do+--+-- Note: to make multiple concurrent calls to 'runHaxl', each one must+-- have a separate 'Env'. A single 'Env' must /not/ be shared between+-- multiple concurrent calls to 'runHaxl', otherwise deadlocks or worse+-- will likely ensue.+--+-- However, multiple 'Env's may share a single 'StateStore', and thereby+-- use the same set of datasources.+runHaxl:: forall u w a. Env u w -> GenHaxl u w a -> IO a+runHaxl env haxl = fst <$> runHaxlWithWrites env haxl +runHaxlWithWrites :: forall u w a. Env u w -> GenHaxl u w a -> IO (a, [w])+runHaxlWithWrites 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 #-}@@ -74,8 +89,12 @@         Left e -> do           rethrowAsyncExceptions e           result (ThrowIO e)-        Right (Done a) -> result (Ok a)-        Right (Throw ex) -> result (ThrowHaxl ex)+        Right (Done a) -> do+          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@@ -95,7 +114,7 @@     -- 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@@ -108,7 +127,7 @@         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@@ -122,7 +141,7 @@               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@@ -138,7 +157,7 @@             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@@ -171,7 +190,7 @@           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@@ -184,8 +203,10 @@   r <- readIORef resultRef   case r of     IVarEmpty _ -> throwIO (CriticalError "runHaxl: missing result")-    IVarFull (Ok a)  -> return a-    IVarFull (ThrowHaxl e)  -> throwIO e+    IVarFull (Ok a wt)  -> return (a, flattenWT wt)+    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  

@@ -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

@@ -106,12 +106,12 @@ -- -- > 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 @@   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 @@ -- 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 @@ -- '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 a   -- ^ if it throws 'LogicError' or 'TransientError', run this-  -> GenHaxl u a+  :: GenHaxl u w a   -- ^ run this first+  -> GenHaxl u w a   -- ^ if it throws 'LogicError' or 'TransientError', run this+  -> GenHaxl u w a catchAny haxl handler =   haxl `catch` \e ->     if isJust (fromException e :: Maybe LogicError) ||

@@ -1,3 +1,25 @@+# Changes in version 2.1.2.0++  * Add a callgraph reference to 'Env' to record the function callgraph during a+    computation. The callgraph is stored as an edge list in the Env through the+    use of `withCallGraph` and enables users to debug a Haxl computation.++# Changes in version 2.1.1.0+  * Adds feature to track outgone datasource fetches. This is only turned on+    for report level greater than 1. The fetches are stored as a running Map+    in the env ('submittedReqsRef').++# 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

@@ -1,5 +1,5 @@ name:                haxl-version:             2.0.1.1+version:             2.1.2.0 synopsis:            A Haskell library for efficient, concurrent,                      and concise data access. homepage:            https://github.com/facebook/Haxl@@ -68,6 +68,7 @@    exposed-modules:     Haxl.Core,+    Haxl.Core.CallGraph,     Haxl.Core.DataCache,     Haxl.Core.DataSource,     Haxl.Core.Exception,@@ -132,6 +133,7 @@   if impl(ghc >= 8.0)     other-modules:       AdoTests+      OutgoneFetchesTests    other-modules:     AllTests@@ -151,6 +153,7 @@     TestTypes     TestUtils     WorkDataSource+    WriteTests    type:     exitcode-stdio-1.0

@@ -2,6 +2,8 @@  # Haxl +[![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 @@ -55,5 +57,3 @@    Hackage.   * [There is no Fork: An Abstraction for Efficient, Concurrent, and Concise Data Access](http://simonmar.github.io/bib/papers/haxl-icfp14.pdf), our paper on Haxl, accepted for publication at ICFP'14.--[![Build Status](https://travis-ci.org/facebook/Haxl.svg?branch=master)](https://travis-ci.org/facebook/Haxl)

@@ -13,6 +13,7 @@ import DataCacheTest #if __GLASGOW_HASKELL__ >= 801 import AdoTests+import OutgoneFetchesTests #endif #if __GLASGOW_HASKELL__ >= 710 import ProfileTests@@ -20,6 +21,7 @@ import MemoizationTests import TestBadDataSource import FullyAsyncTest+import WriteTests  import Test.HUnit @@ -32,6 +34,7 @@   , TestLabel "DataCacheTests" DataCacheTest.tests #if __GLASGOW_HASKELL__ >= 801   , TestLabel "AdoTests" $ AdoTests.tests False+  , TestLabel "OutgoneFetchesTest" OutgoneFetchesTests.tests #endif #if __GLASGOW_HASKELL__ >= 710   , TestLabel "ProfileTests" ProfileTests.tests@@ -39,4 +42,5 @@   , TestLabel "MemoizationTests" MemoizationTests.tests   , TestLabel "BadDataSourceTests" TestBadDataSource.tests   , TestLabel "FullyAsyncTest" FullyAsyncTest.tests+  , TestLabel "WriteTest" WriteTests.tests   ]

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

@@ -32,10 +32,10 @@ instance Hashable (TestReq a) where   hashWithSalt salt (Req i) = hashWithSalt salt i -newResult :: a -> IO (IVar u a)-newResult a = IVar <$> newIORef (IVarFull (Ok a))+newResult :: a -> IO (IVar u w a)+newResult a = IVar <$> newIORef (IVarFull (Ok a NilWrites)) -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@@ -56,25 +56,25 @@   -- with a result of type String, we should get Nothing, not a crash.   r <- mapM takeResult $ DataCache.lookup (Req 1) cache   assertBool "dcSoundness1" $-    case r :: Maybe (ResultVal String) of+    case r :: Maybe (ResultVal String ()) of      Nothing -> True      _something_else -> False    r <- mapM takeResult $ DataCache.lookup (Req 1) cache   assertBool "dcSoundness2" $-    case r :: Maybe (ResultVal Int) of-     Just (Ok 1) -> True+    case r :: Maybe (ResultVal Int ()) of+     Just (Ok 1 NilWrites) -> True      _something_else -> False    r <- mapM takeResult $ DataCache.lookup (Req 2) cache   assertBool "dcSoundness3" $-    case r :: Maybe (ResultVal String) of-      Just (Ok "hello") -> True+    case r :: Maybe (ResultVal String ()) of+      Just (Ok "hello" NilWrites) -> True       _something_else -> False    r <- mapM takeResult $ DataCache.lookup (Req 2) cache   assertBool "dcSoundness4" $-    case r :: Maybe (ResultVal Int) of+    case r :: Maybe (ResultVal Int ()) of       Nothing -> True       _something_else -> False 

@@ -155,8 +155,8 @@ -- 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)

@@ -48,7 +48,7 @@   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  {-

@@ -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))

@@ -5,7 +5,7 @@ -- found in the LICENSE file.  -- | Benchmarking tool for core performance characteristics of the Haxl monad.-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, OverloadedStrings #-} module MonadBench (main) where  import Control.Monad@@ -25,7 +25,9 @@  import ExampleDataSource -testEnv :: IO (Env ())+newtype SimpleWrite = SimpleWrite Text deriving (Eq, Show)++testEnv :: IO (Env () SimpleWrite) testEnv = do   exstate <- ExampleDataSource.initGlobalState   let st = stateSet exstate stateEmpty@@ -88,7 +90,15 @@                        | x <- take n $ cycle [100, 200 .. 1000]                        , let y = x + 1000                        ]+    -- parallel writes+    "write1" -> runHaxl env $+      Haxl.sequence_ (replicate n (tellWrite (SimpleWrite "haha"))) +    -- sequential writes+    "write2" -> runHaxl env $+      foldr andThen (return ()) (replicate n (tellWrite (SimpleWrite "haha")))++     "cc1" -> runHaxl env $       Haxl.sequence_ [ cachedComputation (ListWombats 1000) unionWombats                      | _ <- [1..n]@@ -118,18 +128,18 @@   -- 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 () SimpleWrite [Id] tree 0 = listWombats 0 tree n = concat <$> Haxl.sequence   [ tree (n-1)   , listWombats (fromIntegral n), tree (n-1)   ] -unionWombats :: GenHaxl () [Id]+unionWombats :: GenHaxl () SimpleWrite [Id] unionWombats = foldl List.union [] <$> Haxl.mapM listWombats [1..1000] -unionWombatsTo :: Id -> GenHaxl () [Id]+unionWombatsTo :: Id -> GenHaxl () SimpleWrite [Id] unionWombatsTo x = foldl List.union [] <$> Haxl.mapM listWombats [1..x] -unionWombatsFromTo :: Id -> Id -> GenHaxl () [Id]+unionWombatsFromTo :: Id -> Id -> GenHaxl () SimpleWrite [Id] unionWombatsFromTo x y = foldl List.union [] <$> Haxl.mapM listWombats [x..y]

@@ -0,0 +1,137 @@+-- 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 OverloadedStrings #-}+{-# LANGUAGE ApplicativeDo #-}+module OutgoneFetchesTests (tests) where++import Haxl.Prelude as Haxl+import Prelude()++import Haxl.Core+import Haxl.DataSource.ConcurrentIO+import Haxl.Core.RequestStore (getMapFromRCMap)++import Data.IORef+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Proxy (Proxy(..))+import Data.Typeable+import Test.HUnit+import System.Timeout++import ExampleDataSource+import SleepDataSource++testEnv = do+  exstate <- ExampleDataSource.initGlobalState+  sleepState <- mkConcurrentIOState+  let st = stateSet exstate $ stateSet sleepState stateEmpty+  e <- initEnv st ()+  return e { flags = (flags e) {report = 1} }+    -- report=1 to enable fetches tracking++-- A cheap haxl computation we interleave b/w the @sleep@ fetches.+wombats :: GenHaxl () () Int+wombats = length <$> listWombats 3++getFetches :: Env () () -> IO (Map Text (Map TypeRep Int))+getFetches env = getMapFromRCMap <$> readIORef (submittedReqsRef env)++outgoneFetchesTest :: Test+outgoneFetchesTest = TestCase $ do+  let+    withTimeout env h = timeout 2000 $ runHaxl env h -- 2 ms++  -- test that a completed datasource fetch doesn't show up in Env+  env <- testEnv++  withTimeout env $ do+    _ <- sleep 1 -- 1 ms+    _ <- sleep 1 -- should be cached+    _ <- sleep 1+    wombats++  fetchesMap <- getFetches env+  assertEqual "outgoneFetches1" 0 (Map.size fetchesMap)++  -- test that unfinished datasource fetches shows up in Env+  env <- testEnv++  withTimeout env $ do+    _ <- sleep 4 -- 4 ms+    _ <- wombats+    _ <- sleep 5 -- 4 ms+    _  <- wombats+    return ()++  fetchesMap <- getFetches env+  assertEqual "outgoneFetches2" 1 (Map.size fetchesMap)+  assertEqual "outgoneFetches2"+    (Map.fromList+      [ ( dataSourceName (Proxy :: Proxy (ConcurrentIOReq Sleep))+        , Map.fromList [(typeOf1 (undefined :: ConcurrentIOReq Sleep a), 2)]+        )+      ])+    fetchesMap++  -- test for finished/unfinished fetches from the same datasource+  env <- testEnv++  withTimeout env $ do+    _ <- sleep 1 -- 1 ms+    _ <- sleep 4+    _ <- sleep 5+    return ()++  fetchesMap <- getFetches env+  assertEqual "outgoneFetches3"+    (Map.fromList+      [ ( dataSourceName (Proxy :: Proxy (ConcurrentIOReq Sleep))+        , Map.fromList [(typeOf1 (undefined :: ConcurrentIOReq Sleep a), 2)]+        )+      ])+    fetchesMap++  -- test for cached requests not showing up twice in ReqCountMap+  env <- testEnv++  withTimeout env $ do+    _ <- sleep 4 -- 3 ms+    _ <- sleep 4+    return ()++  fetchesMap <- getFetches env+  assertEqual "outgoneFetches4"+    (Map.fromList+      [ ( dataSourceName (Proxy :: Proxy (ConcurrentIOReq Sleep))+        , Map.fromList [(typeOf1 (undefined :: ConcurrentIOReq Sleep a), 1)]+        )+      ])+    fetchesMap++  -- test for unsent requests not showing up in ReqCountMap+  env <- testEnv++  withTimeout env $ do+    _ <- sleep =<< sleep 4 -- second req should never be sent+    return ()++  fetchesMap <- getFetches env+  assertEqual "outgoneFetches5"+    (Map.fromList+      [ ( dataSourceName (Proxy :: Proxy (ConcurrentIOReq Sleep))+        , Map.fromList [(typeOf1 (undefined :: ConcurrentIOReq Sleep a), 1)]+        )+      ])+    fetchesMap+++++tests = TestList+  [ TestLabel "outgoneFetchesTest" outgoneFetchesTest+  ]

@@ -14,7 +14,7 @@ {-# LANGUAGE FlexibleInstances #-}  module SleepDataSource (-    sleep,+    Sleep, sleep,   ) where  import Haxl.Prelude@@ -27,7 +27,7 @@ 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

@@ -25,7 +25,7 @@   let st = stateSet exstate $ stateSet (fn badstate) stateEmpty   initEnv st () -wombats :: GenHaxl () Int+wombats :: GenHaxl () () Int wombats = length <$> listWombats 3  badDataSourceTest :: Test

@@ -11,6 +11,7 @@ module TestTypes    ( UserEnv    , Haxl+   , HaxlEnv    , lookupInput    , Id(..)    ) where@@ -26,7 +27,8 @@ import Haxl.Core  type UserEnv = Object-type Haxl a = GenHaxl UserEnv a+type Haxl a = GenHaxl UserEnv () a+type HaxlEnv = Env UserEnv ()  lookupInput :: FromJSON a => Text -> Haxl a lookupInput field = do

@@ -46,7 +46,7 @@ id4 :: Haxl Id id4 = lookupInput "D" -makeTestEnv :: Bool -> IO (Env UserEnv)+makeTestEnv :: Bool -> IO HaxlEnv makeTestEnv future = do   tao <- MockTAO.initGlobalState future   let st = stateSet tao stateEmpty@@ -54,7 +54,7 @@   return env { flags = (flags env) { report = 2 } }  expectResultWithEnv-  :: (Eq a, Show a) => a -> Haxl a -> Env UserEnv -> Assertion+  :: (Eq a, Show a) => a -> Haxl a -> HaxlEnv -> Assertion expectResultWithEnv result haxl env = do   a <- runHaxl env haxl   assertEqual "result" result a

@@ -25,7 +25,7 @@ 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

@@ -0,0 +1,100 @@+-- 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, OverloadedStrings #-}+module WriteTests (tests) where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+#endif++import Test.HUnit++import Data.Foldable++import Haxl.Core+import Haxl.Prelude as Haxl++newtype SimpleWrite = SimpleWrite Text+  deriving (Eq, Show)++doWrite :: GenHaxl u SimpleWrite Int+doWrite = do+  tellWrite $ SimpleWrite "inner"+  return 0++doOuterWrite :: GenHaxl u SimpleWrite Int+doOuterWrite = do+  tellWrite $ SimpleWrite "outer1"++  doWriteMemo <- newMemoWith doWrite+  let doMemoizedWrite = runMemo doWriteMemo+  _ <- doMemoizedWrite+  _ <- doMemoizedWrite++  tellWrite $ SimpleWrite "outer2"++  return 1++writeSoundness :: Test+writeSoundness = TestCase $ do+  let numReps = 4++  -- do writes without memoization+  env1 <- emptyEnv ()+  (allRes, allWrites) <- runHaxlWithWrites env1 $+    Haxl.sequence (replicate numReps doWrite)++  assertBool "Write Soundness 1" $+    allWrites == replicate numReps (SimpleWrite "inner")+  assertBool "Write Soundness 2" $ allRes == replicate numReps 0++  -- do writes with memoization+  env2 <- emptyEnv ()++  (memoRes, memoWrites) <- runHaxlWithWrites env2 $ do+    doWriteMemo <- newMemoWith doWrite+    let memoizedWrite = runMemo doWriteMemo++    Haxl.sequence (replicate numReps memoizedWrite)++  assertBool "Write Soundness 3" $+    memoWrites == replicate numReps (SimpleWrite "inner")+  assertBool "Write Soundness 4" $ memoRes == replicate numReps 0++  -- do writes with interleaved memo+  env3 <- emptyEnv ()++  (ilRes, ilWrites) <- runHaxlWithWrites env3 $ do+    doWriteMemo <- newMemoWith doWrite+    let memoizedWrite = runMemo doWriteMemo++    Haxl.sequence $ replicate numReps (doWrite *> memoizedWrite)++  assertBool "Write Soundness 5" $+    ilWrites == replicate (2*numReps) (SimpleWrite "inner")+  assertBool "Write Soundness 6" $ ilRes == replicate numReps 0++  -- do writes with nested memo+  env4 <- emptyEnv ()++  (nestRes, nestWrites) <- runHaxlWithWrites env4 $ do+    doWriteMemo' <- newMemoWith doOuterWrite+    let memoizedWrite' = runMemo doWriteMemo'++    Haxl.sequence (replicate numReps memoizedWrite')++  let expWrites =+        [ SimpleWrite "outer1"+        , SimpleWrite "inner"+        , SimpleWrite "inner"+        , SimpleWrite "outer2"+        ]+  assertBool "Write Soundness 7" $+    nestWrites == fold (replicate numReps expWrites)+  assertBool "Write Soundness 8" $ nestRes == replicate numReps 1++tests = TestList [TestLabel "Write Soundness" writeSoundness]