haxl 2.3.0.0 → 2.4.0.0

raw patch · 30 files changed

+954/−186 lines, 30 filesdep ~aesonPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: aeson

API changes (from Hackage documentation)

Files

• Haxl/Core.hs +13/−1
• Haxl/Core/DataCache.hs +2/−2
• Haxl/Core/DataSource.hs +21/−7
• Haxl/Core/Exception.hs +5/−6
• Haxl/Core/Fetch.hs +149/−56
• Haxl/Core/Flags.hs +75/−15
• Haxl/Core/Memo.hs +3/−2
• Haxl/Core/Monad.hs +102/−41
• Haxl/Core/Parallel.hs +1/−1
• Haxl/Core/Profile.hs +20/−13
• Haxl/Core/RequestStore.hs +4/−3
• Haxl/Core/Run.hs +7/−5
• Haxl/Core/StateStore.hs +2/−1
• Haxl/Core/Stats.hs +31/−0
• changelog.md +5/−1
• haxl.cabal +4/−2
• readme.md +2/−2
• tests/AllTests.hs +4/−0
• tests/DataCacheTest.hs +114/−3
• tests/DataSourceDispatchTests.hs +81/−0
• tests/ExceptionStackTests.hs +71/−0
• tests/FullyAsyncTest.hs +2/−1
• tests/MonadBench.hs +8/−5
• tests/OutgoneFetchesTests.hs +2/−3
• tests/ProfileTests.hs +29/−3
• tests/StatsTests.hs +2/−1
• tests/TestExampleDataSource.hs +2/−1
• tests/TestTypes.hs +18/−6
• tests/TestUtils.hs +9/−3
• tests/WriteTests.hs +166/−2

@@ -63,7 +63,16 @@   , AllocCount   , LabelHitCount -    -- ** Tracing flags+    -- * Report flags+  , ReportFlag(..)+  , ReportFlags+  , defaultReportFlags+  , profilingReportFlags+  , setReportFlag+  , clearReportFlag+  , testReportFlag++    -- ** Flags   , Flags(..)   , defaultFlags   , ifTrace@@ -88,6 +97,9 @@   , putResult   , putSuccess   , putResultFromChildThread+  , putResultWithStats+  , putResultWithStatsFromChildThread+  , DataSourceStats(..)      -- ** Default fetch implementations   , asyncFetch, asyncFetchWithDispatch, asyncFetchAcquireRelease

@@ -50,8 +50,8 @@ -- 'Hashable' and 'Eq' once per request type. -- data SubCache res =-  forall req a . (Hashable (req a), Eq (req a), Typeable (req a)) =>-       SubCache (req a -> String) (a -> String) ! (HashTable (req a) (res a))+  forall req a . (Hashable (req a), Eq (req a)) =>+       SubCache (req a -> String) (a -> String) !(HashTable (req a) (res a))        -- NB. the inner HashMap is strict, to avoid building up        -- a chain of thunks during repeated insertions. 

@@ -36,6 +36,8 @@   , putResult   , putResultFromChildThread   , putSuccess+  , putResultWithStats+  , putResultWithStatsFromChildThread    -- * Default fetch implementations   , asyncFetch, asyncFetchWithDispatch@@ -55,12 +57,14 @@ import Control.Monad import Data.Hashable import Data.Text (Text)+import Data.Kind (Type) import Data.Typeable  import Haxl.Core.Exception import Haxl.Core.Flags import Haxl.Core.ShowP import Haxl.Core.StateStore+import Haxl.Core.Stats   import GHC.Conc ( newStablePtrPrimMVar@@ -70,7 +74,6 @@                           , myThreadId ) import Control.Concurrent.MVar import Foreign.StablePtr-import System.Mem (setAllocationCounter)  -- --------------------------------------------------------------------------- -- DataSource class@@ -107,7 +110,7 @@   classifyFailure :: u -> req a -> SomeException -> FailureClassification   classifyFailure _ _ _ = StandardFailure -class DataSourceName (req :: * -> *) where+class DataSourceName (req :: Type -> Type) where   -- | The name of this 'DataSource', used in tracing and stats. Must   -- take a dummy request.   dataSourceName :: Proxy req -> Text@@ -128,7 +131,7 @@   )  -- | Hints to the scheduler about this data source-data SchedulerHint (req :: * -> *)+data SchedulerHint (req :: Type -> Type)   = TryToBatch     -- ^ Hold data-source requests while we execute as much as we can, so     -- that we can hopefully collect more requests to batch.@@ -183,12 +186,15 @@ -- ResultVar  -- | A sink for the result of a data fetch in 'BlockedFetch'-newtype ResultVar a = ResultVar (Either SomeException a -> Bool -> IO ())+newtype ResultVar a =+  ResultVar (Either SomeException a -> Bool -> Maybe DataSourceStats -> IO ())   -- The Bool here is True if result was returned by a child thread,   -- rather than the main runHaxl thread.  see Note [tracking allocation in   -- child threads] -mkResultVar :: (Either SomeException a -> Bool -> IO ()) -> ResultVar a+mkResultVar+  :: (Either SomeException a -> Bool -> Maybe DataSourceStats -> IO ())+  -> ResultVar a mkResultVar = ResultVar  putFailure :: (Exception e) => ResultVar a -> e -> IO ()@@ -198,8 +204,16 @@ putSuccess r = putResult r . Right  putResult :: ResultVar a -> Either SomeException a -> IO ()-putResult (ResultVar io) res = io res False+putResult (ResultVar io) res = io res False Nothing +putResultWithStats+  :: ResultVar a -> Either SomeException a -> DataSourceStats -> IO ()+putResultWithStats (ResultVar io) res st = io res False (Just st)++putResultWithStatsFromChildThread+  :: ResultVar a -> Either SomeException a -> DataSourceStats -> IO ()+putResultWithStatsFromChildThread (ResultVar io) res st = io res True (Just st)+ -- | Like `putResult`, but used to get correct accounting when work is -- being done in child threads.  This is particularly important for -- data sources that are using 'BackgroundFetch', The allocation performed@@ -216,7 +230,7 @@ -- 'putResultFromChildThread', so that allocation is not counted -- multiple times. putResultFromChildThread :: ResultVar a -> Either SomeException a -> IO ()-putResultFromChildThread (ResultVar io) res =  io res True+putResultFromChildThread (ResultVar io) res =  io res True Nothing   -- see Note [tracking allocation in child threads]  -- | Function for easily setting a fetch to a particular exception

