haxl 0.1.0.0 → 0.2.0.0

raw patch · 19 files changed

+615/−343 lines, 19 filesdep ~aesondep ~filepathdep ~textPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: aeson, filepath, text, time

API changes (from Hackage documentation)

Files

• Haxl/Core.hs +2/−4
• Haxl/Core/DataCache.hs +19/−16
• Haxl/Core/Env.hs +0/−65
• Haxl/Core/Exception.hs +1/−1
• Haxl/Core/Fetch.hs +0/−172
• Haxl/Core/Monad.hs +417/−38
• Haxl/Core/RequestStore.hs +1/−1
• Haxl/Core/Show1.hs +1/−1
• Haxl/Core/StateStore.hs +1/−1
• Haxl/Core/Types.hs +82/−14
• Haxl/Core/Util.hs +1/−1
• Haxl/Prelude.hs +9/−3
• LICENSE +1/−1
• haxl.cabal +10/−10
• readme.md +3/−5
• tests/CoreTests.hs +26/−1
• tests/DataCacheTest.hs +12/−2
• tests/ExampleDataSource.hs +5/−0
• tests/TestExampleDataSource.hs +24/−7

@@ -1,4 +1,4 @@--- Copyright (c) 2014, Facebook, Inc.+-- Copyright (c) 2014-present, Facebook, Inc. -- All rights reserved. -- -- This source code is distributed under the terms of a BSD license,@@ -8,15 +8,13 @@ -- | Everything needed to define data sources and to invoke the -- engine. This module should not be imported by user code. module Haxl.Core-  ( module Haxl.Core.Env-  , module Haxl.Core.Monad+  ( module Haxl.Core.Monad   , module Haxl.Core.Types   , module Haxl.Core.Exception   , module Haxl.Core.StateStore   , module Haxl.Core.Show1   ) where -import Haxl.Core.Env import Haxl.Core.Monad hiding (unsafeLiftIO {- Ask nicely to get this! -}) import Haxl.Core.Types import Haxl.Core.Exception

@@ -1,10 +1,11 @@--- Copyright (c) 2014, Facebook, Inc.+-- 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. An additional grant of patent rights can -- be found in the PATENTS file. +{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -fno-warn-orphans #-}@@ -25,7 +26,9 @@ import qualified Data.HashMap.Strict as HashMap import Data.Typeable.Internal import Data.Maybe+#if __GLASGOW_HASKELL__ < 710 import Control.Applicative hiding (empty)+#endif import Control.Exception  import Haxl.Core.Types@@ -36,32 +39,32 @@ -- -- See the definition of 'ResultVar' for more details. -newtype DataCache = DataCache (HashMap TypeRep SubCache)+newtype DataCache res = DataCache (HashMap TypeRep (SubCache res))  -- | The implementation is a two-level map: the outer level maps the -- types of requests to 'SubCache', which maps actual requests to their -- results.  So each 'SubCache' contains requests of the same type. -- This works well because we only have to store the dictionaries for -- 'Hashable' and 'Eq' once per request type.-data SubCache =+data SubCache res =   forall req a . (Hashable (req a), Eq (req a), Show (req a), Show a) =>-       SubCache ! (HashMap (req a) (ResultVar a))+       SubCache ! (HashMap (req a) (res a))        -- NB. the inner HashMap is strict, to avoid building up        -- a chain of thunks during repeated insertions.  -- | A new, empty 'DataCache'.-empty :: DataCache+empty :: DataCache res empty = DataCache HashMap.empty  -- | Inserts a request-result pair into the 'DataCache'. insert-  :: (Hashable (r a), Typeable (r a), Eq (r a), Show (r a), Show a)-  => r a+  :: (Hashable (req a), Typeable (req a), Eq (req a), Show (req a), Show a)+  => req a   -- ^ Request-  -> ResultVar a+  -> res a   -- ^ Result-  -> DataCache-  -> DataCache+  -> DataCache res+  -> DataCache res  insert req result (DataCache m) =       DataCache $@@ -73,11 +76,11 @@  -- | Looks up the cached result of a request. lookup-  :: Typeable (r a)-  => r a+  :: Typeable (req a)+  => req a   -- ^ Request-  -> DataCache-  -> Maybe (ResultVar a)+  -> DataCache res+  -> Maybe (res a)  lookup req (DataCache m) =       case HashMap.lookup (typeOf req) m of@@ -90,13 +93,13 @@ -- 'TypeRep'. -- showCache-  :: DataCache+  :: DataCache ResultVar   -> IO [(TypeRep, [(String, Either SomeException String)])]  showCache (DataCache cache) = mapM goSubCache (HashMap.toList cache)  where   goSubCache-    :: (TypeRep,SubCache)+    :: (TypeRep,SubCache ResultVar)     -> IO (TypeRep,[(String, Either SomeException String)])   goSubCache (ty, SubCache hmap) = do     elems <- catMaybes <$> mapM go (HashMap.toList hmap)

@@ -1,65 +0,0 @@--- Copyright (c) 2014, Facebook, Inc.--- All rights reserved.------ This source code is distributed under the terms of a BSD license,--- found in the LICENSE file. An additional grant of patent rights can--- be found in the PATENTS file.--{-# LANGUAGE OverloadedStrings #-}---- | The Haxl monad environment.-module Haxl.Core.Env-  ( Env(..)-  , emptyEnv-  , initEnv-  , initEnvWithData-  , caches-  ) where--import Haxl.Core.DataCache as DataCache-import Haxl.Core.StateStore-import Haxl.Core.Types--import Data.IORef---- | The data we carry around in the Haxl monad.-data Env u = Env-  { cacheRef     :: IORef DataCache     -- cached data fetches-  , memoRef      :: IORef DataCache     -- memoized computations-  , flags        :: Flags-  , userEnv      :: u-  , statsRef     :: IORef Stats-  , states       :: StateStore-  -- ^ Data sources and other components can store their state in-  -- here. Items in this store must be instances of 'StateKey'.-  }--type Caches = (IORef DataCache, IORef DataCache)--caches :: Env u -> Caches-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 -> IO (Env u)-initEnvWithData states e (cref, mref) = do-  sref <- newIORef emptyStats-  return Env-    { cacheRef = cref-    , memoRef = mref-    , flags = defaultFlags-    , userEnv = e-    , states = states-    , statsRef = sref-    }---- | Initializes an environment with 'DataStates' and an input map.-initEnv :: StateStore -> u -> IO (Env u)-initEnv states e = do-  cref <- newIORef DataCache.empty-  mref <- newIORef DataCache.empty-  initEnvWithData states e (cref,mref)---- | A new, empty environment.-emptyEnv :: u -> IO (Env u)-emptyEnv = initEnv stateEmpty

@@ -1,4 +1,4 @@--- Copyright (c) 2014, Facebook, Inc.+-- Copyright (c) 2014-present, Facebook, Inc. -- All rights reserved. -- -- This source code is distributed under the terms of a BSD license,

@@ -1,172 +0,0 @@--- Copyright (c) 2014, Facebook, Inc.--- All rights reserved.------ This source code is distributed under the terms of a BSD license,--- found in the LICENSE file. An additional grant of patent rights can--- be found in the PATENTS file.--{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}---- | Generic fetching infrastructure, used by 'Haxl.Core.Monad'.-module Haxl.Core.Fetch-  ( CacheResult(..)-  , cached-  , memoized-  , performFetches-  ) where--import Haxl.Core.DataCache as DataCache-import Haxl.Core.Env-import Haxl.Core.Exception-import Haxl.Core.RequestStore-import Haxl.Core.Show1-import Haxl.Core.StateStore-import Haxl.Core.Types-import Haxl.Core.Util--import Control.Exception-import Control.Monad-import Data.IORef-import Data.List-import Data.Time-import Text.Printf-import Data.Monoid-import qualified Data.HashMap.Strict as HashMap-import qualified Data.Text as Text---- | Issues a batch of fetches in a 'RequestStore'. After--- 'performFetches', all the requests in the 'RequestStore' are--- complete, and all of the 'ResultVar's are full.-performFetches :: forall u. Env u -> RequestStore u -> IO ()-performFetches env reqs = do-  let f = flags env-      sref = statsRef env-      jobs = contents reqs--  t0 <- getCurrentTime--  let-    roundstats =-      [ (dataSourceName (getReq reqs), length reqs)-      | BlockedFetches reqs <- jobs ]-      where-      getReq :: [BlockedFetch r] -> r a-      getReq = undefined--  modifyIORef' sref $ \(Stats rounds) ->-     Stats (RoundStats (HashMap.fromList roundstats) : rounds)--  ifTrace f 1 $-    printf "Batch data fetch (%s)\n" $-       intercalate (", "::String) $-           map (\(name,num) -> printf "%d %s" num (Text.unpack name)) roundstats--  ifTrace f 3 $-    forM_ jobs $ \(BlockedFetches reqs) ->-      forM_ reqs $ \(BlockedFetch r _) -> putStrLn (show1 r)--  let-    applyFetch (BlockedFetches (reqs :: [BlockedFetch r])) =-      case stateGet (states env) of-        Nothing ->-          return (SyncFetch (mapM_ (setError (const e)) reqs))-          where req :: r a; req = undefined-                e = DataSourceError $-                      "data source not initialized: " <> dataSourceName req-        Just state ->-          return $ wrapFetch reqs $ fetch state f (userEnv env) reqs--  fetches <- mapM applyFetch jobs--  scheduleFetches fetches--  ifTrace f 1 $ do-    t1 <- getCurrentTime-    printf "Batch data fetch done (%.2fs)\n"-      (realToFrac (diffUTCTime t1 t0) :: Double)---- Catch exceptions arising from the data source and stuff them into--- the appropriate requests.  We don't want any exceptions propagating--- directly from the data sources, because we want the exception to be--- thrown by dataFetch instead.----wrapFetch :: [BlockedFetch req] -> PerformFetch -> PerformFetch-wrapFetch reqs fetch =-  case fetch of-    SyncFetch io -> SyncFetch (io `catch` handler)-    AsyncFetch fio -> AsyncFetch (\io -> fio io `catch` handler)-  where-    handler :: SomeException -> IO ()-    handler e = mapM_ (forceError e) reqs--    -- Set the exception even if the request already had a result.-    -- Otherwise we could be discarding an exception.-    forceError e (BlockedFetch _ rvar) = do-      void $ tryTakeResult rvar-      putResult rvar (except e)---- | Start all the async fetches first, then perform the sync fetches before--- getting the results of the async fetches.-scheduleFetches :: [PerformFetch] -> IO()-scheduleFetches fetches = async_fetches sync_fetches- where-  async_fetches :: IO () -> IO ()-  async_fetches = compose [f | AsyncFetch f <- fetches]--  sync_fetches :: IO ()-  sync_fetches = sequence_ [io | SyncFetch io <- fetches]---- | Possible responses when checking the cache.-data CacheResult a-  -- | The request hadn't been seen until now.-  = Uncached (ResultVar a)--  -- | The request has been seen before, but its result has not yet been-  -- fetched.-  | CachedNotFetched (ResultVar a)--  -- | The request has been seen before, and its result has already been-  -- fetched.-  | Cached (Either SomeException a)----- | Checks the data cache for the result of a request.-cached :: (Request r a) => Env u -> r a -> IO (CacheResult a)-cached env = checkCache (flags env) (cacheRef env)---- | Checks the memo cache for the result of a computation.-memoized :: (Request r a) => Env u -> r a -> IO (CacheResult a)-memoized env = checkCache (flags env) (memoRef env)---- | Common guts of 'cached' and 'memoized'.-checkCache-  :: (Request r a)-  => Flags-  -> IORef DataCache-  -> r a-  -> IO (CacheResult a)--checkCache flags ref req = do-  cache <- readIORef ref-  let-    do_fetch = do-      rvar <- newEmptyResult-      writeIORef ref (DataCache.insert req rvar cache)-      return (Uncached rvar)-  case DataCache.lookup req cache of-    Nothing -> do_fetch-    Just rvar -> do-      mb <- tryReadResult rvar-      case mb of-        Nothing -> return (CachedNotFetched rvar)-        -- Use the cached result, even if it was an error.-        Just r -> do-          ifTrace flags 3 $ putStrLn $ case r of-            Left _ -> "Cached error: " ++ show req-            Right _ -> "Cached request: " ++ show req-          return (Cached r)

@@ -1,4 +1,4 @@--- Copyright (c) 2014, Facebook, Inc.+-- Copyright (c) 2014-present, Facebook, Inc. -- All rights reserved. -- -- This source code is distributed under the terms of a BSD license,@@ -6,10 +6,12 @@ -- be found in the PATENTS file.  {-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -20,8 +22,11 @@     GenHaxl (..), runHaxl,     env, +    -- * Env+    Env(..), caches, initEnvWithData, initEnv, emptyEnv,+     -- * Exceptions-    throw, catch, try, tryToHaxlException,+    throw, catch, catchIf, try, tryToHaxlException,      -- * Data fetching and caching     dataFetch, uncachedRequest,@@ -33,28 +38,87 @@   ) where  import Haxl.Core.Types-import Haxl.Core.Fetch-import Haxl.Core.Env+import Haxl.Core.Show1+import Haxl.Core.StateStore import Haxl.Core.Exception import Haxl.Core.RequestStore import Haxl.Core.Util-import Haxl.Core.DataCache+import Haxl.Core.DataCache as DataCache  import qualified Data.Text as Text import Control.Exception (Exception(..), SomeException)-import qualified Control.Exception+#if __GLASGOW_HASKELL__ >= 708+import Control.Exception (SomeAsyncException(..))+#endif+#if __GLASGOW_HASKELL__ >= 710+import Control.Exception (AllocationLimitExceeded(..))+#endif+import Control.Monad+import qualified Control.Exception as Exception import Control.Applicative hiding (Const) import GHC.Exts (IsString(..)) #if __GLASGOW_HASKELL__ < 706 import Prelude hiding (catch) #endif import Data.IORef+import Data.List import Data.Monoid+import Data.Time+import qualified Data.HashMap.Strict as HashMap import Text.Printf import Text.PrettyPrint hiding ((<>)) import Control.Arrow (left)+#ifdef EVENTLOG+import Control.Exception (bracket_)+import Debug.Trace (traceEventIO)+#endif  -- -----------------------------------------------------------------------------+-- The environment++-- | The data we carry around in the Haxl monad.+data Env u = Env+  { cacheRef     :: IORef (DataCache ResultVar) -- cached data fetches+  , memoRef      :: IORef (DataCache (MemoVar u))   -- memoized computations+  , flags        :: Flags+  , userEnv      :: u+  , statsRef     :: IORef Stats+  , states       :: StateStore+  -- ^ Data sources and other components can store their state in+  -- here. Items in this store must be instances of 'StateKey'.+  }++type Caches u = (IORef (DataCache ResultVar), IORef (DataCache (MemoVar u)))++caches :: Env u -> Caches u+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 states e (cref, mref) = do+  sref <- newIORef emptyStats+  return Env+    { cacheRef = cref+    , memoRef = mref+    , flags = defaultFlags+    , userEnv = e+    , states = states+    , statsRef = sref+    }++-- | Initializes an environment with 'DataStates' and an input map.+initEnv :: StateStore -> u -> IO (Env u)+initEnv states e = do+  cref <- newIORef DataCache.empty+  mref <- newIORef DataCache.empty+  initEnvWithData states e (cref,mref)++-- | A new, empty environment.+emptyEnv :: u -> IO (Env u)+emptyEnv = initEnv stateEmpty++-- ----------------------------------------------------------------------------- -- | The Haxl monad, which does several things: -- --  * It is a reader monad for 'Env' and 'IORef' 'RequestStore', The@@ -120,16 +184,40 @@  -- | Runs a 'Haxl' computation in an 'Env'. runHaxl :: Env u -> GenHaxl u a -> IO a+#ifdef EVENTLOG+runHaxl env h = do+  let go !n env (GenHaxl haxl) = do+        traceEventIO "START computation"+        ref <- newIORef noRequests+        e <- haxl env ref+        traceEventIO "STOP computation"+        case e of+          Done a       -> return a+          Throw e      -> Exception.throw e+          Blocked cont -> do+            bs <- readIORef ref+            writeIORef ref noRequests -- Note [RoundId]+            traceEventIO "START performFetches"+            n' <- performFetches n env bs+            traceEventIO "STOP performFetches"+            go n' env cont+  traceEventIO "START runHaxl"+  r <- go 0 env h+  traceEventIO "STOP runHaxl"+  return r+#else runHaxl env (GenHaxl haxl) = do   ref <- newIORef noRequests   e <- haxl env ref   case e of     Done a       -> return a-    Throw e      -> Control.Exception.throw e+    Throw e      -> Exception.throw e     Blocked cont -> do       bs <- readIORef ref-      performFetches env bs+      writeIORef ref noRequests -- Note [RoundId]+      void (performFetches 0 env bs)       runHaxl env cont+#endif  -- | Extracts data from the 'Env'. env :: (Env u -> a) -> GenHaxl u a@@ -145,6 +233,7 @@ raise :: (Exception e) => e -> IO (Result u a) raise = return . Throw . toException +-- | Catch an exception in the Haxl monad catch :: Exception e => GenHaxl u a -> (e -> GenHaxl u a) -> GenHaxl u a catch (GenHaxl m) h = GenHaxl $ \env ref -> do    r <- m env ref@@ -154,9 +243,19 @@              | otherwise -> return (Throw e)      Blocked k -> return (Blocked (catch k h)) +-- | Catch exceptions that satisfy a predicate+catchIf+  :: Exception e => (e -> Bool) -> GenHaxl u a -> (e -> GenHaxl u a)+  -> GenHaxl u 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 haxl = (Right <$> haxl) `catch` (return . Left) + -- ----------------------------------------------------------------------------- -- Unsafe operations @@ -171,7 +270,7 @@ -- order.  Not to be exposed to user code. unsafeToHaxlException :: GenHaxl u a -> GenHaxl u a unsafeToHaxlException (GenHaxl m) = GenHaxl $ \env ref -> do-  r <- m env ref `Control.Exception.catch` \e -> return (Throw e)+  r <- m env ref `Exception.catch` \e -> return (Throw e)   case r of     Blocked c -> return (Blocked (unsafeToHaxlException c))     other -> return other@@ -183,9 +282,45 @@ tryToHaxlException :: GenHaxl u a -> GenHaxl u (Either HaxlException a) tryToHaxlException h = left asHaxlException <$> try (unsafeToHaxlException h) + -- ----------------------------------------------------------------------------- -- Data fetching and caching +-- | Possible responses when checking the cache.+data CacheResult a+  -- | The request hadn't been seen until now.+  = Uncached (ResultVar a)++  -- | The request has been seen before, but its result has not yet been+  -- fetched.+  | CachedNotFetched (ResultVar a)++  -- | The request has been seen before, and its result has already been+  -- fetched.+  | Cached (Either SomeException a)++-- | Checks the data cache for the result of a request.+cached :: (Request r a) => Env u -> r a -> IO (CacheResult a)+cached env req = do+  cache <- readIORef (cacheRef env)+  let+    do_fetch = do+      rvar <- newEmptyResult+      writeIORef (cacheRef env) $! DataCache.insert req rvar cache+      return (Uncached rvar)+  case DataCache.lookup req cache of+    Nothing -> do_fetch+    Just rvar -> do+      mb <- tryReadResult rvar+      case mb of+        Nothing -> return (CachedNotFetched rvar)+        -- Use the cached result, even if it was an error.+        Just r -> do+          ifTrace (flags env) 3 $ putStrLn $ case r of+            Left _ -> "Cached error: " ++ show req+            Right _ -> "Cached request: " ++ show req+          return (Cached r)+ -- | Performs actual fetching of data for a 'Request' from a 'DataSource'. dataFetch :: (DataSource u r, Request r a) => r a -> GenHaxl u a dataFetch req = GenHaxl $ \env ref -> do@@ -232,19 +367,23 @@   case m of     Nothing -> raise . DataSourceError $       textShow req <> " did not set contents of result var"-    Just (Left e) -> return (Throw e)-    Just (Right a) -> return (Done a)+    Just r -> done r  -- | Transparently provides caching. Useful for datasources that can--- return immediately, but also caches values.+-- return immediately, but also caches values.  Exceptions thrown by+-- 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 req val = GenHaxl $ \env _ref -> do   cachedResult <- cached env req   case cachedResult of     Uncached rvar -> do-      result <- Control.Exception.try val+      result <- Exception.try val       putResult rvar result-      done result+      case result of+        Left e -> do rethrowAsyncExceptions e; done result+        _other -> done result     Cached result -> done result     CachedNotFetched _ -> corruptCache   where@@ -256,6 +395,45 @@       , " cacheResult on a query that involves a blocking fetch."       ] ++-- We must be careful about turning IO monad exceptions into Haxl+-- exceptions.  An IO monad exception will normally propagate right+-- out of runHaxl and terminate the whole computation, whereas a Haxl+-- exception can get dropped on the floor, if it is on the right of+-- <*> and the left side also throws, for example.  So turning an IO+-- monad exception into a Haxl exception is a dangerous thing to do.+-- In particular, we never want to do it for an asynchronous exception+-- (AllocationLimitExceeded, ThreadKilled, etc.), because these are+-- supposed to unconditionally terminate the computation.+--+-- There are three places where we take an arbitrary IO monad exception and+-- turn it into a Haxl exception:+--+--  * wrapFetchInCatch.  Here we want to propagate a failure of the+--    data source to the callers of the data source, but if the+--    failure came from elsewhere (an asynchronous exception), then we+--    should just propagate it+--+--  * cacheResult (cache the results of IO operations): again,+--    failures of the IO operation should be visible to the caller as+--    a Haxl exception, but we exclude asynchronous exceptions from+--    this.++--  * unsafeToHaxlException: assume the caller knows what they're+--    doing, and just wrap all exceptions.+--+rethrowAsyncExceptions :: SomeException -> IO ()+rethrowAsyncExceptions e+#if __GLASGOW_HASKELL__ >= 708+  | Just SomeAsyncException{} <- fromException e = Exception.throw e+#endif+#if __GLASGOW_HASKELL__ >= 710+  | Just AllocationLimitExceeded{} <- fromException e = Exception.throw e+    -- AllocationLimitExceeded is not a child of SomeAsyncException,+    -- but it should be.+#endif+  | otherwise = return ()+ -- | Inserts a request/result pair into the cache. Throws an exception -- if the request has already been issued, either via 'dataFetch' or -- 'cacheRequest'.@@ -283,6 +461,183 @@ instance IsString a => IsString (GenHaxl u a) where   fromString s = return (fromString s) +-- | Issues a batch of fetches in a 'RequestStore'. After+-- 'performFetches', all the requests in the 'RequestStore' are+-- complete, and all of the 'ResultVar's are full.+performFetches :: forall u. Int -> Env u -> RequestStore u -> IO Int+performFetches n env reqs = do+  let f = flags env+      sref = statsRef env+      jobs = contents reqs+      !n' = n + length jobs++  t0 <- getCurrentTime++  let+    roundstats =+      [ (dataSourceName (getReq reqs), length reqs)+      | BlockedFetches reqs <- jobs ]+      where+      getReq :: [BlockedFetch r] -> r a+      getReq = undefined++  ifTrace f 1 $+    printf "Batch data fetch (%s)\n" $+      intercalate (", "::String) $+        map (\(name,num) -> printf "%d %s" num (Text.unpack name)) roundstats++  ifTrace f 3 $+    forM_ jobs $ \(BlockedFetches reqs) ->+      forM_ reqs $ \(BlockedFetch r _) -> putStrLn (show1 r)++  let+    applyFetch (i, BlockedFetches (reqs :: [BlockedFetch r])) =+      case stateGet (states env) of+        Nothing ->+          return (SyncFetch (mapM_ (setError (const e)) reqs))+          where req :: r a; req = undefined+                e = DataSourceError $+                      "data source not initialized: " <> dataSourceName req+        Just state ->+          return $ wrapFetchInTrace i (length reqs)+                    (dataSourceName (undefined :: r a))+                 $ wrapFetchInCatch reqs+                 $ fetch state f (userEnv env) reqs++  fetches <- mapM applyFetch $ zip [n..] jobs++  times <-+    if report f >= 2+    then do+      (refs, timedfetches) <- mapAndUnzipM wrapFetchInTimer fetches+      scheduleFetches timedfetches+      mapM (fmap Just . readIORef) refs+    else do+      scheduleFetches fetches+      return $ repeat Nothing++  let dsroundstats = HashMap.fromList+         [ (name, DataSourceRoundStats { dataSourceFetches = fetches+                                       , dataSourceTime = time+                                       })+         | ((name, fetches), time) <- zip roundstats times]++  t1 <- getCurrentTime+  let roundtime = realToFrac (diffUTCTime t1 t0) :: Double++  ifReport f 1 $+    modifyIORef' sref $ \(Stats rounds) ->+      Stats (RoundStats (microsecs roundtime) dsroundstats: rounds)++  ifTrace f 1 $+    printf "Batch data fetch done (%.2fs)\n" (realToFrac roundtime :: Double)++  return n'++-- Catch exceptions arising from the data source and stuff them into+-- the appropriate requests.  We don't want any exceptions propagating+-- directly from the data sources, because we want the exception to be+-- thrown by dataFetch instead.+--+wrapFetchInCatch :: [BlockedFetch req] -> PerformFetch -> PerformFetch+wrapFetchInCatch reqs fetch =+  case fetch of+    SyncFetch io ->+      SyncFetch (io `Exception.catch` handler)+    AsyncFetch fio ->+      AsyncFetch (\io -> fio io `Exception.catch` handler)+  where+    handler :: SomeException -> IO ()+    handler e = do+      rethrowAsyncExceptions e+      mapM_ (forceError e) reqs++    -- Set the exception even if the request already had a result.+    -- Otherwise we could be discarding an exception.+    forceError e (BlockedFetch _ rvar) = do+      void $ tryTakeResult rvar+      putResult rvar (except e)++wrapFetchInTimer :: PerformFetch -> IO (IORef Microseconds, PerformFetch)+wrapFetchInTimer f = do+  r <- newIORef 0+  case f of+    SyncFetch io -> return (r, SyncFetch (time io >>= writeIORef r))+    AsyncFetch f -> do+       inner_r <- newIORef 0+       return (r, AsyncFetch $ \inner -> do+         total <- time (f (time inner >>= writeIORef inner_r))+         inner_t <- readIORef inner_r+         writeIORef r (total - inner_t))++wrapFetchInTrace :: Int -> Int -> Text.Text -> PerformFetch -> PerformFetch+#ifdef EVENTLOG+wrapFetchInTrace i n dsName f =+  case f of+    SyncFetch io -> SyncFetch (wrapF "Sync" io)+    AsyncFetch fio -> AsyncFetch (wrapF "Async" . fio . unwrapF "Async")+  where+    d = Text.unpack dsName+    wrapF :: String -> IO a -> IO a+    wrapF ty = bracket_ (traceEventIO $ printf "START %d %s (%d %s)" i d n ty)+                        (traceEventIO $ printf "STOP %d %s (%d %s)" i d n ty)+    unwrapF :: String -> IO a -> IO a+    unwrapF ty = bracket_ (traceEventIO $ printf "STOP %d %s (%d %s)" i d n ty)+                          (traceEventIO $ printf "START %d %s (%d %s)" i d n ty)+#else+wrapFetchInTrace _ _ _ f = f+#endif++time :: IO () -> IO Microseconds+time io = do+  t0 <- getCurrentTime+  io+  t1 <- getCurrentTime+  return . microsecs . realToFrac $ t1 `diffUTCTime` t0++microsecs :: Double -> Microseconds+microsecs t = round (t * 10^(6::Int))++-- | Start all the async fetches first, then perform the sync fetches before+-- getting the results of the async fetches.+scheduleFetches :: [PerformFetch] -> IO()+scheduleFetches fetches = async_fetches sync_fetches+ where+  async_fetches :: IO () -> IO ()+  async_fetches = compose [f | AsyncFetch f <- fetches]++  sync_fetches :: IO ()+  sync_fetches = sequence_ [io | SyncFetch io <- fetches]+++-- -----------------------------------------------------------------------------+-- Memoization++-- | A variable in the cache representing the state of a memoized computation+newtype MemoVar u a = MemoVar (IORef (MemoStatus u a))++-- | The state of a memoized computation+data MemoStatus u a+  = MemoInProgress (RoundId u) (GenHaxl u a)+      -- ^ Under evaluation in the given round, here is the latest+      -- continuation.  The continuation might be a little out of+      -- date, but that's fine, the worst that can happen is we do a+      -- little extra work.+  | MemoDone (Either SomeException a)+      -- fully evaluated, here is the result.++type RoundId u = IORef (RequestStore u)+{-+Note [RoundId]++A token representing the round.  This needs to be unique per round,+and it needs to support Eq.  Fortunately the IORef RequestStore is+exactly what we need: IORef supports Eq, and we make a new one for+each round.  There's a danger that storing this in the DataCache could+cause a space leak, so we stub out the contents after each round (see+runHaxl).+-}+ -- | 'cachedComputation' memoizes a Haxl computation.  The key is a -- request. --@@ -293,36 +648,60 @@    :: forall req u a. (Request req a)    => req a -> GenHaxl u a -> GenHaxl u a cachedComputation req haxl = GenHaxl $ \env ref -> do-  res <- memoized env req-  case res of-    -- Uncached: we must compute the result and store it in the ResultVar.-    Uncached rvar -> do-      let-          with_result :: Either SomeException a -> GenHaxl u a-          with_result r = GenHaxl $ \_ _ -> do putResult rvar r; done r--      unHaxl (try haxl >>= with_result) env ref+  cache <- readIORef (memoRef env)+  case DataCache.lookup req cache of+    Nothing -> do+      memovar <- newIORef (MemoInProgress ref haxl)+      writeIORef (memoRef env) $! DataCache.insert req (MemoVar memovar) cache+      run memovar haxl env ref+    Just (MemoVar memovar) -> do+      status <- readIORef memovar+      case status of+        MemoDone r -> done r+        MemoInProgress round cont+          | round == ref -> return (Blocked (retryMemo req))+          | otherwise    -> run memovar cont env ref+          -- was blocked in a previous round; run the saved continuation to+          -- make more progress.+ where+  -- If we got blocked on this memo in the current round, this is the+  -- continuation: just try to evaluate the memo again.  We know it is+  -- already in the cache (because we just checked), so the computation+  -- will never be used.+  retryMemo req =+   cachedComputation req (throw (CriticalError "retryMemo")) -    -- CachedNotFetched: this request is already being computed, we just-    -- have to block until the result is available.  Note that we might-    -- have to block repeatedly, because the Haxl computation might block-    -- multiple times before it has a result.-    CachedNotFetched rvar -> return $ Blocked (continueCached rvar)-    Cached r -> done r+  -- Run the memoized computation and store the result (complete or+  -- partial) back in the MemoVar afterwards.+ --+ -- We don't attempt to catch IO monad exceptions here.  That may seem+ -- dangerous, because if an IO exception is raised we'll leave the+ -- MemoInProgress in the MemoVar.  But we always want to just+ -- propagate an IO monad exception (it should kill the whole runHaxl,+ -- unless there's a unsafeToHaxlException), so we should never be+ -- looking at the MemoVar again anyway.  Furthermore, storing the+ -- exception in the MemoVar is wrong, because that will turn it into+ -- a Haxl exception (see rethrowAsyncExceptions).+  run memovar cont env ref = do+    e <- unHaxl cont env ref+    case e of+      Done a -> complete memovar (Right a)+      Throw e -> complete memovar (Left e)+      Blocked cont -> do+        writeIORef memovar (MemoInProgress ref cont)+        return (Blocked (retryMemo req)) -continueCached :: ResultVar a -> GenHaxl u a-continueCached rvar = GenHaxl $ \_env _ref -> do-  m <- tryReadResult rvar-  case m of-    -- Unlike dataFetch, Nothing is not an error here: the computation-    -- is being worked on elsewhere and probably got blocked in a-    -- datafetch, we just have to keep waiting for the result.-    Nothing -> return $ Blocked (continueCached rvar)-    Just r -> done r+  -- We're finished: store the final result+  complete memovar r = do+    writeIORef memovar (MemoDone r)+    done r  -- | Lifts an 'Either' into either 'Throw' or 'Done'. done :: Either SomeException a -> IO (Result u a) done = return . either Throw Done+++-- -----------------------------------------------------------------------------  -- | Dump the contents of the cache as Haskell code that, when -- compiled and run, will recreate the same cache contents.  For

@@ -1,4 +1,4 @@--- Copyright (c) 2014, Facebook, Inc.+-- Copyright (c) 2014-present, Facebook, Inc. -- All rights reserved. -- -- This source code is distributed under the terms of a BSD license,

@@ -1,4 +1,4 @@--- Copyright (c) 2014, Facebook, Inc.+-- Copyright (c) 2014-present, Facebook, Inc. -- All rights reserved. -- -- This source code is distributed under the terms of a BSD license,

@@ -1,4 +1,4 @@--- Copyright (c) 2014, Facebook, Inc.+-- Copyright (c) 2014-present, Facebook, Inc. -- All rights reserved. -- -- This source code is distributed under the terms of a BSD license,

@@ -1,4 +1,4 @@--- Copyright (c) 2014, Facebook, Inc.+-- Copyright (c) 2014-present, Facebook, Inc. -- All rights reserved. -- -- This source code is distributed under the terms of a BSD license,@@ -13,6 +13,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -26,13 +27,19 @@   Flags(..),   defaultFlags,   ifTrace,+  ifReport,    -- * Statistics   Stats(..),   RoundStats(..),+  DataSourceRoundStats(..),+  Microseconds,   emptyStats,   numRounds,   numFetches,+  ppStats,+  ppRoundStats,+  ppDataSourceRoundStats,    -- * Data fetching   DataSource(..),@@ -63,16 +70,20 @@    ) where +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative+#endif+import Control.Concurrent.MVar import Control.Exception-import Data.Typeable-import Data.Text (Text)+import Control.Monad import Data.Aeson+import Data.Function (on) import Data.Hashable-import Control.Concurrent.MVar-import Control.Monad+import Data.HashMap.Strict (HashMap, toList) import qualified Data.HashMap.Strict as HashMap-import Data.HashMap.Strict (HashMap)+import Data.List (intercalate, sortBy)+import Data.Text (Text, unpack)+import Data.Typeable (Typeable)  #if __GLASGOW_HASKELL__ < 708 import Haxl.Core.Util (tryReadMVar)@@ -94,29 +105,78 @@ data Flags = Flags   { trace :: Int     -- ^ Tracing level (0 = quiet, 3 = very verbose).+  , report :: Int+    -- ^ Report level (0 = quiet, 1 = # of requests, 2 = time, 3 = # of errors)   }  defaultFlags :: Flags-defaultFlags = Flags { trace = 0 }+defaultFlags = Flags+  { trace = 0+  , report = 1+  }  -- | Runs an action if the tracing level is above the given threshold. ifTrace :: (Functor m, Monad m) => Flags -> Int -> m a -> m ()-ifTrace flags i m-  | trace flags >= i = void m-  | otherwise        = return ()+ifTrace flags i = when (trace flags >= i) . void +-- | Runs an action if the report level is above the given threshold.+ifReport :: (Functor m, Monad m) => Flags -> Int -> m a -> m ()+ifReport flags i = when (report flags >= i) . void++type Microseconds = Int+ -- | Stats that we collect along the way. newtype Stats = Stats [RoundStats]   deriving ToJSON +-- | Pretty-print Stats.+ppStats :: Stats -> String+ppStats (Stats rss) =+  intercalate "\n" [ "Round: " ++ show i ++ " - " ++ ppRoundStats rs+                   | (i, rs) <- zip [(1::Int)..] (reverse rss) ]+ -- | Maps data source name to the number of requests made in that round. -- The map only contains entries for sources that made requests in that -- round.-newtype RoundStats = RoundStats (HashMap Text Int)-  deriving ToJSON+data RoundStats = RoundStats+  { roundTime :: Microseconds+  , roundDataSources :: HashMap Text DataSourceRoundStats+  } +-- | Pretty-print RoundStats.+ppRoundStats :: RoundStats -> String+ppRoundStats (RoundStats t dss) =+    show t ++ "us\n"+      ++ unlines [ "  " ++ unpack nm ++ ": " ++ ppDataSourceRoundStats dsrs+                 | (nm, dsrs) <- sortBy (compare `on` fst) (toList dss) ]++instance ToJSON RoundStats where+  toJSON RoundStats{..} = object+    [ "time" .= roundTime+    , "dataSources" .= roundDataSources+    ]++-- | Detailed stats of each data source in each round.+data DataSourceRoundStats = DataSourceRoundStats+  { dataSourceFetches :: Int+  , dataSourceTime :: Maybe Microseconds+  }++-- | Pretty-print DataSourceRoundStats+ppDataSourceRoundStats :: DataSourceRoundStats -> String+ppDataSourceRoundStats (DataSourceRoundStats i t) =+  maybeTime $ show i ++ " fetches"+    where maybeTime = maybe id (\ tm s -> s ++ " (" ++ show tm ++ "us)") t++instance ToJSON DataSourceRoundStats where+  toJSON DataSourceRoundStats{..} = object [k .= v | (k, Just v) <-+    [ ("fetches", Just dataSourceFetches)+    , ("time", dataSourceTime)+    ]]+ fetchesInRound :: RoundStats -> Int-fetchesInRound (RoundStats hm) = sum $ HashMap.elems hm+fetchesInRound (RoundStats _ hm) =+  sum $ map dataSourceFetches $ HashMap.elems hm  emptyStats :: Stats emptyStats = Stats []@@ -136,7 +196,7 @@ -- such as 'IORef'. -- -- For a complete example data source, see--- <https://phabricator.fb.com/diffusion/FBCODE/browse/master/sigma/haxl/core/tests/ExampleDataSource.hs ExampleDataSource>.+-- <https://github.com/facebook/Haxl/tree/master/example Examples>. -- class (DataSourceName req, StateKey req, Show1 req) => DataSource u req where @@ -190,6 +250,14 @@ data PerformFetch   = SyncFetch  (IO ())   | AsyncFetch (IO () -> IO ())++-- Why does AsyncFetch contain a `IO () -> IO ()` rather than the+-- alternative approach of returning the `IO` action to retrieve the+-- results, which might seem better: `IO (IO ())`?  The point is that+-- this allows the data source to acquire resources for the purpose of+-- this fetching round using the standard `bracket` pattern, so it can+-- ensure that the resources acquired are properly released even if+-- other data sources fail.  -- | A 'BlockedFetch' is a pair of --

@@ -1,4 +1,4 @@--- Copyright (c) 2014, Facebook, Inc.+-- Copyright (c) 2014-present, Facebook, Inc. -- All rights reserved. -- -- This source code is distributed under the terms of a BSD license,

@@ -1,10 +1,11 @@--- Copyright (c) 2014, Facebook, Inc.+-- 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. An additional grant of patent rights can -- be found in the PATENTS file. +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -35,7 +36,10 @@      -- * Extra Monad and Applicative things     Applicative(..),-    mapM, mapM_, sequence, sequence_, (<$>), filterM, foldM,+#if __GLASGOW_HASKELL__ < 710+    (<$>),+#endif+    mapM, mapM_, sequence, sequence_, filterM, foldM,     forM, forM_,     foldl', sort,     Monoid(..),@@ -71,7 +75,9 @@ import Data.Traversable hiding (forM, mapM, sequence) import GHC.Exts (IsString(..)) import Prelude hiding (mapM, mapM_, sequence, sequence_)+#if __GLASGOW_HASKELL__ < 710 import Data.Monoid+#endif import Data.Maybe import Control.Exception (fromException) @@ -89,7 +95,7 @@   ifThenElse :: a -> b -> b -> b  instance IfThenElse Bool a where-  ifThenElse b t e = case b of True -> t; False -> e+  ifThenElse b t e = if b then t else e  -- The equality constraint is necessary to convince the typechecker that -- this is valid:

@@ -1,4 +1,4 @@-Copyright (c) 2014, Facebook, Inc.+Copyright (c) 2014-present, Facebook, Inc. All rights reserved.  Redistribution and use in source and binary forms, with or without modification,

@@ -1,5 +1,5 @@ name:                haxl-version:             0.1.0.0+version:             0.2.0.0 synopsis:            A Haskell library for efficient, concurrent,                      and concise data access. homepage:            https://github.com/facebook/Haxl@@ -8,7 +8,7 @@ license-file:        LICENSE author:              Facebook, Inc. maintainer:          The Haxl Team <haxl-team@fb.com>-copyright:           2014 (C) 2014 Facebook, Inc.+copyright:           Copyright (c) 2014-present, Facebook, Inc. category:            Concurrency build-type:          Simple stability:           alpha@@ -27,16 +27,16 @@    build-depends:     HUnit == 1.2.*,-    aeson >= 0.6 && <0.8,+    aeson >= 0.6 && < 0.9,     base == 4.*,-    bytestring >= 0.9 && <0.11,+    bytestring >= 0.9 && < 0.11,     containers == 0.5.*,-    directory >= 1.1 && <1.3,-    filepath == 1.3.*,+    directory >= 1.1 && < 1.3,+    filepath >= 1.3 && < 1.5,     hashable == 1.2.*,     pretty == 1.1.*,-    text == 1.1.*,-    time == 1.4.*,+    text >= 1.1.0.1 && < 1.3,+    time >= 1.4 && < 1.6,     unordered-containers == 0.2.*,     vector == 0.10.* @@ -44,8 +44,6 @@     Haxl.Core,     Haxl.Core.DataCache,     Haxl.Core.Exception,-    Haxl.Core.Env,-    Haxl.Core.Fetch,     Haxl.Core.Monad,     Haxl.Core.RequestStore,     Haxl.Core.StateStore,@@ -99,3 +97,5 @@    type:     exitcode-stdio-1.0++  default-language: Haskell2010

@@ -1,4 +1,4 @@-![Haxl Logo](http://github.com/facebook/Haxl/raw/master/logo.png)+![Haxl Logo](https://github.com/facebook/Haxl/raw/master/logo.png)  # Haxl @@ -28,7 +28,7 @@  ## Where to go next? - * *The Story of Haxl* (a blog post to be published very soon!)+ * [The Story of Haxl](https://code.facebook.com/posts/302060973291128/open-sourcing-haxl-a-library-for-haskell/)    explains how Haxl came about at Facebook, and discusses our    particular use case. @@ -44,6 +44,4 @@  * [Haxl Documentation](http://hackage.haskell.org/package/haxl) on    Hackage. - * *There is no Fork: An Abstraction for Efficient, Concurrent, and-   Concise Data Access*, our paper on Haxl, accepted for publication-   at ICFP'14.  Online version coming soon (June 12).+ * [There is no Fork: An Abstraction for Efficient, Concurrent, and Concise Data Access](http://community.haskell.org/~simonmar/papers/haxl-icfp14.pdf), our paper on Haxl, accepted for publication at ICFP'14.

@@ -1,4 +1,6 @@-{-# LANGUAGE RebindableSyntax, OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RebindableSyntax #-} module CoreTests where  import Haxl.Prelude@@ -48,9 +50,32 @@     f <- runHaxl en $          throw (NotFound "haha") `catch` \LogicError{} -> return True     assertBool "catch2" f++    -- test catchIf+    let transientOrNotFound e+          | Just TransientError{} <- fromException e  = True+          | Just NotFound{} <- fromException e  = True+          | otherwise = False++    e <- runHaxl en $+         catchIf transientOrNotFound (throw (NotFound "haha")) $ \_ ->+           return True+    assertBool "catchIf1" e++    e <- runHaxl en $+         catchIf transientOrNotFound (throw (FetchError "haha")) $ \_ ->+           return True+    assertBool "catchIf2" e++    e <- runHaxl en $+           (catchIf transientOrNotFound (throw (CriticalError "haha")) $ \_ ->+              return True)+            `catch` \InternalError{} -> return False+    assertBool "catchIf2" (not e)   where   isLeft Left{} = True   isLeft _ = False+  -- This is mostly a compile test, to make sure all the plumbing -- makes the compiler happy.

@@ -2,7 +2,7 @@ module DataCacheTest (tests) where  import Haxl.Core.DataCache as DataCache-import Haxl.Core.Types+import Haxl.Core  import Control.Exception import Data.Hashable@@ -58,5 +58,15 @@       _something_else -> False  +dcStrictnessTest :: Test+dcStrictnessTest = TestLabel "DataCache strictness" $ TestCase $ do+  env <- initEnv stateEmpty ()+  r <- Control.Exception.try $ runHaxl env $+    cachedComputation (Req (error "BOOM")) $ return "OK"+  assertBool "dcStrictnessTest" $+    case r of+      Left (ErrorCall "BOOM") -> True+      _other -> False+ -- tests :: Assertion-tests = TestList [dcSoundnessTest]+tests = TestList [dcSoundnessTest, dcStrictnessTest]

@@ -24,6 +24,8 @@  import Data.Typeable import Data.Hashable+import Control.Concurrent+import System.IO  -- Here is an example minimal data source.  Our data source will have -- two requests:@@ -134,6 +136,9 @@   putSuccess m 1   error "BANG2" -- the exception is propagated even if we have already                 -- put the result with putSuccess+fetch1 (BlockedFetch (CountAardvarks "BANG3") _) = do+  hPutStr stderr "BANG3"+  killThread =<< myThreadId -- an asynchronous exception fetch1 (BlockedFetch (CountAardvarks str) m) =   putSuccess m (length (filter (== 'a') str)) fetch1 (BlockedFetch (ListWombats a) r) =

@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, RebindableSyntax #-}+{-# LANGUAGE OverloadedStrings, RebindableSyntax, MultiWayIf #-} module TestExampleDataSource (tests) where  import Haxl.Prelude as Haxl@@ -47,12 +47,15 @@   assertEqual "runTests" x (2 + 3)    -- Should be just one fetching round:-  Stats s <- readIORef (statsRef env)-  assertEqual "rounds" 1 (length s)+  Stats stats <- readIORef (statsRef env)+  assertEqual "rounds" 1 (length stats)    -- With two fetches:-  let reqs = case head s of RoundStats m -> HashMap.lookup "ExampleDataSource" m-  assertEqual "reqs" (Just 2) reqs+  assertBool "reqs" $+      if | RoundStats { roundDataSources = m } : _  <- stats,+           Just (DataSourceRoundStats { dataSourceFetches = 2 })+              <- HashMap.lookup "ExampleDataSource" m  -> True+         | otherwise -> False  -- Test side-effect ordering @@ -121,16 +124,30 @@  dataSourceExceptionTest = TestCase $ do   env <- testEnv+   r <- runHaxl env $ Haxl.try $ countAardvarks "BANG"-  assertBool "exception" $+  assertBool "exception1" $     case r of       Left (ErrorCall "BANG") -> True       _ -> False   r <- runHaxl env $ Haxl.try $ countAardvarks "BANG2"-  assertBool "exception" $+  assertBool "exception2" $     case r of       Left (ErrorCall "BANG2") -> True       _ -> False++  -- In this test, BANG3 is an asynchronous exception (ThreadKilled),+  -- so we should see that instead of the exception on the left.+  -- Furthermore, it doesn't get caught by Haxl.try, and we have to+  -- catch it outside of runHaxl.+  env <- testEnv+  r <- Control.Exception.try $ runHaxl env $ Haxl.try $+          (length <$> listWombats 100) + countAardvarks "BANG3"+  print r+  assertBool "exception3" $+    case (r :: Either AsyncException (Either SomeException Int)) of+       Left ThreadKilled -> True+       _ -> False  -- Test that we can load the cache from a dumped copy of it, and then dump it -- again to get the same result.