@@ -81,6 +81,7 @@ import Data.Binary (Binary) import Data.Typeable import Data.Text (Text)+import qualified Data.Text as Text  import Haxl.Core.Util import GHC.Stack@@ -113,11 +114,12 @@          e   deriving (Typeable) -type Stack = [String]+type Stack = [Text]   -- hopefully this will get more informative in the future  instance Show HaxlException where-  show (HaxlException (Just stk@(_:_)) e) = show e ++ '\n' : renderStack stk+  show (HaxlException (Just stk@(_:_)) e) =+    show e ++ '\n' : renderStack (reverse $ map Text.unpack stk)   show (HaxlException _ e) = show e  instance Exception HaxlException@@ -126,7 +128,7 @@ instance ToJSON HaxlException where   toJSON (HaxlException stk e) = object fields     where-      fields | Just s@(_:_) <- stk = ("stack" .= reverse s) : rest+      fields | Just s@(_:_) <- stk = ("stack" .= s) : rest              | otherwise = rest       rest =         [ "type" .= show (typeOf e)@@ -362,9 +364,6 @@ rethrowAsyncExceptions :: SomeException -> IO () rethrowAsyncExceptions e   | Just SomeAsyncException{} <- fromException e = Exception.throw e-  | Just AllocationLimitExceeded{} <- fromException e = Exception.throw e-    -- AllocationLimitExceeded is not a child of SomeAsyncException,-    -- but it should be.   | otherwise = return ()  tryWithRethrow :: IO a -> IO (Either SomeException a)

@@ -23,6 +23,7 @@ module Haxl.Core.Fetch   ( dataFetch   , dataFetchWithShow+  , dataFetchWithInsert   , uncachedRequest   , cacheResult   , dupableCacheRequest@@ -47,6 +48,7 @@ import Data.Proxy import Data.Typeable import Data.Text (Text)+import Data.Kind (Type) import qualified Data.Text as Text import Text.Printf #ifdef PROFILING@@ -111,8 +113,7 @@     doFetch = do       ivar <- newIVar       k <- nextCallId env-      let !rvar = stdResultVar ivar completions submittedReqsRef flags-            (Proxy :: Proxy r)+      let !rvar = stdResultVar env ivar (Proxy :: Proxy r)       insertFn req (DataCacheItem ivar k) dataCache       return (Uncached rvar ivar k)   mbRes <- DataCache.lookup req dataCache@@ -137,14 +138,12 @@ -- completes. stdResultVar   :: forall r a u w. (DataSourceName r, Typeable r)-  => IVar u w a-  -> TVar [CompleteReq u w]-  -> IORef ReqCountMap-  -> Flags+  => Env u w+  -> IVar u w a   -> Proxy r   -> ResultVar a-stdResultVar ivar completions ref flags p =-  mkResultVar $ \r isChildThread -> do+stdResultVar Env{..} ivar p =+  mkResultVar $ \r isChildThread _ -> do     allocs <- if isChildThread       then         -- In a child thread, return the current allocation counter too,@@ -155,12 +154,12 @@     atomicallyOnBlocking       (LogicBug (ReadingCompletionsFailedFetch (dataSourceName p))) $ do       cs <- readTVar completions-      writeTVar completions (CompleteReq r ivar allocs : cs)+      writeTVar completions (CompleteReq (eitherToResult r) ivar allocs : cs)     -- Decrement the counter as request has finished. Do this after updating the     -- completions TVar so that if the scheduler is tracking what was being     -- waited on it gets a consistent view.-    ifReport flags 1 $-      atomicModifyIORef' ref (\m -> (subFromCountMap p 1 m, ()))+    ifReport flags ReportOutgoneFetches $+      atomicModifyIORef' submittedReqsRef (\m -> (subFromCountMap p 1 m, ())) {-# INLINE stdResultVar #-}  @@ -169,7 +168,7 @@ logFetch :: Env u w -> (r a -> String) -> r a -> CallId -> IO () #ifdef PROFILING logFetch env showFn req fid = do-  ifReport (flags env) 5 $ do+  ifReport (flags env) ReportFetchStack $ do     stack <- currentCallStack     modifyIORef' (statsRef env) $ \(Stats s) ->       Stats (FetchCall (showFn req) stack fid : s)@@ -177,6 +176,55 @@ logFetch _ _ _ _ = return () #endif +calcFailure+  :: forall u req a . DataSource u req+  => u+  -> req a+  -> Either SomeException a+  -> FailureCount+calcFailure _u _r Right{} = mempty+calcFailure u r (Left e) = case classifyFailure u r e of+  StandardFailure -> mempty { failureCountStandard = 1 }+  IgnoredForStatsFailure -> mempty { failureCountIgnored = 1 }++addFallbackFetchStats+  :: forall u w req a . DataSource u req+  => Env u w+  -> CallId+  -> req a+  -> ResultVal a w+  -> IO ()+addFallbackFetchStats Env{..} fid req res = do+  bid <- atomicModifyIORef' statsBatchIdRef $ \x -> (x+1,x+1)+  start <- getTimestamp+  let+    dsName = dataSourceName (Proxy :: Proxy req)+    FailureCount{..} = case res of+      Ok{} -> mempty+      (ThrowHaxl e _) -> calcFailure userEnv req (Left e)+      (ThrowIO e) -> calcFailure userEnv req (Left e)+    this = FetchStats { fetchDataSource = dsName+                      , fetchBatchSize = 1+                      , fetchStart = start+                      , fetchDuration = 0+                      , fetchSpace = 0+                      , fetchFailures = failureCountStandard+                      , fetchIgnoredFailures = failureCountIgnored+                      , fetchBatchId = bid+                      , fetchIds = [fid] }+  atomicModifyIORef' statsRef $ \(Stats fs) -> (Stats (this : fs), ())++addFallbackResult+  :: Env u w+  -> ResultVal a w+  -> IVar u w a+  -> IO ()+addFallbackResult Env{..} res ivar = do+  atomicallyOnBlocking+    (LogicBug (ReadingCompletionsFailedFetch "addFallbackResult")) $ do+    cs <- readTVar completions+    writeTVar completions (CompleteReq res ivar 0 : cs)+ -- | Performs actual fetching of data for a 'Request' from a 'DataSource'. dataFetch :: (DataSource u r, Request r a) => r a -> GenHaxl u w a dataFetch = dataFetchWithInsert show DataCache.insert@@ -212,18 +260,36 @@       -- Check whether the data source wants to submit requests       -- eagerly, or batch them up.       ---      let blockedFetch = BlockedFetch req rvar-      let blockedFetchI = BlockedFetchInternal fid-      case schedulerHint userEnv :: SchedulerHint r of-        SubmitImmediately ->-          performFetches env [BlockedFetches [blockedFetch] [blockedFetchI]]-        TryToBatch ->-          -- add the request to the RequestStore and continue-          modifyIORef' reqStoreRef $ \bs ->-            addRequest blockedFetch blockedFetchI bs-      ---      return $ Blocked ivar (Return ivar)+      let+        blockedFetch = BlockedFetch req rvar+        blockedFetchI = BlockedFetchInternal fid+        submitFetch = do+          case schedulerHint userEnv :: SchedulerHint r of+            SubmitImmediately ->+              performFetches env [BlockedFetches [blockedFetch] [blockedFetchI]]+            TryToBatch ->+              -- add the request to the RequestStore and continue+              modifyIORef' reqStoreRef $ \bs ->+                addRequest blockedFetch blockedFetchI bs+          return $ Blocked ivar (Return ivar) +      -- if there is a fallback configured try that,+      -- else dispatch the fetch+      case dataCacheFetchFallback of+        Nothing -> submitFetch+        Just (DataCacheLookup dcl) -> do+          mbFallbackRes <- dcl req+          case mbFallbackRes of+            Nothing -> submitFetch+            Just fallbackRes -> do+              addFallbackResult env fallbackRes ivar+              ifReport flags ReportFetchStats $ addFallbackFetchStats+                env+                fid+                req+                fallbackRes+              return $ Blocked ivar (Return ivar)+     -- Seen before but not fetched yet.  We're blocked, but we don't have     -- to add the request to the RequestStore.     CachedNotFetched ivar fid -> do@@ -233,7 +299,7 @@     -- Cached: either a result, or an exception     Cached r fid -> do       ifProfiling flags $ addProfileFetch env req fid True-      done r+      done env r  -- | A data request that is not cached.  This is not what you want for -- normal read requests, because then multiple identical requests may@@ -251,17 +317,16 @@ -- allows a transparent run afterwards. Without this, the test would try to -- call the datasource during testing and that would be an exception. uncachedRequest- :: forall a u w (r :: * -> *). (DataSource u r, Request r a)+ :: forall a u w (r :: Type -> Type). (DataSource u r, Request r a)  => r a -> GenHaxl u w a uncachedRequest req = do   flg <- env flags-  subRef <- env submittedReqsRef   if recording flg /= 0     then dataFetch req     else GenHaxl $ \e@Env{..} -> do       ivar <- newIVar       k <- nextCallId e-      let !rvar = stdResultVar ivar completions subRef flg (Proxy :: Proxy r)+      let !rvar = stdResultVar e ivar (Proxy :: Proxy r)       modifyIORef' reqStoreRef $ \bs ->         addRequest (BlockedFetch req rvar) (BlockedFetchInternal k) bs       return $ Blocked ivar (Return ivar)@@ -292,26 +357,34 @@   -> r a   -> IO a   -> GenHaxl u w a-cacheResultWithInsert showFn insertFn req val = GenHaxl $ \e@Env{..} -> do+cacheResultWithInsert showFn insertFn req val = GenHaxl $ \env@Env{..} -> do   mbRes <- DataCache.lookup req dataCache   case mbRes of     Nothing -> do-      eitherResult <- Exception.try val-      case eitherResult of-        Left e -> rethrowAsyncExceptions e-        _ -> return ()-      let result = eitherToResultThrowIO eitherResult+      let+        getResult = do+          eitherResult <- Exception.try val+          case eitherResult of+            Left e -> rethrowAsyncExceptions e+            _ -> return ()+          return $ eitherToResultThrowIO eitherResult+      -- if there is a fallback configured try that+      result <- case dataCacheFetchFallback of+        Nothing -> getResult+        Just (DataCacheLookup dcl) -> do+          mbFallbackRes <- dcl req+          maybe getResult return mbFallbackRes       ivar <- newFullIVar result-      k <- nextCallId e+      k <- nextCallId env       insertFn req (DataCacheItem ivar k) dataCache-      done result+      done env result     Just (DataCacheItem IVar{ivarRef = cr} _) -> do       e <- readIORef cr       case e of-        IVarEmpty _ -> corruptCache-        IVarFull r -> done r+        IVarEmpty _ -> raise env corruptCache+        IVarFull r -> done env r   where-    corruptCache = raise . DataSourceError $ Text.concat+    corruptCache = DataSourceError $ Text.concat       [ Text.pack (showFn req)       , " has a corrupted cache value: these requests are meant to"       , " return immediately without an intermediate value. Either"@@ -341,7 +414,7 @@     -- It is an error if the request is already in the cache.     -- We can't test whether the cached result is the same without adding an     -- Eq constraint, and we don't necessarily have Eq for all results.-    _other -> raise $+    _other -> raise e $       DataSourceError "cacheRequest: request is already in the cache"  -- | Similar to @cacheRequest@ but doesn't throw an exception if the key@@ -386,7 +459,7 @@                   <> Text.pack (showp req)         Just state ->           return $ FetchToDo reqs-            $ (if report f >= 2+            $ (if testReportFlag ReportFetchStats $ report f                 then wrapFetchInStats                         (userEnv env)                         sref@@ -413,7 +486,7 @@  data FetchToDo where   FetchToDo-    :: forall (req :: * -> *). (DataSourceName req, Typeable req)+    :: forall (req :: Type -> Type). (DataSourceName req, Typeable req)     => [BlockedFetch req] -> PerformFetch req -> FetchToDo  -- Catch exceptions arising from the data source and stuff them into@@ -490,7 +563,8 @@       SyncFetch $ \reqs -> do         bid <- newBatchId         fail_ref <- newIORef mempty-        (t0,t,alloc,_) <- statsForIO (f (map (addFailureCount u fail_ref) reqs))+        (t0,t,alloc,_) <- statsForIO (f (map (addFailureCount u fail_ref)+          (reqsWithFetchDsStats bid reqs)))         failures <- readIORef fail_ref         updateFetchStats bid allFids t0 t alloc batchSize failures     AsyncFetch f -> do@@ -502,7 +576,8 @@               (_,t,alloc,_) <- statsForIO inner               writeIORef inner_r (t,alloc)             reqs' = map (addFailureCount u fail_ref) reqs-        (t0, totalTime, totalAlloc, _) <- statsForIO (f reqs' inner')+            reqs'' = reqsWithFetchDsStats bid reqs'+        (t0, totalTime, totalAlloc, _) <- statsForIO (f reqs'' inner')         (innerTime, innerAlloc) <- readIORef inner_r         failures <- readIORef fail_ref         updateFetchStats bid allFids t0 (totalTime - innerTime)@@ -511,7 +586,8 @@       BackgroundFetch $ \reqs -> do         bid <- newBatchId         startTime <- getTimestamp-        io (zipWith (addTimer u bid startTime) reqs reqsI)+        io (reqsWithFetchDsStats bid+          (zipWith (addTimer u bid startTime) reqs reqsI))   where     allFids = map (\(BlockedFetchInternal k) -> k) reqsI     newBatchId = atomicModifyIORef' batchIdRef $ \x -> (x+1,x+1)@@ -520,20 +596,15 @@       (t0,t,a) <- time io       postAlloc <- getAllocationCounter       return (t0,t, fromIntegral $ prevAlloc - postAlloc, a)--    calcFailure _u _r (Right _) = mempty-    calcFailure u r (Left e) = case classifyFailure u r e of-      StandardFailure -> mempty { failureCountStandard = 1 }-      IgnoredForStatsFailure -> mempty { failureCountIgnored = 1 }--+    reqsWithFetchDsStats = \bid reqs+      -> zipWith (addFetchDatasourceStats bid) reqs reqsI     addTimer       u       bid       t0       (BlockedFetch req (ResultVar fn))       (BlockedFetchInternal fid) =-        BlockedFetch req $ ResultVar $ \result isChildThread -> do+        BlockedFetch req $ ResultVar $ \result isChildThread stats -> do           t1 <- getTimestamp           -- We cannot measure allocation easily for BackgroundFetch. Here we           -- just attribute all allocation to the last@@ -546,8 +617,30 @@             (negate allocs)             1 -- batch size: we don't know if this is a batch or not             (calcFailure u req result) -- failures-          fn result isChildThread+          fn result isChildThread stats +    addFetchDatasourceStats+      :: Int+      -> BlockedFetch r+      -> BlockedFetchInternal+      -> BlockedFetch r+    addFetchDatasourceStats bid+      (BlockedFetch req (ResultVar fn))+      (BlockedFetchInternal fid) = BlockedFetch req $ ResultVar+        $ \result isChildThread stats -> do+          let mkStats dss = FetchDataSourceStats+                { fetchDsStatsCallId = fid+                , fetchDsStatsDataSource = dataSource+                , fetchDsStatsStats = dss+                , fetchBatchId = bid+                }+          case stats of+            Just dss -> atomicModifyIORef' statsRef+              $ \(Stats fs) -> (Stats (mkStats dss : fs), ())+            Nothing -> return ()+          fn result isChildThread stats++     updateFetchStats       :: Int       -> [CallId]@@ -572,10 +665,10 @@     addFailureCount :: DataSource u r       => u -> IORef FailureCount -> BlockedFetch r -> BlockedFetch r     addFailureCount u ref (BlockedFetch req (ResultVar fn)) =-      BlockedFetch req $ ResultVar $ \result isChildThread -> do+      BlockedFetch req $ ResultVar $ \result isChildThread stats -> do         let addFailures r = (r <> calcFailure u req result, ())         when (isLeft result) $ atomicModifyIORef' ref addFailures-        fn result isChildThread+        fn result isChildThread stats  wrapFetchInTrace   :: Int@@ -612,7 +705,7 @@ scheduleFetches :: [FetchToDo] -> IORef ReqCountMap -> Flags -> IO () scheduleFetches fetches ref flags = do   -- update ReqCountmap for these fetches-  ifReport flags 1 $ sequence_+  ifReport flags ReportOutgoneFetches $ sequence_     [ atomicModifyIORef' ref $         \m -> (addToCountMap (Proxy :: Proxy r) (length reqs) m, ())     | FetchToDo (reqs :: [BlockedFetch r]) _f <- fetches

@@ -4,6 +4,8 @@ -- This source code is distributed under the terms of a BSD license, -- found in the LICENSE file. +{-# LANGUAGE BangPatterns #-}+ -- | -- The 'Flags' type and related functions.  This module is provided -- for access to Haxl internals only; most users should import@@ -11,8 +13,16 @@ -- module Haxl.Core.Flags   (-    -- * Tracing flags-    Flags(..)+    -- * Report flags+    ReportFlag(..)+  , ReportFlags+  , defaultReportFlags+  , profilingReportFlags+  , setReportFlag+  , clearReportFlag+  , testReportFlag+    -- * Flags+  , Flags(..)   , defaultFlags   , ifTrace   , ifReport@@ -20,22 +30,72 @@   ) where  import Control.Monad+import Data.Bits+import Data.List (foldl')+import Text.Printf (printf)  -- ---------------------------------------------------------------------------+-- ReportFlags+data ReportFlag+  = ReportOutgoneFetches  -- ^ outgone fetches, for debugging eg: timeouts+  | ReportFetchStats  -- ^ data fetch stats & errors+  | ReportProfiling   -- ^ enabling label stack and profiling+  | ReportExceptionLabelStack  -- ^ include label stack in HaxlException+  | ReportFetchStack  -- ^ log cost-center stack traces of dataFetch calls+  deriving (Bounded, Enum, Eq, Show)++profilingDependents :: [ReportFlag]+profilingDependents =+  [ ReportExceptionLabelStack+  , ReportFetchStack+  ]++newtype ReportFlags = ReportFlags Int++instance Show ReportFlags where+  show (ReportFlags fs) = printf "%0*b" (fromEnum maxReportFlag + 1) fs+    where+      maxReportFlag = maxBound :: ReportFlag++defaultReportFlags :: ReportFlags+defaultReportFlags = ReportFlags 0++profilingReportFlags :: ReportFlags+profilingReportFlags = foldl' (flip setReportFlag) defaultReportFlags+  [ ReportOutgoneFetches+  , ReportFetchStats+  , ReportProfiling+  ]++setReportFlag :: ReportFlag -> ReportFlags -> ReportFlags+setReportFlag f (ReportFlags fs) =+  ReportFlags $ setDependencies $ setBit fs $ fromEnum f+  where+    setDependencies+      | f `elem` profilingDependents = flip setBit $ fromEnum ReportProfiling+      | otherwise = id++clearReportFlag :: ReportFlag -> ReportFlags -> ReportFlags+clearReportFlag f (ReportFlags fs) =+  ReportFlags $ clearDependents $ clearBit fs $ fromEnum f+  where+    clearDependents z = case f of+      ReportProfiling -> foldl' clearBit z $ map fromEnum profilingDependents+      _ -> z++{-# INLINE testReportFlag #-}+testReportFlag :: ReportFlag -> ReportFlags -> Bool+testReportFlag !f (ReportFlags !fs) = testBit fs $ fromEnum f++-- --------------------------------------------------------------------------- -- Flags  -- | Flags that control the operation of the engine. data Flags = Flags   { trace :: {-# UNPACK #-} !Int     -- ^ Tracing level (0 = quiet, 3 = very verbose).-  , report :: {-# UNPACK #-} !Int-    -- ^ Report level:-    --    * 0 = quiet-    --    * 1 = outgone fetches, for debugging eg: timeouts-    --    * 2 = data fetch stats & errors-    --    * 3 = (same as 2, this used to enable errors)-    --    * 4 = profiling-    --    * 5 = log stack traces of dataFetch calls+  , report :: {-# UNPACK #-} !ReportFlags+    -- ^ Report flags   , caching :: {-# UNPACK #-} !Int     -- ^ Non-zero if caching is enabled.  If caching is disabled, then     -- we still do batching and de-duplication, but do not cache@@ -48,7 +108,7 @@ defaultFlags :: Flags defaultFlags = Flags   { trace = 0-  , report = 0+  , report = defaultReportFlags   , caching = 1   , recording = 0   }@@ -57,9 +117,9 @@ ifTrace :: Monad m => Flags -> Int -> m a -> m () ifTrace flags i = when (trace flags >= i) . void --- | Runs an action if the report level is above the given threshold.-ifReport :: Monad m => Flags -> Int -> m a -> m ()-ifReport flags i = when (report flags >= i) . void+-- | Runs an action if the ReportFlag is set.+ifReport :: Monad m => Flags -> ReportFlag -> m a -> m ()+ifReport flags i = when (testReportFlag i $ report flags) . void  ifProfiling :: Monad m => Flags -> m a -> m ()-ifProfiling flags = when (report flags >= 4) . void+ifProfiling flags = ifReport flags ReportProfiling

@@ -202,7 +202,7 @@   case stored of     -- Memo was not prepared first; throw an exception.     MemoEmpty -> trace_ "MemoEmpty " $-      raise $ CriticalError "Attempting to run empty memo."+      raise env $ CriticalError "Attempting to run empty memo."     -- Memo has been prepared but not run yet     MemoReady cont k -> trace_ "MemoReady" $ do       ivar <- newIVar@@ -220,7 +220,8 @@   -> IVar u w a   -> CallId   -> IO (Result u w a)-execMemoNowProfiled envOuter cont ivar cid = if report (flags envOuter) < 4+execMemoNowProfiled envOuter cont ivar cid =+  if not $ testReportFlag ReportProfiling $ report $ flags envOuter   then execMemoNow envOuter cont ivar   else do     incrementMemoHitCounterFor envOuter cid False

@@ -48,6 +48,7 @@   , flattenWT   , appendWTs   , mbModifyWLRef+  , mapWrites      -- * Cont   , Cont(..)@@ -75,6 +76,8 @@     -- * Env   , Env(..)   , DataCacheItem(..)+  , DataCacheLookup(..)+  , HaxlDataCache   , Caches   , caches   , initEnvWithData@@ -125,7 +128,6 @@ import Control.Applicative (liftA2) import Control.Arrow (left) import Control.Concurrent.STM-import qualified Data.Text as Text import qualified Control.Monad.Catch as Catch import Control.Exception (Exception(..), SomeException, throwIO) #if __GLASGOW_HASKELL__ >= 808@@ -135,12 +137,16 @@ import Control.Monad #endif import qualified Control.Exception as Exception+import Data.Either (rights) import Data.IORef import Data.Int-import Data.Either (rights)+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NonEmpty #if __GLASGOW_HASKELL__ < 804 import Data.Semigroup #endif+import qualified Data.Text as Text+import Data.Typeable import GHC.Exts (IsString(..)) import Text.PrettyPrint hiding ((<>)) import Text.Printf@@ -152,7 +158,6 @@ #ifdef PROFILING import qualified Data.Map as Map import Data.Text (Text)-import Data.Typeable import Foreign.Ptr (Ptr) import GHC.Stack import Haxl.Core.CallGraph@@ -164,12 +169,18 @@ -- | The data we carry around in the Haxl monad.  data DataCacheItem u w a = DataCacheItem (IVar u w a) {-# UNPACK #-} !CallId+type HaxlDataCache u w = DataCache (DataCacheItem u w)+newtype DataCacheLookup w =+  DataCacheLookup+    (forall req a . Typeable (req a)+    => req a+    -> IO (Maybe (ResultVal a w)))  data Env u w = Env-  { dataCache     :: {-# UNPACK #-} !(DataCache (DataCacheItem u w))+  { dataCache     :: {-# UNPACK #-} !(HaxlDataCache u w)       -- ^ cached data fetches -  , memoCache      :: {-# UNPACK #-} !(DataCache (DataCacheItem u w))+  , memoCache      :: {-# UNPACK #-} !(HaxlDataCache u w)       -- ^ memoized computations    , memoKey    :: {-# UNPACK #-} !CallId@@ -233,6 +244,11 @@        -- ^ This is just a specialized version of @writeLogsRef@, where we put        -- logs that user doesn't want memoized. This is a better alternative to        -- doing arbitrary IO from a (memoized) Haxl computation.++  , dataCacheFetchFallback :: !(Maybe (DataCacheLookup w))+       -- ^ Allows you to inject a DataCache lookup just before a dataFetch is+       -- dispatched. This is useful for injecting fetch results in testing.+ #ifdef PROFILING   , callGraphRef ::  Maybe (IORef CallGraph)        -- ^ An edge list representing the current function call graph. The type@@ -245,15 +261,15 @@  data ProfileCurrent = ProfileCurrent   { profCurrentKey ::  {-# UNPACK #-} !ProfileKey-  , profCurrentLabel :: {-# UNPACK #-} !ProfileLabel+  , profLabelStack :: {-# UNPACK #-} !(NonEmpty ProfileLabel)   } -type Caches u w = (DataCache (DataCacheItem u w), DataCache (DataCacheItem u w))+type Caches u w = (HaxlDataCache u w, HaxlDataCache u w)  caches :: Env u w -> Caches u w caches env = (dataCache env, memoCache env) -getMaxCallId :: DataCache (DataCacheItem u w) -> IO (Maybe Int)+getMaxCallId :: HaxlDataCache u w -> IO (Maybe Int) getMaxCallId c = do   callIds  <- rights . concatMap snd <$>               DataCache.readCache c (\(DataCacheItem _ i) -> return i)@@ -288,7 +304,7 @@     , states = states     , statsRef = sref     , statsBatchIdRef = sbref-    , profCurrent = ProfileCurrent 0 "MAIN"+    , profCurrent = ProfileCurrent 0 $ "MAIN" :| []     , callIdRef = ciref     , profRef = pref     , reqStoreRef = rs@@ -297,6 +313,7 @@     , completions = comps     , writeLogsRef = wl     , writeLogsRefNoMemo = wlnm+    , dataCacheFetchFallback = Nothing #ifdef PROFILING     , callGraphRef = Nothing     , currFunction = mainFunction@@ -380,6 +397,12 @@ mbModifyWLRef NilWrites _ = return () mbModifyWLRef !wt ref = modifyIORef' ref (`appendWTs` wt) +mapWriteTree :: (w -> w) -> WriteTree w -> WriteTree w+mapWriteTree _ NilWrites = NilWrites+mapWriteTree f (SomeWrite w) = SomeWrite (f w)+mapWriteTree f (MergeWrites wt1 wt2) =+  MergeWrites (mapWriteTree f wt1) (mapWriteTree f wt2)+ -- ----------------------------------------------------------------------------- -- | The Haxl monad, which does several things: --@@ -514,28 +537,28 @@ #endif  getIVar :: IVar u w a -> GenHaxl u w a-getIVar i@IVar{ivarRef = !ref} = GenHaxl $ \Env{..} -> do+getIVar i@IVar{ivarRef = !ref} = GenHaxl $ \env -> do   e <- readIORef ref   case e of     IVarFull (Ok a _wt) -> return (Done a)-    IVarFull (ThrowHaxl e _wt) -> raiseFromIVar i e+    IVarFull (ThrowHaxl e _wt) -> raiseFromIVar env i e     IVarFull (ThrowIO e) -> throwIO e     IVarEmpty _ -> return (Blocked i (Return i))  -- Just a specialised version of getIVar, for efficiency in <*> getIVarApply :: IVar u w (a -> b) -> a -> GenHaxl u w b-getIVarApply i@IVar{ivarRef = !ref} a = GenHaxl $ \Env{..} -> do+getIVarApply i@IVar{ivarRef = !ref} a = GenHaxl $ \env -> do   e <- readIORef ref   case e of     IVarFull (Ok f _wt) -> return (Done (f a))-    IVarFull (ThrowHaxl e _wt) -> raiseFromIVar i e+    IVarFull (ThrowHaxl e _wt) -> raiseFromIVar env i e     IVarFull (ThrowIO e) -> throwIO e     IVarEmpty _ ->       return (Blocked i (Cont (getIVarApply i a)))  -- Another specialised version of getIVar, for efficiency in cachedComputation getIVarWithWrites :: IVar u w a -> GenHaxl u w a-getIVarWithWrites i@IVar{ivarRef = !ref} = GenHaxl $ \Env{..} -> do+getIVarWithWrites i@IVar{ivarRef = !ref} = GenHaxl $ \env@Env{..} -> do   e <- readIORef ref   case e of     IVarFull (Ok a wt) -> do@@ -543,7 +566,7 @@       return (Done a)     IVarFull (ThrowHaxl e wt) -> do       mbModifyWLRef wt writeLogsRef-      raiseFromIVar i e+      raiseFromIVar env i e     IVarFull (ThrowIO e) -> throwIO e     IVarEmpty _ ->       return (Blocked i (Cont (getIVarWithWrites i)))@@ -586,10 +609,10 @@   | ThrowIO SomeException     -- we get no write logs when an IO exception occurs -done :: ResultVal a w -> IO (Result u w a)-done (Ok a _) = return (Done a)-done (ThrowHaxl e _) = raise e-done (ThrowIO e) = throwIO e+done :: Env u w -> ResultVal a w -> IO (Result u w a)+done _ (Ok a _) = return (Done a)+done env (ThrowHaxl e _) = raise env e+done _ (ThrowIO e) = throwIO e  eitherToResultThrowIO :: Either SomeException a -> ResultVal a w eitherToResultThrowIO (Right a) = Ok a NilWrites@@ -612,7 +635,7 @@ -- the relevant computations. data CompleteReq u w   = forall a . CompleteReq-      (Either SomeException a)+      (ResultVal a w)       !(IVar u w a)  -- IVar because the result is cached       {-# UNPACK #-} !Int64 -- see Note [tracking allocation in child threads] @@ -874,6 +897,36 @@ nextCallId :: Env u w -> IO CallId nextCallId env = atomicModifyIORef' (callIdRef env) $ \x -> (x+1,x+1) +-- | Runs the Haxl computation, transforming the writes within using the+-- provided function.+--+-- Memoization behavior is unchanged, meaning if a memoized computation is run+-- once inside @mapWrites@ and then once without, the writes from the second run+-- will NOT be transformed.+mapWrites :: (w -> w) -> GenHaxl u w a -> GenHaxl u w a+mapWrites f action = GenHaxl $ \curEnv -> do+  wlogs <- newIORef NilWrites+  wlogsNoMemo <- newIORef NilWrites+  let+    !newEnv = curEnv { writeLogsRef = wlogs, writeLogsRefNoMemo = wlogsNoMemo }+  unHaxl (mapWritesImpl curEnv newEnv action) newEnv+  where+    mapWritesImpl oldEnv curEnv (GenHaxl m) = GenHaxl $ \_ -> do+      let+        pushTransformedWrites = do+          wt <- readIORef $ writeLogsRef curEnv+          mbModifyWLRef (mapWriteTree f wt) (writeLogsRef oldEnv)+          wtNoMemo <- readIORef $ writeLogsRefNoMemo curEnv+          mbModifyWLRef (mapWriteTree f wtNoMemo) (writeLogsRefNoMemo oldEnv)++      r <- m curEnv++      case r of+        Done a -> pushTransformedWrites >> return (Done a)+        Throw e -> pushTransformedWrites >> return (Throw e)+        Blocked ivar k -> return+          (Blocked ivar (Cont (mapWritesImpl oldEnv curEnv (toHaxl k))))+ #ifdef PROFILING -- ----------------------------------------------------------------------------- -- CallGraph recording@@ -909,34 +962,42 @@ -- Exceptions  -- | Throw an exception in the Haxl monad-throw :: (Exception e) => e -> GenHaxl u w a-throw e = GenHaxl $ \_env -> raise e+throw :: Exception e => e -> GenHaxl u w a+throw e = GenHaxl $ \env -> raise env e -raise :: (Exception e) => e -> IO (Result u w a)-raise e+raise :: Exception e => Env u w -> e -> IO (Result u w a)+raise env e = raiseImpl env (toException e) #ifdef PROFILING-  | Just (HaxlException Nothing h) <- fromException somex = do-    stk <- currentCallStack-    return (Throw (toException (HaxlException (Just stk) h)))-  | otherwise+  currentCallStack #endif-    = return (Throw somex)-  where-    somex = toException e -raiseFromIVar :: Exception e => IVar u w a -> e -> IO (Result u w b)++raiseFromIVar :: Exception e => Env u w -> IVar u w a -> e -> IO (Result u w b) #ifdef PROFILING-raiseFromIVar ivar e-  | Just (HaxlException Nothing h) <- fromException somex = do-    stk <- ccsToStrings (ivarCCS ivar)-    return (Throw (toException (HaxlException (Just stk) h)))-  | otherwise+raiseFromIVar env IVar{..} e =+  raiseImpl env (toException e) (ccsToStrings ivarCCS) #else-raiseFromIVar _ivar e+raiseFromIVar env _ivar e = raiseImpl env (toException e) #endif-    = return (Throw somex)-  where-    somex = toException e++{-# INLINE raiseImpl #-}+#ifdef PROFILING+raiseImpl :: Env u w -> SomeException -> IO [String] -> IO (Result u w b)+raiseImpl Env{..} e getCostCentreStack+#else+raiseImpl :: Env u w -> SomeException -> IO (Result u w b)+raiseImpl Env{..} e+#endif+  | testReportFlag ReportExceptionLabelStack $ report flags+  , Just (HaxlException Nothing h) <- fromException e = do+    let stk = NonEmpty.toList $ profLabelStack profCurrent+    return $ Throw $ toException $ HaxlException (Just stk) h+#ifdef PROFILING+  | Just (HaxlException Nothing h) <- fromException e = do+    stk <- reverse . map Text.pack <$> getCostCentreStack+    return $ Throw $ toException $ HaxlException (Just stk) h+#endif+  | otherwise = return $ Throw e  -- | Catch an exception in the Haxl monad catch :: Exception e => GenHaxl u w a -> (e -> GenHaxl u w a) -> GenHaxl u w a

@@ -47,7 +47,7 @@              -> GenHaxl u w r              -> GenHaxl u w t biselect_opt discrimA discrimB left right haxla haxlb =-  let go (GenHaxl haxla) (GenHaxl haxlb) = GenHaxl $ \env@Env{..} -> do+  let go (GenHaxl haxla) (GenHaxl haxlb) = GenHaxl $ \env -> do         ra <- haxla env         case ra of           Done ea ->

@@ -4,6 +4,7 @@ -- This source code is distributed under the terms of a BSD license, -- found in the LICENSE file. +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-}@@ -25,6 +26,7 @@  import Data.IORef import Data.Hashable+import Data.List.NonEmpty (NonEmpty(..), (<|)) #if __GLASGOW_HASKELL__ < 804 import Data.Monoid #endif@@ -43,7 +45,7 @@ -- | Label a computation so profiling data is attributed to the label. withLabel :: ProfileLabel -> GenHaxl u w a -> GenHaxl u w a withLabel l (GenHaxl m) = GenHaxl $ \env ->-  if report (flags env) < 4+  if not $ testReportFlag ReportProfiling $ report $ flags env      then m env      else collectProfileData l m env @@ -51,7 +53,7 @@ -- Intended only for internal use by 'memoFingerprint'. withFingerprintLabel :: Addr# -> Addr# -> GenHaxl u w a -> GenHaxl u w a withFingerprintLabel mnPtr nPtr (GenHaxl m) = GenHaxl $ \env ->-  if report (flags env) < 4+  if not $ testReportFlag ReportProfiling $ report $ flags env      then m env      else collectProfileData             (Text.unpackCString# mnPtr <> "." <> Text.unpackCString# nPtr)@@ -64,7 +66,7 @@   -> Env u w   -> IO (Result u w a) collectProfileData l m env = do-  let (ProfileCurrent prevProfKey prevProfLabel) = profCurrent env+  let ProfileCurrent prevProfKey (prevProfLabel :| _) = profCurrent env   if prevProfLabel == l   then     -- do not add a new label if we are recursing@@ -93,12 +95,22 @@   t0 <- getTimestamp   a0 <- getAllocationCounter   let+    ProfileCurrent caller stack = profCurrent env     nextCurrent = ProfileCurrent-                  { profCurrentKey = key-                  , profCurrentLabel = l }-    caller = profCurrentKey (profCurrent env)+      { profCurrentKey = key+      , profLabelStack = l <| stack+      }+    runCont (GenHaxl h) = GenHaxl $ runProfileData l key h True    r <- m env{profCurrent=nextCurrent} -- what if it throws?++  -- Make the result strict in Done/Throw so that if the user code+  -- returns (force a), the force is evaluated *inside* the profile.+  result <- case r of+    Done !a -> return (Done a)+    Throw !e -> return (Throw e)+    Blocked ivar k -> return (Blocked ivar (Cont $ runCont (toHaxl k)))+   a1 <- getAllocationCounter   t1 <- getTimestamp @@ -111,12 +123,7 @@    -- So we do not count the allocation overhead of modifyProfileData   setAllocationCounter a1-  case r of-    Done a -> return (Done a)-    Throw e -> return (Throw e)-    Blocked ivar k -> return (Blocked ivar (Cont $ runCont (toHaxl k)))-  where-    runCont (GenHaxl h) = GenHaxl $ runProfileData l key h True+  return result {-# INLINE runProfileData #-}  modifyProfileData@@ -180,7 +187,7 @@   t1 <- getTimestamp   let     allocs = a0 - a1-    t = t0 - t1+    t = t1 - t0     newEntry = emptyProfileData       { profileAllocs = allocs       , profileTime = t

@@ -44,6 +44,7 @@ import qualified Data.Map.Strict as Map import Data.Proxy import Data.Text (Text)+import Data.Kind (Type) import Data.Typeable import Unsafe.Coerce @@ -110,7 +111,7 @@ emptyReqCounts = ReqCountMap Map.empty  addToCountMap-  :: forall (r :: * -> *). (DataSourceName r, Typeable r)+  :: forall (r :: Type -> Type). (DataSourceName r, Typeable r)   => Proxy r   -> Int -- type and number of requests   -> ReqCountMap@@ -118,7 +119,7 @@ addToCountMap = updateCountMap (+)  subFromCountMap-  :: forall (r :: * -> *). (DataSourceName r, Typeable r)+  :: forall (r :: Type -> Type). (DataSourceName r, Typeable r)   => Proxy r   -> Int -- type and number of requests   -> ReqCountMap@@ -126,7 +127,7 @@ subFromCountMap = updateCountMap (-)  updateCountMap-  :: forall (r :: * -> *). (DataSourceName r, Typeable r)+  :: forall (r :: Type -> Type). (DataSourceName r, Typeable r)   => (Int -> Int -> Int)   -> Proxy r   -> Int -- type and number of requests

@@ -96,7 +96,7 @@                        _ -> modifyIORef' runQueueRef (appendJobList rq)                    else reschedule env (appendJobList haxls rq)       r <--        if report flags >= 4          -- withLabel unfolded+        if testReportFlag ReportProfiling $ report flags  -- withLabel unfolded           then Exception.try $ profileCont run env           else Exception.try $ run env       case r of@@ -142,7 +142,7 @@           schedule env' c a b      emptyRunQueue :: Env u w -> IO ()-    emptyRunQueue env@Env{..} = do+    emptyRunQueue env = do       ifTraceLog $ printf "emptyRunQueue\n"       haxls <- checkCompletions env       case haxls of@@ -195,7 +195,7 @@                     -- pushed on the front of the completions list) and                     -- therefore overrides it.                   IVarEmpty cv -> do-                    writeIORef cr (IVarFull (eitherToResult a))+                    writeIORef cr (IVarFull a)                     return cv           jobs <- mapM getComplete comps           return (foldr appendJobList JobNil jobs)@@ -229,7 +229,7 @@                         , fetchWaitDuration = (end-start)                         }               modifyIORef' statsRef $ \(Stats s) -> Stats (fw:s)-      if report flags >= 2+      if testReportFlag ReportFetchStats $ report flags         then doWaitProfiled         else doWait       emptyRunQueue env@@ -237,10 +237,12 @@   --   schedule env JobNil haxl result   r <- readIORef resultRef+  writeIORef writeLogsRef NilWrites+  wtNoMemo <- atomicModifyIORef' writeLogsRefNoMemo+    (\old_wrts -> (NilWrites , old_wrts))   case r of     IVarEmpty _ -> throwIO (CriticalError "runHaxl: missing result")     IVarFull (Ok a wt) -> do-      wtNoMemo <- readIORef writeLogsRefNoMemo       return (a, flattenWT (wt `appendWTs` wtNoMemo))     IVarFull (ThrowHaxl e _wt)  -> throwIO e       -- The written logs are discarded when there's a Haxl exception. We

@@ -23,6 +23,7 @@   ) where  import Data.Map (Map)+import Data.Kind (Type) import qualified Data.Map.Strict as Map #if __GLASGOW_HASKELL__ < 804 import Data.Monoid@@ -34,7 +35,7 @@ -- instance of 'StateKey' can store and retrieve information from a -- 'StateStore'. ---class Typeable f => StateKey (f :: * -> *) where+class Typeable f => StateKey (f :: Type -> Type) where   data State f    -- | We default this to typeOf1, but if f is itself a complex type that is

@@ -6,6 +6,7 @@  {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE CPP #-}@@ -23,6 +24,7 @@   , FetchStats(..)   , Microseconds   , Timestamp+  , DataSourceStats(..)   , getTimestamp   , emptyStats   , numFetches@@ -59,6 +61,7 @@ import Data.Ord (Down(..)) import Data.Text (Text) import Data.Time.Clock.POSIX+import Data.Typeable import Text.Printf import qualified Data.HashMap.Strict as HashMap import qualified Data.Text as Text@@ -79,6 +82,16 @@ -- --------------------------------------------------------------------------- -- Stats +data DataSourceStats =+  forall a. (Typeable a, Show a, Eq a, ToJSON a) => DataSourceStats a++instance Show DataSourceStats where+  show (DataSourceStats x) = printf "DataSourceStats %s" (show x)++instance Eq DataSourceStats where+  (==) (DataSourceStats a) (DataSourceStats b) =+    cast a == Just b+ -- | Stats that we collect along the way. newtype Stats = Stats [FetchStats]   deriving (Show, ToJSON, Semigroup, Monoid)@@ -101,6 +114,7 @@   where     isFetchStats FetchStats{} = True     isFetchStats FetchWait{} = True+    isFetchStats FetchDataSourceStats{} = True     isFetchStats _ = False     validFetchStats = filter isFetchStats (reverse rss)     numDashes = 50@@ -159,6 +173,12 @@     , fetchWaitStart :: {-# UNPACK #-} !Timestamp     , fetchWaitDuration :: {-# UNPACK #-} !Microseconds     }+  | FetchDataSourceStats+    { fetchDsStatsCallId :: CallId+    , fetchDsStatsDataSource :: Text+    , fetchDsStatsStats :: DataSourceStats+    , fetchBatchId :: {-# UNPACK #-} !Int+    }   deriving (Eq, Show)  -- | Pretty-print RoundStats.@@ -183,6 +203,9 @@     msg x = printf "%s (%.2fms)"                 x                 (fromIntegral fetchWaitDuration / 1000 :: Double)+ppFetchStats FetchDataSourceStats{..} =+  printf "%s (stats): %s" (Text.unpack fetchDsStatsDataSource)+    (show fetchDsStatsStats)  -- | Aggregate stats merging FetchStats from the same dispatched batch into one. aggregateFetchBatches :: ([FetchStats] -> a) -> Stats -> [a]@@ -220,6 +243,14 @@     [ "type" .= ("FetchWait" :: Text)     , "duration" .= fetchWaitDuration     ]+  toJSON FetchDataSourceStats{..} = object+    [ "type" .= ("FetchDataSourceStats" :: Text)+    , "datasource" .= fetchDsStatsDataSource+    , "stats" .= sjson fetchDsStatsStats+    , "batchid" .= fetchBatchId+    ]+    where+      sjson (DataSourceStats s) = toJSON s  emptyStats :: Stats emptyStats = Stats []

@@ -1,6 +1,10 @@-# Changes in version <next>+# Changes in version 2.4.0.0   * Added fetchBatchId to FetchStats   * Profiling now tracks full stacks and links each label to memos/fetches+  * Adds FetchDataSourceStats used to log stats/profiling data returned+    from datasources. This is stored in statsRef like any other Stats.+  * Report flag was changed from sequential numbers to bitmask.+  * Add ReportExceptionLabelStack flag to include label stack in HaxlException.  # Changes in version 2.3.0.0   * Removed `FutureFetch`

@@ -1,5 +1,5 @@ name:                haxl-version:             2.3.0.0+version:             2.4.0.0 synopsis:            A Haskell library for efficient, concurrent,                      and concise data access. homepage:            https://github.com/facebook/Haxl@@ -43,7 +43,7 @@ library    build-depends:-    aeson >= 0.6 && < 1.6,+    aeson >= 0.6 && < 2.1,     base >= 4.10 && < 5,     binary >= 0.7 && < 0.10,     bytestring >= 0.9 && < 0.11,@@ -132,6 +132,7 @@     CoreTests     DataCacheTest     ExampleDataSource+    ExceptionStackTests     FullyAsyncTest     LoadCache     MemoizationTests@@ -148,6 +149,7 @@     TestUtils     WorkDataSource     WriteTests+    DataSourceDispatchTests    type:     exitcode-stdio-1.0

@@ -1,8 +1,8 @@-![Haxl Logo](https://github.com/facebook/Haxl/raw/master/logo.png)+![Haxl Logo](https://raw.githubusercontent.com/facebook/Haxl/main/logo.png)  # Haxl -[![Build Status](https://travis-ci.org/facebook/Haxl.svg?branch=master)](https://travis-ci.org/facebook/Haxl)+[![Support Ukraine](https://img.shields.io/badge/Support-Ukraine-FFD500?style=flat&labelColor=005BBB)](https://opensource.fb.com/support-ukraine) [![Build Status](https://travis-ci.org/facebook/Haxl.svg?branch=master)](https://travis-ci.org/facebook/Haxl)  Haxl is a Haskell library that simplifies access to remote data, such as databases or web-based services. Haxl can automatically

@@ -11,6 +11,7 @@ import BatchTests import CoreTests import DataCacheTest+import ExceptionStackTests import AdoTests import OutgoneFetchesTests import ProfileTests@@ -21,6 +22,7 @@ import WriteTests import ParallelTests import StatsTests+import DataSourceDispatchTests  import Test.HUnit @@ -31,6 +33,7 @@   , TestLabel "BatchTests-sync" $ BatchTests.tests False   , TestLabel "CoreTests" CoreTests.tests   , TestLabel "DataCacheTests" DataCacheTest.tests+  , TestLabel "ExceptionStackTests" ExceptionStackTests.tests   , TestLabel "AdoTests" $ AdoTests.tests False   , TestLabel "OutgoneFetchesTest" OutgoneFetchesTests.tests   , TestLabel "ProfileTests" ProfileTests.tests@@ -41,4 +44,5 @@   , TestLabel "WriteTest" WriteTests.tests   , TestLabel "ParallelTest" ParallelTests.tests   , TestLabel "StatsTests" StatsTests.tests+  , TestLabel "DataSourceDispatchTests" DataSourceDispatchTests.tests   ]

@@ -5,6 +5,10 @@ -- found in the LICENSE file.  {-# LANGUAGE StandaloneDeriving, GADTs, DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-} module DataCacheTest (tests, newResult, takeResult) where  import Haxl.Core.DataCache as DataCache@@ -12,12 +16,15 @@ import Haxl.Core  import Control.Exception+import Data.Either import Data.Hashable import Data.Traversable import Data.Typeable import Prelude hiding (mapM) import Test.HUnit import Data.IORef+import Data.Text+import Unsafe.Coerce  data TestReq a where    Req :: Int -> TestReq a -- polymorphic result@@ -29,11 +36,30 @@ instance Hashable (TestReq a) where   hashWithSalt salt (Req i) = hashWithSalt salt i +instance DataSource u TestReq where+  fetch = error "no fetch defined"++instance DataSourceName TestReq where+  dataSourceName _ = pack "TestReq"++instance StateKey TestReq where+  data State TestReq = TestReqState++instance ShowP TestReq where showp = show++data CacheableReq x where CacheableInt :: Int -> CacheableReq Int+  deriving Typeable+deriving instance Eq (CacheableReq x)+deriving instance Show (CacheableReq x)+instance Hashable (CacheableReq x) where+  hashWithSalt s (CacheableInt val) = hashWithSalt s (0::Int, val)++ newResult :: a -> IO (IVar u w a)-newResult a = IVar <$> newIORef (IVarFull (Ok a NilWrites))+newResult a = newFullIVar (Ok a NilWrites)  takeResult :: IVar u w a -> IO (ResultVal a w)-takeResult (IVar ref) = do+takeResult IVar{ivarRef = ref} = do   e <- readIORef ref   case e of     IVarFull a -> return a@@ -85,5 +111,90 @@       Left (ErrorCall "BOOM") -> True       _other -> False +dcFallbackTest :: Test+dcFallbackTest = TestLabel "DataCache fallback" $ TestList+  [ TestLabel "Base" $ TestCase $ do+      env <- mkEnv+      (r,cached) <- runHaxl env (do+                           a <- dataFetch req+                           b <- cacheResult (CacheableInt 1234) (return 99999)+                           return (a,b))+      (Stats stats) <- readIORef (statsRef env)+      assertEqual "fallback still has stats" 1+        (Prelude.length [x | x@FetchStats{} <- stats])+      assertEqual "dcFallbackTest found" 1 r+      assertEqual "dcFallbackTest cached" 1234 cached+  , TestLabel "Exception" $ TestCase $ do+      env <- mkEnv+      rbad <- Control.Exception.try $ runHaxl env (dataFetch reqBad)+      assertBool "dcFallbackTest not found" $+        case rbad of+          Left (ErrorCall "no fetch defined") -> True+          _ -> False+  , TestLabel "Completions" $ TestCase $ do+      -- check applicative still runs as it would have without a fallback+      env <- mkEnv+      let+        fetchA = dataFetch reqEx+        fetchB = tellWrite 7 >> dataFetch req+      (rbad, writes) <- runHaxlWithWrites env $+        Haxl.Core.try $ (,) <$> fetchA <*> fetchB+      fetches <- countFetches env+      assertEqual "dispatched 2 fetches" 2 fetches+      assertBool "exception propogates" $+        case rbad of+          Left (NotFound _) -> True+          _ -> False+      assertEqual "write side effects happen" [7] writes+  ]+  where++    mkEnv = addLookup <$> initEnv (stateSet TestReqState stateEmpty) ()++    countFetches env = do+      (Stats stats) <- readIORef (statsRef env)+      let+        c = sum [ fetchBatchSize x+                | x@FetchStats{} <- stats+                ]+      return c++    addLookup :: Env () Int -> Env () Int+    addLookup e = e { dataCacheFetchFallback = Just (DataCacheLookup lookup)+                    , flags = (flags e) { report = profilingReportFlags }+                    }+    lookup+      :: forall req a . Typeable (req a)+      => req a+      -> IO (Maybe (ResultVal a Int))+    lookup r+      | typeOf r == typeRep (Proxy :: Proxy (TestReq Int)) =+        -- have to coerce on the way out as results are not Typeable+        -- so you better be sure you do it right!+        return $ unsafeCoerce . doReq <$> cast r+      | typeOf r == typeRep (Proxy :: Proxy (CacheableReq Int)) =+          return $ unsafeCoerce . doCache <$> cast r+      | otherwise = return Nothing++    doReq :: TestReq Int -> ResultVal Int Int+    doReq (Req 999) = ThrowHaxl (toException $ NotFound empty) NilWrites+    doReq (Req r) = Ok r NilWrites++    doCache :: CacheableReq Int -> ResultVal Int Int+    doCache (CacheableInt i) = Ok i NilWrites++    req :: TestReq Int+    req = Req 1++    reqEx :: TestReq Int+    reqEx = Req 999++    reqBad :: TestReq String+    reqBad = Req 2++ -- tests :: Assertion-tests = TestList [dcSoundnessTest, dcStrictnessTest]+tests = TestList [ dcSoundnessTest+                 , dcStrictnessTest+                 , dcFallbackTest+                 ]

@@ -0,0 +1,81 @@+-- Copyright (c) 2014-present, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file.++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ApplicativeDo #-}++module DataSourceDispatchTests (tests) where+import Test.HUnit hiding (State)+import Control.Monad+import Haxl.Core+import Data.Hashable++data DataSourceDispatch ty where+    GetBatchSize :: Int -> DataSourceDispatch Int++deriving instance Eq (DataSourceDispatch ty)+deriving instance Show (DataSourceDispatch ty)++instance DataSourceName DataSourceDispatch where+    dataSourceName _ = "DataSourceDispatch"++instance StateKey DataSourceDispatch where+    data State DataSourceDispatch = DataSourceDispatchState++instance ShowP DataSourceDispatch where showp = show++instance Hashable (DataSourceDispatch a) where+  hashWithSalt s (GetBatchSize n) = hashWithSalt s n++initDataSource :: IO (State DataSourceDispatch)+initDataSource = return DataSourceDispatchState++instance DataSource UserEnv DataSourceDispatch where+    fetch _state _flags _u = SyncFetch $ \bfs -> forM_ bfs (fill $ length bfs)+      where+      fill :: Int -> BlockedFetch DataSourceDispatch -> IO ()+      fill l (BlockedFetch (GetBatchSize _ ) rv) = putResult rv (Right l)++    schedulerHint Batching = TryToBatch+    schedulerHint NoBatching = SubmitImmediately++data UserEnv = Batching | NoBatching deriving (Eq)++makeTestEnv :: UserEnv -> IO (Env UserEnv ())+makeTestEnv testUsrEnv = do+  st <- initDataSource+  e <- initEnv (stateSet st stateEmpty) testUsrEnv+  return e { flags = (flags e) {+    report = setReportFlag ReportFetchStats defaultReportFlags } }++schedulerTest:: Test+schedulerTest = TestCase $ do+    let+        fet = do+          x <- dataFetch (GetBatchSize 0)+          y <- dataFetch (GetBatchSize 1)+          return [x,y]++    e <- makeTestEnv Batching+    r1 :: [Int] <- runHaxl e fet+    assertEqual "Failed to create batches for data fetch" [2,2] r1++    eNoBatching <- makeTestEnv NoBatching+    r2 :: [Int] <- runHaxl eNoBatching fet+    assertEqual "Unexpexted batches in SubmitImmediately" [1,1] r2++    return ()++tests :: Test+tests = TestList+  [ TestLabel "schedulerTest" schedulerTest+  ]

@@ -0,0 +1,71 @@+-- Copyright (c) 2014-present, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file.++{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++module ExceptionStackTests (tests) where++import Prelude ()+import Haxl.Core+import Haxl.Prelude++import Test.HUnit++import qualified ExampleDataSource++testEnv :: ReportFlags -> IO (Env () ())+testEnv report = do+  exstate <- ExampleDataSource.initGlobalState+  let st = stateSet exstate stateEmpty+  env <- initEnv st ()+  return env{ flags = (flags env){ report = report } }++reportFlags :: ReportFlags+reportFlags = setReportFlag ReportExceptionLabelStack defaultReportFlags++runHaxlTest+  :: ReportFlags+  -> String+  -> (Int -> Int -> GenHaxl () () Int)+  -> IO (Maybe [Text])+runHaxlTest report str func = do+  env <- testEnv report+  result <- runHaxl env $+    withLabel "try" $ tryToHaxlException $ withLabel "test" $ do+      x <- withLabel "dummy" $ pure 1+      y <- withLabel "fetch" $ ExampleDataSource.countAardvarks str+      withLabel "func" $ func x y+  case result of+    Left (HaxlException stk _) -> return stk+    Right{} -> assertFailure "expected: HaxlException"++fetchException :: Test+fetchException = TestCase $ do+  result <- runHaxlTest reportFlags "BANG4" $ \i j -> return $ i + j+  assertEqual "stack" (Just ["fetch", "test", "try", "MAIN"]) result++userException :: Test+userException = TestCase $ do+  result <- runHaxlTest reportFlags "aaa" $ \_ _ -> withLabel "throw" $+    throw $ InvalidParameter "throw"+  assertEqual "stack" (Just ["throw", "func", "test", "try", "MAIN"]) result++#ifndef PROFILING+disabledExceptionStack :: Test+disabledExceptionStack = TestCase $ do+  result <- runHaxlTest defaultReportFlags "BANG4" $ \i j -> return $ i + j+  assertEqual "stack" Nothing result+#endif++tests :: Test+tests = TestList+  [ TestLabel "FetchException" fetchException+  , TestLabel "UserException" userException+#ifndef PROFILING+  , TestLabel "DisabledExceptionStack"  disabledExceptionStack+#endif+  ]

@@ -23,7 +23,8 @@ testEnv = do   st <- mkConcurrentIOState   env <- initEnv (stateSet st stateEmpty) ()-  return env { flags = (flags env) { report = 2 } }+  return env { flags = (flags env) {+    report = setReportFlag ReportFetchStats defaultReportFlags } }  sleepTest :: Test sleepTest = TestCase $ do

@@ -21,8 +21,6 @@ import Haxl.Prelude as Haxl import Prelude() -import Haxl.Core.Memo (newMemoWith, runMemo)- import Haxl.Core import Haxl.Core.Util @@ -30,7 +28,7 @@  newtype SimpleWrite = SimpleWrite Text deriving (Eq, Show) -testEnv :: Int -> IO (Env () SimpleWrite)+testEnv :: ReportFlags -> IO (Env () SimpleWrite) testEnv report = do   exstate <- ExampleDataSource.initGlobalState   let st = stateSet exstate stateEmpty@@ -112,7 +110,7 @@ data Options = Options   { test :: String   , nOverride :: Maybe Int-  , reportFlag :: Int+  , reportFlag :: ReportFlags   }  runTest :: Options -> Test -> IO ()@@ -128,9 +126,14 @@ optionsParser :: Parser Options optionsParser = do   test <- argument str (metavar "TEST")-  reportFlag <- option auto (long "report" <> value 0 <> metavar "REPORT")+  reportFlag <- reportFlagParser   nOverride <- optional $ argument auto (metavar "NUM")   return Options{..}+  where+    reportFlagParser = foldl' (flip ($)) defaultReportFlags <$> sequenceA+      [ flag id (setReportFlag i) $ long $ show i+      | i <- enumFrom minBound+      ]  main :: IO () main = do

@@ -13,11 +13,9 @@  import Haxl.Core import Haxl.DataSource.ConcurrentIO-import Haxl.Core.RequestStore (getMapFromRCMap)  import Data.IORef import qualified Data.Map as Map-import Data.Proxy (Proxy(..)) import Data.Typeable import Test.HUnit import System.Timeout@@ -31,7 +29,8 @@   sleepState <- mkConcurrentIOState   let st = stateSet exstate $ stateSet sleepState stateEmpty   e <- initEnv st ()-  return e { flags = (flags e) {report = 1} }+  return e { flags = (flags e) {+    report = setReportFlag ReportOutgoneFetches defaultReportFlags } }     -- report=1 to enable fetches tracking  -- A cheap haxl computation we interleave b/w the @sleep@ fetches.

@@ -7,6 +7,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE CPP #-}  module ProfileTests where @@ -23,6 +24,11 @@ import Data.Aeson import Data.IORef import qualified Data.HashMap.Strict as HashMap+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as KeyMap+#else+import qualified Data.HashMap.Strict as KeyMap+#endif import Data.Int  import TestUtils@@ -31,7 +37,7 @@  mkProfilingEnv = do   env <- makeTestEnv False-  return env { flags = (flags env) { report = 4 } }+  return env { flags = (flags env) { report = profilingReportFlags } }  -- expects only one label to be shown labelToDataMap :: Profile -> HashMap.HashMap ProfileLabel ProfileData@@ -53,7 +59,7 @@               slp <- sum <$> mapM (\x -> withLabel "baz" $ return x) [1..5]               -- do some non-trivial work that can't be lifted out               -- first sleep though in order to force a Blocked result-              sleep slp `andThen` case fromJSON <$> HashMap.lookup "A" u of+              sleep slp `andThen` case fromJSON <$> KeyMap.lookup "A" u of                 Just (Success n) | sum [n .. 1000::Integer] > 0 -> return 5                 _otherwise -> return (4::Int)   profCopy <- readIORef (profRef e)@@ -87,6 +93,24 @@   assertEqual "foo's parent is bar" (Just (head fooParents)) $     HashMap.lookup ("bar", 0) (profileTree profCopy) ++collectsLazyData :: Assertion+collectsLazyData = do+  e <- mkProfilingEnv+  _x <- runHaxl e $ withLabel "bar" $ do+          u <- env userEnv+          withLabel "foo" $ do+             let start = if KeyMap.member "A" u+                         then 10+                         else 1+             return $ sum [start..10000::Integer]+  profCopy <- readIORef (profRef e)+  -- check the allocations are attributed to foo+  assertBool "foo has allocations" $+    case profileAllocs <$> HashMap.lookup "foo" (labelToDataMap profCopy) of+      Just x -> x > 10000+      Nothing -> False+ exceptions :: Assertion exceptions = do   env <- mkProfilingEnv@@ -114,7 +138,8 @@ threadAlloc :: Integer -> Assertion threadAlloc batches = do   env' <- initEnv (stateSet mkWorkState stateEmpty) ()-  let env = env'  { flags = (flags env') { report = 2 } }+  let env = env'  { flags = (flags env') {+    report = setReportFlag ReportFetchStats defaultReportFlags } }   a0 <- getAllocationCounter   let     wsize = 100000@@ -180,6 +205,7 @@  tests = TestList   [ TestLabel "collectsdata" $ TestCase collectsdata+  , TestLabel "collectsdata - lazy" $ TestCase collectsLazyData   , TestLabel "exceptions" $ TestCase exceptions   , TestLabel "threads" $ TestCase (threadAlloc 1)   , TestLabel "threads with batch" $ TestCase (threadAlloc 50)

@@ -77,7 +77,8 @@    -- Create the Env:   env <- initEnv st ()-  return env{ flags = (flags env){ report = 5 } }+  return env{ flags = (flags env){+    report = setReportFlag ReportFetchStack profilingReportFlags } }   fetchIdsSync :: Test

@@ -33,7 +33,8 @@    -- Create the Env:   env <- initEnv st ()-  return env{ flags = (flags env){ report = 2 } }+  return env{ flags = (flags env){+    report = setReportFlag ReportFetchStats defaultReportFlags } }   tests = TestList [

@@ -7,6 +7,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP #-}  module TestTypes    ( UserEnv@@ -18,29 +19,40 @@  import Data.Aeson import Data.Binary (Binary)-import Data.Text (Text) import qualified Data.Text as Text-import qualified Data.HashMap.Strict as HashMap+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as KeyMap+import Data.Aeson.Key (toText)+#else+import qualified Data.HashMap.Strict as KeyMap+#endif import Data.Hashable import Data.Typeable  import Haxl.Core +#if !MIN_VERSION_aeson(2,0,0)+type Key = Text.Text++toText :: Key -> Text.Text+toText = id+#endif+ type UserEnv = Object type Haxl a = GenHaxl UserEnv () a type HaxlEnv = Env UserEnv () -lookupInput :: FromJSON a => Text -> Haxl a+lookupInput :: FromJSON a => Key -> Haxl a lookupInput field = do-  mb_val <- env (HashMap.lookup field . userEnv)+  mb_val <- env (KeyMap.lookup field . userEnv)   case mb_val of     Nothing ->-      throw (NotFound (Text.concat ["field ", field, " was not found."]))+      throw (NotFound (Text.concat ["field ", toText field, " was not found."]))     Just val ->       case fromJSON val of         Error str ->           throw (UnexpectedType (Text.concat-            ["field ", field, ": ", Text.pack str]))+            ["field ", toText field, ": ", Text.pack str]))         Success a -> return a  

@@ -5,6 +5,7 @@ -- found in the LICENSE file.  {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-} module TestUtils   ( makeTestEnv   , expectResultWithEnv@@ -21,7 +22,11 @@ import Data.IORef import Data.Aeson import Test.HUnit-import qualified Data.HashMap.Strict as HashMap+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as KeyMap+#else+import qualified Data.HashMap.Strict as KeyMap+#endif  import Haxl.Core @@ -29,7 +34,7 @@ import Haxl.Prelude  testinput :: Object-testinput = HashMap.fromList [+testinput = KeyMap.fromList [   "A" .= (1 :: Int),   "B" .= (2 :: Int),   "C" .= (3 :: Int),@@ -53,7 +58,8 @@   stio <- mkConcurrentIOState   let st = stateSet stio $ stateSet tao stateEmpty   env <- initEnv st testinput-  return env { flags = (flags env) { report = 2 } }+  return env { flags = (flags env) {+    report = setReportFlag ReportFetchStats defaultReportFlags } }  expectResultWithEnv   :: (Eq a, Show a) => a -> Haxl a -> HaxlEnv -> Assertion

@@ -4,19 +4,60 @@ -- This source code is distributed under the terms of a BSD license, -- found in the LICENSE file. +{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-} module WriteTests (tests) where  import Test.HUnit +import Control.Concurrent+import Data.Either import Data.Foldable+import Data.Hashable+import Data.IORef+import qualified Data.Text as Text +import Haxl.Core.Monad (mapWrites, flattenWT) import Haxl.Core import Haxl.Prelude as Haxl +-- A fake data source+data SimpleDataSource a where+  GetNumber :: SimpleDataSource Int++deriving instance Eq (SimpleDataSource a)+deriving instance Show (SimpleDataSource a)+instance ShowP SimpleDataSource where showp = show++instance Hashable (SimpleDataSource a) where+  hashWithSalt s GetNumber = hashWithSalt s (0 :: Int)++instance StateKey SimpleDataSource where+  data State SimpleDataSource = DSState++instance DataSourceName SimpleDataSource where+  dataSourceName _ = "SimpleDataSource"++instance DataSource u SimpleDataSource where+  fetch _st _flags _usr  = SyncFetch $ Haxl.mapM_ fetch1+    where+    fetch1 :: BlockedFetch SimpleDataSource -> IO ()+    fetch1 (BlockedFetch GetNumber m) =+      threadDelay 1000 >> putSuccess m 37+ newtype SimpleWrite = SimpleWrite Text-  deriving (Eq, Show)+  deriving (Eq, Show, Ord) +assertEqualIgnoreOrder ::+  (Eq a, Show a, Ord a) => String -> [a] -> [a] -> Assertion+assertEqualIgnoreOrder msg lhs rhs =+  assertEqual msg (sort lhs) (sort rhs)+ doInnerWrite :: GenHaxl u SimpleWrite Int doInnerWrite = do   tellWrite $ SimpleWrite "inner"@@ -124,6 +165,129 @@       [SimpleWrite "inner not memo"]   assertBool "Write Soundness 12" $ memoRes == replicate numReps 0 +writeLogsCorrectnessTest :: Test+writeLogsCorrectnessTest = TestLabel "writeLogs_correctness" $ TestCase $ do+  e <- emptyEnv ()+  (_ , wrts) <- runHaxlWithWrites e doNonMemoWrites+  assertEqualIgnoreOrder "Expected writes" [SimpleWrite "inner",+    SimpleWrite "inner not memo"] wrts+  wrtsNoMemo <- readIORef $ writeLogsRefNoMemo e+  wrtsMemo <- readIORef $ writeLogsRef e+  assertEqualIgnoreOrder "WriteTree not empty" [] $ flattenWT wrtsNoMemo+  assertEqualIgnoreOrder "WriteTree not empty" [] $ flattenWT wrtsMemo +mapWritesTest :: Test+mapWritesTest = TestLabel "mapWrites" $ TestCase $ do+  let func (SimpleWrite s) = SimpleWrite $ Text.toUpper s+  env0 <- emptyEnv ()+  (res0, wrts0) <- runHaxlWithWrites env0 $ mapWrites func doNonMemoWrites+  assertEqual "Expected computation result" 0 res0+  assertEqualIgnoreOrder "Writes correctly transformed" [SimpleWrite "INNER",+    SimpleWrite "INNER NOT MEMO"] wrts0 -tests = TestList [TestLabel "Write Soundness" writeSoundness]+  -- Writes should behave the same inside and outside mapWrites+  env1 <- emptyEnv ()+  (res1, wrts1) <- runHaxlWithWrites env1 $ do+    outer <- doOuterWrite+    outerMapped <- mapWrites func doOuterWrite+    return $ outer == outerMapped+  assertBool "Results are identical" res1+  assertEqualIgnoreOrder+    "Writes correctly transformed, non-transformed writes preserved"+    [ SimpleWrite "outer1", SimpleWrite "inner"+    , SimpleWrite "inner", SimpleWrite "outer2"+    , SimpleWrite "OUTER1", SimpleWrite "INNER"+    , SimpleWrite "INNER", SimpleWrite "OUTER2"+    ]+    wrts1++  -- Memoization behaviour should be unaffected+  env2 <- emptyEnv ()+  (_res2, wrts2) <- runHaxlWithWrites env2 $ do+    writeMemo <- newMemoWith doNonMemoWrites+    let doWriteMemo = runMemo writeMemo+    _ <- mapWrites func doWriteMemo+    _ <- doWriteMemo+    return ()+  -- "inner not memo" should appear only once+  assertEqualIgnoreOrder+    "Write correctly transformed under memoization"+    [ SimpleWrite "INNER"+    , SimpleWrite "inner"+    , SimpleWrite "INNER NOT MEMO"+    ]+    wrts2++  -- Same as previous, but the non-mapped computation is run first+  env3 <- emptyEnv ()+  (_res3, wrts3) <- runHaxlWithWrites env3 $ do+    writeMemo <- newMemoWith doNonMemoWrites+    let doWriteMemo = runMemo writeMemo+    _ <- doWriteMemo+    _ <- mapWrites func doWriteMemo+    return ()+  -- "inner not memo" should appear only once+  assertEqualIgnoreOrder+    "Flipped: Write correctly transformed under memoization"+    [ SimpleWrite "inner"+    , SimpleWrite "INNER"+    , SimpleWrite "inner not memo"+    ]+    wrts3++  -- inner computation performs no writes+  env4 <- emptyEnv ()+  (res4, wrts4) <- runHaxlWithWrites env4 $+    mapWrites func (return (0 :: Int))+  assertEqual "No Writes: Expected computation result" 0 res4+  assertEqualIgnoreOrder "No writes" [] wrts4++  -- inner computation throws an exception+  env5 <- emptyEnv ()+  (res5, wrts5) <- runHaxlWithWrites env5 $ mapWrites func $ try $ do+    _ <- doNonMemoWrites+    _ <- throw (NotFound "exception")+    return 0+  assertBool "Throw: Expected Computation Result" $ isLeft+    (res5 :: Either HaxlException Int)+  assertEqualIgnoreOrder+    "Datasource writes correctly transformed"+    [ SimpleWrite "INNER"+    , SimpleWrite "INNER NOT MEMO"+    ]+    wrts5++  -- inner computation calls a datasource+  env6 <- initEnv (stateSet DSState stateEmpty) ()+  (res6, wrts6) <- runHaxlWithWrites env6 $ mapWrites func $ do+    _ <- doNonMemoWrites+    dataFetch GetNumber++  assertEqual "Datasource: Expected Computation Result" 37 res6+  assertEqualIgnoreOrder+    "Datasource writes correctly transformed"+    [ SimpleWrite "INNER"+    , SimpleWrite "INNER NOT MEMO"+    ]+    wrts6++  -- inner computation calls a datasource, flipped calls+  env7 <- initEnv (stateSet DSState stateEmpty) ()+  (res7, wrts7) <- runHaxlWithWrites env7 $ mapWrites func $ do+    df <- dataFetch GetNumber+    _ <- doNonMemoWrites+    return df++  assertEqual "Flipped Datasource: Expected Computation Result" 37 res7+  assertEqualIgnoreOrder+    "Flipped: Datasource writes correctly transformed"+    [ SimpleWrite "INNER"+    , SimpleWrite "INNER NOT MEMO"+    ]+    wrts7++tests = TestList+  [ TestLabel "Write Soundness" writeSoundness,+    TestLabel "writeLogs_correctness" writeLogsCorrectnessTest,+    TestLabel "mapWrites" mapWritesTest+  ]