haxl 0.3.1.0 → 0.4.0.0

raw patch · 16 files changed

+996/−256 lines, 16 filesdep +binarydep +ghc-primdep +test-frameworkdep ~aesondep ~basedep ~filepathnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: binary, ghc-prim, test-framework, test-framework-hunit, transformers

Dependency ranges changed: aeson, base, filepath, time

API changes (from Hackage documentation)

Files

• Haxl/Core.hs +12/−2
• Haxl/Core/DataCache.hs +28/−39
• Haxl/Core/Exception.hs +88/−22
• Haxl/Core/Memo.hs +71/−15
• Haxl/Core/Monad.hs +522/−117
• Haxl/Core/Types.hs +150/−19
• Haxl/Prelude.hs +5/−4
• haxl.cabal +17/−5
• readme.md +3/−1
• tests/BatchTests.hs +11/−0
• tests/DataCacheTest.hs +1/−1
• tests/Main.hs +0/−26
• tests/MonadBench.hs +71/−1
• tests/TestExampleDataSource.hs +6/−3
• tests/TestMain.hs +9/−0
• tests/TestTypes.hs +2/−1

@@ -15,7 +15,7 @@   -- ** Env   Env(..), Caches, caches,   -- *** Operations in the monad-  env, withEnv,+  env, withEnv, withLabel,   -- *** Building the Env   initEnvWithData, initEnv, emptyEnv,   -- *** Building the StateStore@@ -30,7 +30,8 @@   dumpCacheAsHaskell,    -- ** Memoization-  memo, memoFingerprint, MemoFingerprintKey(..),+  memo, memoize, memoize1, memoize2,+  memoFingerprint, MemoFingerprintKey(..),    -- ** Statistics   Stats(..),@@ -43,12 +44,21 @@   ppStats,   ppRoundStats,   ppDataSourceRoundStats,+  Profile,+  emptyProfile,+  profile,+  profileRound,+  profileCache,+  ProfileLabel,+  ProfileData(..),+  emptyProfileData,    -- ** Tracing flags   Flags(..),   defaultFlags,   ifTrace,   ifReport,+  ifProfiling,    -- * Building data sources   DataSource(..),

@@ -14,15 +14,16 @@ -- provided for access to Haxl internals only; most users should not -- need to import it. module Haxl.Core.DataCache-  ( DataCache-  , empty+  ( DataCache(..)+  , SubCache(..)+  , emptyDataCache   , insert   , insertNotShowable+  , insertWithShow   , lookup   , showCache   ) where -import Data.HashMap.Strict (HashMap) import Data.Hashable import Prelude hiding (lookup) import Unsafe.Coerce@@ -30,35 +31,12 @@ import Data.Typeable.Internal import Data.Maybe #if __GLASGOW_HASKELL__ < 710-import Control.Applicative hiding (empty)+import Control.Applicative ((<$>)) #endif import Control.Exception  import Haxl.Core.Types --- | The 'DataCache' maps things of type @f a@ to @'ResultVar' a@, for--- any @f@ and @a@ provided @f a@ is an instance of 'Typeable'. In--- practice @f a@ will be a request type parameterised by its result.------ See the definition of 'ResultVar' for more details.--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 res =-  forall req a . (Hashable (req a), Eq (req a)) =>-       SubCache (req a -> String) (a -> String) ! (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 res-empty = DataCache HashMap.empty- -- | Inserts a request-result pair into the 'DataCache'. insert   :: (Hashable (req a), Typeable (req a), Eq (req a), Show (req a), Show a)@@ -69,10 +47,27 @@   -> DataCache res   -> DataCache res -insert req result (DataCache m) =+insert = insertWithShow show show++-- | Inserts a request-result pair into the 'DataCache', with the given+-- functions used to show the request and result.+insertWithShow+  :: (Hashable (req a), Typeable (req a), Eq (req a))+  => (req a -> String)+  -- ^ Show function for request+  -> (a -> String)+  -- ^ Show function for result+  -> req a+  -- ^ Request+  -> res a+  -- ^ Result+  -> DataCache res+  -> DataCache res++insertWithShow showRequest showResult req result (DataCache m) =   DataCache $     HashMap.insertWith fn (typeOf req)-       (SubCache show show (HashMap.singleton req result)) m+       (SubCache showRequest showResult (HashMap.singleton req result)) m   where     fn (SubCache _ _ new) (SubCache showReq showRes old) =       SubCache showReq showRes (unsafeCoerce new `HashMap.union` old)@@ -89,13 +84,7 @@   -> DataCache res   -> DataCache res -insertNotShowable req result (DataCache m) =-  DataCache $-    HashMap.insertWith fn (typeOf req)-       (SubCache notShowable notShowable (HashMap.singleton req result)) m-  where-    fn (SubCache _ _ new) (SubCache showReq showRes old) =-      SubCache showReq showRes (unsafeCoerce new `HashMap.union` old)+insertNotShowable = insertWithShow notShowable notShowable  notShowable :: a notShowable = error "insertNotShowable"@@ -115,9 +104,9 @@            unsafeCoerce (HashMap.lookup (unsafeCoerce req) sc)  -- | Dumps the contents of the cache, with requests and responses--- converted to 'String's using 'show'.  The entries are grouped by--- 'TypeRep'.  Note that this will fail if 'insertNotShowable' has--- been used to insert any entries.+-- converted to 'String's using the supplied show functions.  The+-- entries are grouped by 'TypeRep'.  Note that this will fail if+-- 'insertNotShowable' has been used to insert any entries. -- showCache   :: DataCache ResultVar

@@ -5,6 +5,7 @@ -- found in the LICENSE file. An additional grant of patent rights can -- be found in the PATENTS file. +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveDataTypeable #-}@@ -40,6 +41,10 @@   logicErrorToException,   logicErrorFromException, +  LogicBug(..),+  logicBugToException,+  logicBugFromException,+   TransientError(..),   transientErrorToException,   transientErrorFromException,@@ -54,21 +59,25 @@   EmptyList(..),   JSONError(..),   InvalidParameter(..),+  MonadFail(..),    -- ** Transient exceptions   FetchError(..),    -- * Exception utilities   asHaxlException,+  MiddleException(..),    ) where  import Control.Exception import Data.Aeson+import Data.Binary (Binary) import Data.Typeable import Data.Text (Text)  import Haxl.Core.Util+import GHC.Stack  -- | We have a 3-tiered hierarchy of exceptions, with 'HaxlException' at -- the top, and all Haxl exceptions as children of this. Users should@@ -78,8 +87,11 @@ -- --   ['InternalError']  Something is wrong with Haxl core. -----   ['LogicError']     Something is wrong with Haxl client code.+--   ['LogicBug']       Something is wrong with Haxl client code. --+--   ['LogicError']     Things that really should be return values, e.g.+--                      NotFound.+-- --   ['TransientError'] Something is temporarily failing (usually in a fetch). -- -- These are not meant to be thrown (but likely be caught). Thrown@@ -88,30 +100,42 @@ -- (generic transient failure) or 'CriticalError' (internal failure). -- data HaxlException-  = forall e. (Exception e, MiddleException e) => HaxlException e+  = forall e. (Exception e, MiddleException e)+    => HaxlException+         (Maybe Stack)  -- filled in with the call stack when thrown,+                        -- if PROFILING is on+         e   deriving (Typeable) +type Stack = [String]+  -- hopefully this will get more informative in the future+ instance Show HaxlException where-  show (HaxlException e) = show e+  show (HaxlException (Just stk@(_:_)) e) = show e ++ '\n' : renderStack stk+  show (HaxlException _ e) = show e  instance Exception HaxlException  -- | These need to be serializable to JSON to cross FFI boundaries. instance ToJSON HaxlException where-  toJSON (HaxlException e) = object-    [ "type" .= show (typeOf e)-    , "name" .= eName e-    , "txt"  .= show e-    ]+  toJSON (HaxlException stk e) = object fields+    where+      fields | Just s@(_:_) <- stk = ("stack" .= reverse s) : rest+             | otherwise = rest+      rest =+        [ "type" .= show (typeOf e)+        , "name" .= eName e+        , "txt"  .= show e+        ]  haxlExceptionToException   :: (Exception e, MiddleException e) => e -> SomeException-haxlExceptionToException = toException . HaxlException+haxlExceptionToException = toException . HaxlException Nothing  haxlExceptionFromException   :: (Exception e, MiddleException e) => SomeException -> Maybe e haxlExceptionFromException x = do-  HaxlException a <- fromException x+  HaxlException _ a <- fromException x   cast a  class (Exception a) => MiddleException a where@@ -183,29 +207,61 @@   LogicError a <- fromException x   cast a +data LogicBug = forall e . (Exception e) => LogicBug e+  deriving (Typeable)++deriving instance Show LogicBug++instance Exception LogicBug where+ toException   = haxlExceptionToException+ fromException = haxlExceptionFromException++instance MiddleException LogicBug where+  eName (LogicBug e) = show $ typeOf e++logicBugToException :: (Exception e) => e -> SomeException+logicBugToException = toException . LogicBug++logicBugFromException+  :: (Exception e) => SomeException -> Maybe e+logicBugFromException x = do+  LogicBug a <- fromException x+  cast a+ ------------------------------------------------------------------------ -- Leaf exceptions. You should throw these. Or make your own. ------------------------------------------------------------------------  -- | Generic \"critical\" exception. Something internal is -- borked. Panic.-data CriticalError = CriticalError Text-  deriving (Typeable, Eq, Show)+newtype CriticalError = CriticalError Text+  deriving (Typeable, Binary, Eq, Show)  instance Exception CriticalError where   toException   = internalErrorToException   fromException = internalErrorFromException +-- | Exceptions that are converted to HaxlException by+-- asHaxlException.  Typically these will be pure exceptions,+-- e.g., the 'error' function in pure code, or a pattern-match+-- failure.+newtype NonHaxlException = NonHaxlException Text+  deriving (Typeable, Binary, Eq, Show)++instance Exception NonHaxlException where+  toException   = internalErrorToException+  fromException = internalErrorFromException+ -- | Generic \"something was not found\" exception.-data NotFound = NotFound Text-  deriving (Typeable, Eq, Show)+newtype NotFound = NotFound Text+  deriving (Typeable, Binary, Eq, Show)  instance Exception NotFound where   toException = logicErrorToException   fromException = logicErrorFromException  -- | Generic \"something had the wrong type\" exception.-data UnexpectedType = UnexpectedType Text+newtype UnexpectedType = UnexpectedType Text   deriving (Typeable, Eq, Show)  instance Exception UnexpectedType where@@ -213,15 +269,16 @@   fromException = logicErrorFromException  -- | Generic \"input list was empty\" exception.-data EmptyList = EmptyList Text+newtype EmptyList = EmptyList Text   deriving (Typeable, Eq, Show)  instance Exception EmptyList where   toException = logicErrorToException   fromException = logicErrorFromException+  -- TODO: should be a child of LogicBug  -- | Generic \"Incorrect assumptions about JSON data\" exception.-data JSONError = JSONError Text+newtype JSONError = JSONError Text   deriving (Typeable, Eq, Show)  instance Exception JSONError where@@ -229,15 +286,24 @@   fromException = logicErrorFromException  -- | Generic \"passing some invalid parameter\" exception.-data InvalidParameter = InvalidParameter Text+newtype InvalidParameter = InvalidParameter Text   deriving (Typeable, Eq, Show)  instance Exception InvalidParameter where   toException = logicErrorToException   fromException = logicErrorFromException+  -- TODO: should be a child of LogicBug +-- | Generic \"fail was called\" exception.+newtype MonadFail = MonadFail Text+  deriving (Typeable, Eq, Show)++instance Exception MonadFail where+  toException = logicErrorToException+  fromException = logicErrorFromException+ -- | Generic transient fetching exceptions.-data FetchError = FetchError Text+newtype FetchError = FetchError Text   deriving (Typeable, Eq, Show)  instance Exception FetchError where@@ -245,7 +311,7 @@   fromException = transientErrorFromException  -- | A data source did something wrong-data DataSourceError = DataSourceError Text+newtype DataSourceError = DataSourceError Text   deriving (Typeable, Eq, Show)  instance Exception DataSourceError where@@ -253,10 +319,10 @@   fromException = internalErrorFromException  -- | Converts all exceptions that are not derived from 'HaxlException'--- into 'CriticalError', using 'show'.+-- into 'NonHaxlException', using 'show'. asHaxlException :: SomeException -> HaxlException asHaxlException e   | Just haxl_exception <- fromException e = -- it's a HaxlException      haxl_exception   | otherwise =-     HaxlException (InternalError (CriticalError (textShow e)))+     HaxlException Nothing (InternalError (NonHaxlException (textShow e)))

@@ -5,20 +5,34 @@ -- found in the LICENSE file. An additional grant of patent rights can -- be found in the PATENTS file. -{-# LANGUAGE DeriveDataTypeable, GADTs, OverloadedStrings,-    StandaloneDeriving #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}  -- | Most users should import "Haxl.Core" instead of importing this -- module directly.-module Haxl.Core.Memo (memo, memoFingerprint, MemoFingerprintKey(..)) where+module Haxl.Core.Memo (+  memo,+  memoFingerprint,+  MemoFingerprintKey(..),+  memoize, memoize1, memoize2+) where +#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+#endif import Data.Text (Text) import Data.Typeable import Data.Hashable import Data.Word -import Haxl.Core.Monad (GenHaxl, cachedComputation)+import GHC.Prim (Addr#) +import Haxl.Core.Monad+ -- ----------------------------------------------------------------------------- -- A key type that can be used for memoizing computations by a Text key @@ -55,39 +69,81 @@   deriving Typeable  deriving instance Eq (MemoTextKey a)-deriving instance Show (MemoTextKey a)  instance Hashable (MemoTextKey a) where   hashWithSalt s (MemoText t) = hashWithSalt s t  memoText :: (Typeable a) => Text -> GenHaxl u a -> GenHaxl u a-memoText key = cachedComputation (MemoText key)+memoText key = withLabel key . cachedComputation (MemoText key)  -- | A memo key derived from a 128-bit MD5 hash.  Do not use this directly, -- it is for use by automatically-generated memoization.- data MemoFingerprintKey a where   MemoFingerprintKey     :: {-# UNPACK #-} !Word64-    -> {-# UNPACK #-} !Word64  -> MemoFingerprintKey a+    -> {-# UNPACK #-} !Word64+    -> Addr# -> Addr#+    -> MemoFingerprintKey a   deriving Typeable  deriving instance Eq (MemoFingerprintKey a)-deriving instance Show (MemoFingerprintKey a)  instance Hashable (MemoFingerprintKey a) where-  hashWithSalt s (MemoFingerprintKey x _) =+  hashWithSalt s (MemoFingerprintKey x _ _ _) =     hashWithSalt s (fromIntegral x :: Int)  -- This is optimised for cheap call sites: when we have a call -----   memoFingerprint (MemoFingerprintKey 1234 5678) e+--   memoFingerprint (MemoFingerprintKey 1234 5678 "module"# "name"#) e -- -- then the MemoFingerprintKey constructor will be statically--- allocated (with two 64-bit fields), and shared by all calls to--- memo.  So the memo call will not allocate, unlike memoText.+-- allocated (with two 64-bit fields and pointers to cstrings for the names),+-- and shared by all calls to memo. So the memo call will not allocate,+-- unlike memoText. -- {-# NOINLINE memoFingerprint #-} memoFingerprint-   :: (Show a, Typeable a) => MemoFingerprintKey a -> GenHaxl u a -> GenHaxl u a-memoFingerprint key = cachedComputation key+  :: Typeable a => MemoFingerprintKey a -> GenHaxl u a -> GenHaxl u a+memoFingerprint key@(MemoFingerprintKey _ _ mnPtr nPtr) =+  withFingerprintLabel mnPtr nPtr . cachedComputation key++-- * Generic memoization machinery.++-- | Transform a Haxl computation into a memoized version of itself.+--+-- Given a Haxl computation, @memoize@ creates a version which stores its result+-- in a @MemoVar@ (which @memoize@ creates), and returns the stored result on+-- subsequent invocations. This permits the creation of local memos, whose+-- lifetimes are scoped to the current function, rather than the entire request.+memoize :: GenHaxl u a -> GenHaxl u a+memoize a = newMemoWith a >>= runMemo++-- | Transform a 1-argument function returning a Haxl computation into a+-- memoized version of itself.+--+-- Given a function @f@ of type @a -> GenHaxl u b@, @memoize1@ creates a version+-- which memoizes the results of @f@ in a table keyed by its argument, and+-- returns stored results on subsequent invocations with the same argument.+--+-- e.g.:+--+-- allFriends :: [Int] -> GenHaxl u [Int]+-- allFriends ids = do+--   memoizedFriendsOf <- memoize1 friendsOf+--   concat <$> mapM memoizeFriendsOf ids+--+-- The above implementation will not invoke the underlying @friendsOf@+-- repeatedly for duplicate values in @ids@.+memoize1 :: (Eq a, Hashable a)+         => (a -> GenHaxl u b)+         -> GenHaxl u (a -> GenHaxl u b)+memoize1 f = runMemo1 <$> newMemoWith1 f++-- | Transform a 2-argument function returning a Haxl computation, into a+-- memoized version of itself.+--+-- The 2-ary version of @memoize1@, see its documentation for details.+memoize2 :: (Eq a, Hashable a, Eq b, Hashable b)+         => (a -> b -> GenHaxl u c)+         -> GenHaxl u (a -> b -> GenHaxl u c)+memoize2 f = runMemo2 <$> newMemoWith2 f

@@ -5,23 +5,28 @@ -- found in the LICENSE file. An additional grant of patent rights can -- be found in the PATENTS file. -{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}  -- | The implementation of the 'Haxl' monad.  Most users should -- import "Haxl.Core" instead of importing this module directly. module Haxl.Core.Monad (     -- * The monad     GenHaxl (..), runHaxl,-    env, withEnv,+    env, withEnv, withLabel, withFingerprintLabel,      -- * Env     Env(..), Caches, caches, initEnvWithData, initEnv, emptyEnv,@@ -30,10 +35,16 @@     throw, catch, catchIf, try, tryToHaxlException,      -- * Data fetching and caching-    dataFetch, uncachedRequest,-    cacheRequest, cacheResult, cachedComputation,-    dumpCacheAsHaskell,+    ShowReq, dataFetch, dataFetchWithShow, uncachedRequest, cacheRequest,+    cacheResult, cacheResultWithShow, cachedComputation,+    dumpCacheAsHaskell, dumpCacheAsHaskellFn, +    -- * Memoization Machinery+    newMemo, newMemoWith, prepareMemo, runMemo,++    newMemo1, newMemoWith1, prepareMemo1, runMemo1,+    newMemo2, newMemoWith2, prepareMemo2, runMemo2,+     -- * Unsafe operations     unsafeLiftIO, unsafeToHaxlException,   ) where@@ -54,6 +65,7 @@ #endif #if __GLASGOW_HASKELL__ >= 710 import Control.Exception (AllocationLimitExceeded(..))+import GHC.Conc (getAllocationCounter, setAllocationCounter) #endif import Control.Monad import qualified Control.Exception as Exception@@ -61,35 +73,59 @@ import Control.Applicative hiding (Const) #endif import Control.DeepSeq-import GHC.Exts (IsString(..))+import GHC.Exts (IsString(..), Addr#) #if __GLASGOW_HASKELL__ < 706 import Prelude hiding (catch) #endif+import Data.Functor.Constant import Data.Hashable+import qualified Data.HashMap.Strict as HashMap+import qualified Data.HashSet as HashSet import Data.IORef import Data.List+import qualified Data.Map as Map import Data.Monoid import Data.Time import Data.Typeable-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 +#ifdef PROFILING+import GHC.Stack+#endif++#if __GLASGOW_HASKELL__ < 710+import Data.Int (Int64)++getAllocationCounter :: IO Int64+getAllocationCounter = return 0++setAllocationCounter :: Int64 -> IO ()+setAllocationCounter _ = return ()+#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+  { cacheRef     :: {-# UNPACK #-} !(IORef (DataCache ResultVar))+                     -- cached data fetches+  , memoRef      :: {-# UNPACK #-} !(IORef (DataCache (MemoVar u)))+                     -- memoized computations+  , flags        :: !Flags+                     -- conservatively not unpacking, because this is passed+                     -- to 'fetch' and would need to be rebuilt.   , userEnv      :: u-  , statsRef     :: IORef Stats+  , statsRef     :: {-# UNPACK #-} !(IORef Stats)+  , profLabel    :: ProfileLabel+  , profRef      :: {-# UNPACK #-} !(IORef Profile)   , states       :: StateStore   -- ^ Data sources and other components can store their state in   -- here. Items in this store must be instances of 'StateKey'.@@ -105,6 +141,7 @@ initEnvWithData :: StateStore -> u -> Caches u -> IO (Env u) initEnvWithData states e (cref, mref) = do   sref <- newIORef emptyStats+  pref <- newIORef emptyProfile   return Env     { cacheRef = cref     , memoRef = mref@@ -112,13 +149,15 @@     , userEnv = e     , states = states     , statsRef = sref+    , profLabel = "MAIN"+    , profRef = pref     }  -- | Initializes an environment with 'StateStore' and an input map. initEnv :: StateStore -> u -> IO (Env u) initEnv states e = do-  cref <- newIORef DataCache.empty-  mref <- newIORef DataCache.empty+  cref <- newIORef emptyDataCache+  mref <- newIORef emptyDataCache   initEnvWithData states e (cref,mref)  -- | A new, empty environment.@@ -144,6 +183,7 @@ -- newtype GenHaxl u a = GenHaxl   { unHaxl :: Env u -> IORef (RequestStore u) -> IO (Result u a) }+  deriving NFData  -- | The result of a computation is either 'Done' with a value, 'Throw' -- with an exception, or 'Blocked' on the result of a data fetch with@@ -204,6 +244,8 @@       Done a       -> unHaxl (k a) env ref       Throw e      -> return (Throw e)       Blocked cont -> return (Blocked (cont :>>= k))+  fail msg = GenHaxl $ \_env _ref ->+    return $ Throw $ toException $ MonadFail $ Text.pack msg    -- We really want the Applicative version of >>   (>>) = (*>)@@ -242,7 +284,7 @@   let go !n env c = do         traceEventIO "START computation"         ref <- newIORef noRequests-        e <- toHaxl c env ref+        e <- (unHaxl $ toHaxl c) env ref         traceEventIO "STOP computation"         case e of           Done a       -> return a@@ -253,6 +295,8 @@             traceEventIO "START performFetches"             n' <- performFetches n env bs             traceEventIO "STOP performFetches"+            when (caching (flags env) == 0) $+              writeIORef (cacheRef env) DataCache.empty             go n' env cont   traceEventIO "START runHaxl"   r <- go 0 env (Cont h)@@ -269,6 +313,8 @@       bs <- readIORef ref       writeIORef ref noRequests -- Note [RoundId]       void (performFetches 0 env bs)+      when (caching (flags env) == 0) $+        writeIORef (cacheRef env) emptyDataCache       runHaxl env (toHaxl cont) #endif @@ -286,6 +332,72 @@     Throw e -> return (Throw e)     Blocked k -> return (Blocked (Cont (withEnv newEnv (toHaxl k)))) +-- | Label a computation so profiling data is attributed to the label.+withLabel :: ProfileLabel -> GenHaxl u a -> GenHaxl u a+withLabel l (GenHaxl m) = GenHaxl $ \env ref ->+  if report (flags env) < 4+     then m env ref+     else collectProfileData l m env ref++-- | Label a computation so profiling data is attributed to the label.+-- Intended only for internal use by 'memoFingerprint'.+withFingerprintLabel :: Addr# -> Addr# -> GenHaxl u a -> GenHaxl u a+withFingerprintLabel mnPtr nPtr (GenHaxl m) = GenHaxl $ \env ref ->+  if report (flags env) < 4+     then m env ref+     else collectProfileData+            (Text.unpackCString# mnPtr <> "." <> Text.unpackCString# nPtr)+            m env ref++-- | Collect profiling data and attribute it to given label.+collectProfileData+  :: ProfileLabel+  -> (Env u -> IORef (RequestStore u) -> IO (Result u a))+  -> Env u -> IORef (RequestStore u)+  -> IO (Result u a)+collectProfileData l m env ref = do+   a0 <- getAllocationCounter+   r <- m env{profLabel=l} ref -- what if it throws?+   a1 <- getAllocationCounter+   modifyProfileData env l (a0 - a1)+   -- 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 k -> return (Blocked (Cont (withLabel l (toHaxl k))))+{-# INLINE collectProfileData #-}++modifyProfileData :: Env u -> ProfileLabel -> AllocCount -> IO ()+modifyProfileData env label allocs =+  modifyIORef' (profRef env) $ \ p ->+    p { profile =+          HashMap.insertWith updEntry label newEntry .+          HashMap.insertWith updCaller caller newCaller $+          profile p }+  where caller = profLabel env+        newEntry =+          emptyProfileData+            { profileAllocs = allocs+            , profileDeps = HashSet.singleton caller }+        updEntry _ old =+          old { profileAllocs = profileAllocs old + allocs+              , profileDeps = HashSet.insert caller (profileDeps old) }+        -- subtract allocs from caller, so they are not double counted+        -- we don't know the caller's caller, but it will get set on+        -- the way back out, so an empty hashset is fine for now+        newCaller =+          emptyProfileData { profileAllocs = -allocs }+        updCaller _ old =+          old { profileAllocs = profileAllocs old - allocs }++incrementMemoHitCounterFor :: ProfileLabel -> Profile -> Profile+incrementMemoHitCounterFor lbl p =+  p { profile = HashMap.adjust incrementMemoHitCounter lbl (profile p) }++incrementMemoHitCounter :: ProfileData -> ProfileData+incrementMemoHitCounter pd = pd { profileMemoHits = succ (profileMemoHits pd) }+ -- ----------------------------------------------------------------------------- -- Exceptions @@ -294,7 +406,16 @@ throw e = GenHaxl $ \_env _ref -> raise e  raise :: (Exception e) => e -> IO (Result u a)-raise = return . Throw . toException+raise e+#ifdef PROFILING+  | Just (HaxlException Nothing h) <- fromException somex = do+    stk <- currentCallStack+    return (Throw (toException (HaxlException (Just stk) h)))+  | otherwise+#endif+    = return (Throw somex)+  where+    somex = toException e  -- | Catch an exception in the Haxl monad catch :: Exception e => GenHaxl u a -> (e -> GenHaxl u a) -> GenHaxl u a@@ -367,16 +488,37 @@   | 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)+cached :: Request r a => Env u -> r a -> IO (CacheResult a)+cached = cachedWithInsert show DataCache.insert++-- | Show functions for request and its result.+type ShowReq r a = (r a -> String, a -> String)++-- Note [showFn]+--+-- Occasionally, for tracing purposes or generating exceptions, we need to+-- call 'show' on the request in a place where we *cannot* have a Show+-- dictionary. (Because the function is a worker which is called by one of+-- the *WithShow variants that take explicit show functions via a ShowReq+-- argument.) None of the functions that does this is exported, so this is+-- hidden from the Haxl user.++-- | Checks the data cache for the result of a request, inserting new results+-- with the given function.+cachedWithInsert+  :: Typeable (r a)+  => (r a -> String)    -- See Note [showFn]+  -> (r a -> ResultVar a -> DataCache ResultVar -> DataCache ResultVar) -> Env u+  -> r a -> IO (CacheResult a)+cachedWithInsert showFn insertFn env req = do   let-    do_fetch = do+    doFetch insertFn request cache = do       rvar <- newEmptyResult-      writeIORef (cacheRef env) $! DataCache.insert req rvar cache+      writeIORef (cacheRef env) $! insertFn request rvar cache       return (Uncached rvar)+  cache <- readIORef (cacheRef env)   case DataCache.lookup req cache of-    Nothing -> do_fetch+    Nothing -> doFetch insertFn req cache     Just rvar -> do       mb <- tryReadResult rvar       case mb of@@ -384,31 +526,94 @@         -- 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+            Left _ -> "Cached error: " ++ showFn req+            Right _ -> "Cached request: " ++ showFn req           return (Cached r) +-- | Record the call stack for a data fetch in the Stats.  Only useful+-- when profiling.+logFetch :: Env u -> (r a -> String) -> r a -> IO ()+#ifdef PROFILING+logFetch env showFn req = do+  ifReport (flags env) 5 $ do+    stack <- currentCallStack+    modifyIORef' (statsRef env) $ \(Stats s) ->+      Stats (FetchCall (showFn req) stack : s)+#else+logFetch _ _ _ = return ()+#endif+ -- | Performs actual fetching of data for a 'Request' from a 'DataSource'. dataFetch :: (DataSource u r, Request r a) => r a -> GenHaxl u a-dataFetch req = GenHaxl $ \env ref -> do+dataFetch = dataFetchWithInsert show DataCache.insert++-- | Performs actual fetching of data for a 'Request' from a 'DataSource', using+-- the given show functions for requests and their results.+dataFetchWithShow+  :: (DataSource u r, Eq (r a), Hashable (r a), Typeable (r a))+  => ShowReq r a+  -> r a -> GenHaxl u a+dataFetchWithShow (showReq, showRes) = dataFetchWithInsert showReq+  (DataCache.insertWithShow showReq showRes)++-- | Performs actual fetching of data for a 'Request' from a 'DataSource', using+-- the given function to insert requests in the cache.+dataFetchWithInsert+  :: (DataSource u r, Eq (r a), Hashable (r a), Typeable (r a))+  => (r a -> String)    -- See Note [showFn]+  -> (r a -> ResultVar a -> DataCache ResultVar -> DataCache ResultVar)+  -> r a+  -> GenHaxl u a+dataFetchWithInsert showFn insertFn req = GenHaxl $ \env ref -> do   -- First, check the cache-  res <- cached env req+  res <- cachedWithInsert showFn insertFn env req+  ifProfiling (flags env) $ addProfileFetch env req   case res of     -- Not seen before: add the request to the RequestStore, so it     -- will be fetched in the next round.     Uncached rvar -> do+      logFetch env showFn req       modifyIORef' ref $ \bs -> addRequest (BlockedFetch req rvar) bs-      return $ Blocked (Cont (continueFetch req rvar))+      return $ Blocked (Cont (continueFetch showFn req rvar))      -- Seen before but not fetched yet.  We're blocked, but we don't have     -- to add the request to the RequestStore.-    CachedNotFetched rvar -> return-      $ Blocked (Cont (continueFetch req rvar))+    CachedNotFetched rvar ->+      return (Blocked (Cont (continueFetch showFn req rvar)))      -- Cached: either a result, or an exception     Cached (Left ex) -> return (Throw ex)     Cached (Right a) -> return (Done a) +{-# NOINLINE addProfileFetch #-}+addProfileFetch+  :: (DataSourceName r, Eq (r a), Hashable (r a), Typeable (r a))+  => Env u -> r a -> IO ()+addProfileFetch env req = do+  c <- getAllocationCounter+  modifyIORef' (profRef env) $ \ p ->+    let+      dsName :: Text.Text+      dsName = dataSourceName req++      upd :: Round -> ProfileData -> ProfileData+      upd round d =+        d { profileFetches = Map.alter (Just . f) round (profileFetches d) }++      f Nothing   = HashMap.singleton dsName 1+      f (Just hm) = HashMap.insertWith (+) dsName 1 hm+    in case DataCache.lookup req (profileCache p) of+        Nothing ->+          let r = profileRound p+          in p { profile = HashMap.adjust (upd r) (profLabel env) (profile p)+               , profileCache =+                  DataCache.insertNotShowable req (Constant r) (profileCache p)+               }+        Just (Constant r) ->+          p { profile = HashMap.adjust (upd r) (profLabel env) (profile p) }+  -- So we do not count the allocation overhead of addProfileFetch+  setAllocationCounter c+ -- | A data request that is not cached.  This is not what you want for -- normal read requests, because then multiple identical requests may -- return different results, and this invalidates some of the@@ -420,20 +625,20 @@ -- are done in a safe way - that is, not mixed with reads that might -- conflict in the same Haxl computation. ---uncachedRequest :: (DataSource u r, Request r a) => r a -> GenHaxl u a+uncachedRequest :: (DataSource u r, Show (r a)) => r a -> GenHaxl u a uncachedRequest req = GenHaxl $ \_env ref -> do   rvar <- newEmptyResult   modifyIORef' ref $ \bs -> addRequest (BlockedFetch req rvar) bs-  return $ Blocked (Cont (continueFetch req rvar))+  return $ Blocked (Cont (continueFetch show req rvar))  continueFetch-  :: (DataSource u r, Request r a, Show a)-  => r a -> ResultVar a -> GenHaxl u a-continueFetch req rvar = GenHaxl $ \_env _ref -> do+  :: (r a -> String)    -- See Note [showFn]+  -> r a -> ResultVar a -> GenHaxl u a+continueFetch showFn req rvar = GenHaxl $ \_env _ref -> do   m <- tryReadResult rvar   case m of     Nothing -> raise . DataSourceError $-      textShow req <> " did not set contents of result var"+      Text.pack (showFn req) <> " did not set contents of result var"     Just r -> done r  -- | Transparently provides caching. Useful for datasources that can@@ -441,9 +646,26 @@ -- 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+cacheResult :: Request r a => r a -> IO a -> GenHaxl u a+cacheResult = cacheResultWithInsert show DataCache.insert++-- | Transparently provides caching in the same way as 'cacheResult', but uses+-- the given functions to show requests and their results.+cacheResultWithShow+  :: (Eq (r a), Hashable (r a), Typeable (r a))+  => ShowReq r a -> r a -> IO a -> GenHaxl u a+cacheResultWithShow (showReq, showRes) = cacheResultWithInsert showReq+  (DataCache.insertWithShow showReq showRes)++-- Transparently provides caching, using the given function to insert requests+-- into the cache.+cacheResultWithInsert+  :: Typeable (r a)+  => (r a -> String)    -- See Note [showFn]+  -> (r a -> ResultVar a -> DataCache ResultVar -> DataCache ResultVar) -> r a+  -> IO a -> GenHaxl u a+cacheResultWithInsert showFn insertFn req val = GenHaxl $ \env _ref -> do+  cachedResult <- cachedWithInsert showFn insertFn env req   case cachedResult of     Uncached rvar -> do       result <- Exception.try val@@ -455,14 +677,13 @@     CachedNotFetched _ -> corruptCache   where     corruptCache = raise . DataSourceError $ Text.concat-      [ textShow req+      [ Text.pack (showFn req)       , " has a corrupted cache value: these requests are meant to"       , " return immediately without an intermediate value. Either"       , " the cache was updated incorrectly, or you're calling"       , " 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@@ -510,7 +731,7 @@ -- deterministic. -- cacheRequest-  :: (Request req a) => req a -> Either SomeException a -> GenHaxl u ()+  :: Request req a => req a -> Either SomeException a -> GenHaxl u () cacheRequest request result = GenHaxl $ \env _ref -> do   res <- cached env request   case res of@@ -539,6 +760,7 @@       !n' = n + length jobs    t0 <- getCurrentTime+  a0 <- getAllocationCounter    let     roundstats =@@ -573,32 +795,52 @@    fetches <- mapM applyFetch $ zip [n..] jobs -  times <-+  deepStats <-     if report f >= 2     then do-      (refs, timedfetches) <- mapAndUnzipM wrapFetchInTimer fetches+      (refs, timedfetches) <- mapAndUnzipM wrapFetchInStats fetches       scheduleFetches timedfetches       mapM (fmap Just . readIORef) refs     else do       scheduleFetches fetches       return $ repeat Nothing +  failures <-+    if report f >= 3+    then+      forM jobs $ \(BlockedFetches reqs) ->+        fmap (Just . length) . flip filterM reqs $ \(BlockedFetch _ rvar) -> do+          mb <- tryReadResult rvar+          return $ case mb of+            Just (Right _) -> False+            _ -> True+    else return $ repeat Nothing+   let dsroundstats = HashMap.fromList-         [ (name, DataSourceRoundStats { dataSourceFetches = fetches-                                       , dataSourceTime = time+         [ (name, DataSourceRoundStats { dataSourceFetches = dsfetch+                                       , dataSourceTime = fst <$> dsStats+                                       , dataSourceAllocation = snd <$> dsStats+                                       , dataSourceFailures = dsfailure                                        })-         | ((name, fetches), time) <- zip roundstats times]+         | ((name, dsfetch), dsStats, dsfailure) <-+             zip3 roundstats deepStats failures] +  a1 <- getAllocationCounter   t1 <- getCurrentTime-  let roundtime = realToFrac (diffUTCTime t1 t0) :: Double+  let+    roundtime = realToFrac (diffUTCTime t1 t0) :: Double+    allocation = fromIntegral $ a0 - a1    ifReport f 1 $     modifyIORef' sref $ \(Stats rounds) -> roundstats `deepseq`-      Stats (RoundStats (microsecs roundtime) dsroundstats: rounds)+      Stats (RoundStats (microsecs roundtime) allocation dsroundstats: rounds)    ifTrace f 1 $     printf "Batch data fetch done (%.2fs)\n" (realToFrac roundtime :: Double) +  ifProfiling f $+    modifyIORef' (profRef env) $ \ p -> p { profileRound = 1 + profileRound p }+   return n'  -- Catch exceptions arising from the data source and stuff them into@@ -625,17 +867,24 @@       void $ tryTakeResult rvar       putResult rvar (except e) -wrapFetchInTimer :: PerformFetch -> IO (IORef Microseconds, PerformFetch)-wrapFetchInTimer f = do-  r <- newIORef 0+wrapFetchInStats :: PerformFetch -> IO (IORef (Microseconds, Int), PerformFetch)+wrapFetchInStats f = do+  r <- newIORef (0, 0)   case f of-    SyncFetch io -> return (r, SyncFetch (time io >>= writeIORef r))+    SyncFetch io -> return (r, SyncFetch (statsForIO io >>= writeIORef r))     AsyncFetch f -> do-       inner_r <- newIORef 0+       inner_r <- newIORef (0, 0)        return (r, AsyncFetch $ \inner -> do-         total <- time (f (time inner >>= writeIORef inner_r))-         inner_t <- readIORef inner_r-         writeIORef r (total - inner_t))+         (totalTime, totalAlloc) <-+           statsForIO (f (statsForIO inner >>= writeIORef inner_r))+         (innerTime, innerAlloc) <- readIORef inner_r+         writeIORef r (totalTime - innerTime, totalAlloc - innerAlloc))+  where+    statsForIO io = do+      prevAlloc <- getAllocationCounter+      t <- time io+      postAlloc <- getAllocationCounter+      return (t, fromIntegral $ prevAlloc - postAlloc)  wrapFetchInTrace :: Int -> Int -> Text.Text -> PerformFetch -> PerformFetch #ifdef EVENTLOG@@ -680,19 +929,47 @@ -- ----------------------------------------------------------------------------- -- Memoization --- | A variable in the cache representing the state of a memoized computation+-- | Variables representing memoized computations. newtype MemoVar u a = MemoVar (IORef (MemoStatus u a))+newtype MemoVar1 u a b = MemoVar1 (IORef (MemoStatus1 u a b))+newtype MemoVar2 u a b c = MemoVar2 (IORef (MemoStatus2 u a b c))  -- | The state of a memoized computation data MemoStatus u a+  -- | Memoized computation under evaluation. The memo was last evaluated during+  -- the given round, or never, if the given round is Nothing. The continuation+  -- might be slightly out of date, but that's fine; the worst that can happen+  -- is we do a little extra work.   = 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.++  -- | A fully evaluated memo; here is the result.   | MemoDone (Either SomeException a)-      -- fully evaluated, here is the result. +  -- | A new memo, with a stored computation. Not empty, but has not been run+  -- yet.+  | MemoNew (GenHaxl u a)++  -- | An empty memo, should not be run before preparation.+  | MemoEmpty++-- | The state of a memoized 1-argument function.+data MemoStatus1 u a b+  -- | An unprepared memo.+  = MemoEmpty1+  -- | A memo-table containing @MemoStatus@es for at least one in-progress memo.+  | MemoTbl1 ( a -> GenHaxl u b+             , HashMap.HashMap a+               (MemoVar u b))++data MemoStatus2 u a b c+  -- | An unprepared memo.+  = MemoEmpty2+  -- | A memo-table containing @MemoStatus@es for at least one in-progress memo.+  | MemoTbl2 ( a -> b -> GenHaxl u c+             , HashMap.HashMap a+               (HashMap.HashMap b+                 (MemoVar u c)))+ type RoundId u = IORef (RequestStore u) {- Note [RoundId]@@ -713,66 +990,28 @@ -- cachedComputation    :: forall req u a.-      (Eq (req a)+      ( Eq (req a)       , Hashable (req a)       , Typeable (req a))    => req a -> GenHaxl u a -> GenHaxl u a--cachedComputation req haxl = GenHaxl $ \env ref -> do-  cache <- readIORef (memoRef env)-  case DataCache.lookup req cache of-    Nothing -> do-      memovar <- newIORef (MemoInProgress ref haxl)-      writeIORef (memoRef env) $!-        DataCache.insertNotShowable 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 (Cont (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"))--  -- 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 (toHaxl cont))-        return (Blocked (Cont (retryMemo req)))--  -- We're finished: store the final result-  complete memovar r = do-    writeIORef memovar (MemoDone r)-    done r+cachedComputation req haxl = do+  env <- env id+  cache <- unsafeLiftIO $ readIORef (memoRef env)+  unsafeLiftIO $ ifProfiling (flags env) $+    modifyIORef' (profRef env) (incrementMemoHitCounterFor (profLabel env))+  memoVar <- case DataCache.lookup req cache of+               Nothing -> do+                 memoVar <- newMemoWith haxl+                 unsafeLiftIO $ writeIORef (memoRef env) $!+                   DataCache.insertNotShowable req memoVar cache+                 return memoVar+               Just memoVar -> return memoVar+  runMemo memoVar  -- | 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@@ -785,7 +1024,14 @@ -- >   cacheRequest (CountAardvarks "abcabc") (Right (2)) -- dumpCacheAsHaskell :: GenHaxl u String-dumpCacheAsHaskell = do+dumpCacheAsHaskell = dumpCacheAsHaskellFn "loadCache" "GenHaxl u ()"++-- | Dump the contents of the cache as Haskell code that, when+-- compiled and run, will recreate the same cache contents.+--+-- Takes the name and type for the resulting function as arguments.+dumpCacheAsHaskellFn :: String -> String -> GenHaxl u String+dumpCacheAsHaskellFn fnName fnType = do   ref <- env cacheRef  -- NB. cacheRef, not memoRef.  We ignore memoized                        -- results when dumping the cache.   entries <- unsafeLiftIO $ readIORef ref >>= showCache@@ -796,7 +1042,166 @@     result (Right s) = text "Right" <+> parens (text s)    return $ show $-    text "loadCache :: GenHaxl u ()" $$-    text "loadCache = do" $$+    text (fnName ++ " :: " ++ fnType) $$+    text (fnName ++ " = do") $$       nest 2 (vcat (map mk_cr (concatMap snd entries))) $$     text "" -- final newline++-- | Create a new @MemoVar@ for storing a memoized computation. The created+-- @MemoVar@ is initially empty, not tied to any specific computation. Running+-- this memo (with @runMemo@) without preparing it first (with @prepareMemo@)+-- will result in an exception.+newMemo :: GenHaxl u (MemoVar u a)+newMemo = unsafeLiftIO $ MemoVar <$> newIORef MemoEmpty++-- | Store a computation within a supplied @MemoVar@. Any memo stored within the+-- @MemoVar@ already (regardless of completion) will be discarded, in favor of+-- the supplied computation. A @MemoVar@ must be prepared before it is run.+prepareMemo :: MemoVar u a -> GenHaxl u a -> GenHaxl u ()+prepareMemo (MemoVar memoRef) memoCmp+  = unsafeLiftIO $ writeIORef memoRef (MemoNew memoCmp)++-- | Convenience function, combines @newMemo@ and @prepareMemo@.+newMemoWith :: GenHaxl u a -> GenHaxl u (MemoVar u a)+newMemoWith memoCmp = do+  memoVar <- newMemo+  prepareMemo memoVar memoCmp+  return memoVar++-- | Continue the memoized computation within a given @MemoVar@.+-- Notes:+--+--   1. If the memo contains a complete result, return that result.+--   2. If the memo contains an in-progress computation, continue it as far as+--      possible for this round.+--   3. If the memo is empty (it was not prepared), throw an error.+--+-- For example, to memoize the computation @one@ given by:+--+-- > one :: Haxl Int+-- > one = return 1+--+-- use:+--+-- > do+-- >   oneMemo <- newMemoWith one+-- >   let memoizedOne = runMemo aMemo one+-- >   oneResult <- memoizedOne+--+-- To memoize mutually dependent computations such as in:+--+-- > h :: Haxl Int+-- > h = do+-- >   a <- f+-- >   b <- g+-- >   return (a + b)+-- >  where+-- >   f = return 42+-- >   g = succ <$> f+--+-- without needing to reorder them, use:+--+-- > h :: Haxl Int+-- > h = do+-- >   fMemoRef <- newMemo+-- >   gMemoRef <- newMemo+-- >+-- >   let f = runMemo fMemoRef+-- >       g = runMemo gMemoRef+-- >+-- >   prepareMemo fMemoRef $ return 42+-- >   prepareMemo gMemoRef $ succ <$> f+-- >+-- >   a <- f+-- >   b <- g+-- >   return (a + b)+--+runMemo :: MemoVar u a -> GenHaxl u a+runMemo memoVar@(MemoVar memoRef) = GenHaxl $ \env rID ->+  readIORef memoRef >>= \case+    -- Memo was not prepared first; throw an exception.+    MemoEmpty -> raise $ CriticalError "Attempting to run empty memo."+    -- The memo is complete.+    MemoDone result -> done result+    -- Memo has just been prepared, run it.+    MemoNew cont -> runContToMemo cont env rID+    -- The memo is in progress, there *may* be progress to be made.+    MemoInProgress rID' cont+      -- The last update was performed *this* round and is still in progress;+      -- nothing further can be done this round. Wait until the next round.+      | rID' == rID -> return (Blocked $ Cont retryMemo)+      -- This is the first time this memo is being run during this round, or+      -- at all. Enough progress may have been made to continue running the+      -- memo.+      | otherwise -> runContToMemo cont env rID+ where+  -- Continuation to retry an existing memo. It is not possible to *retry* an+  -- empty memo; that will throw an exception during the next round.+  retryMemo = runMemo memoVar++  -- Run a continuation, and store the result in the memo reference. Any+  -- exceptions thrown during the running of the memo are thrown directly; they+  -- are also stored in the memoVar just in case, but we shouldn't be looking at+  -- the memoVar again anyway.+  --+  -- If the memo is incomplete by the end of this round, update its progress+  -- indicator and block.+  runContToMemo cont env rID = do+    result <- unHaxl cont env rID+    case result of+      Done a -> finalize (Right a)+      Throw e -> finalize (Left e)+      Blocked c -> do+        writeIORef memoRef (MemoInProgress rID (toHaxl c))+        return (Blocked $ Cont retryMemo)++  finalize r = writeIORef memoRef (MemoDone r) >> done r++newMemo1 :: GenHaxl u (MemoVar1 u a b)+newMemo1 = unsafeLiftIO $ MemoVar1 <$> newIORef MemoEmpty1++newMemoWith1 :: (a -> GenHaxl u b) -> GenHaxl u (MemoVar1 u a b)+newMemoWith1 f = newMemo1 >>= \r -> prepareMemo1 r f >> return r++prepareMemo1 :: MemoVar1 u a b -> (a -> GenHaxl u b) -> GenHaxl u ()+prepareMemo1 (MemoVar1 r) f+  = unsafeLiftIO $ writeIORef r (MemoTbl1 (f, HashMap.empty))++runMemo1 :: (Eq a, Hashable a) => MemoVar1 u a b -> a -> GenHaxl u b+runMemo1 (MemoVar1 r) k = unsafeLiftIO (readIORef r) >>= \case+  MemoEmpty1 -> throw $ CriticalError "Attempting to run empty memo."+  MemoTbl1 (f, h) -> case HashMap.lookup k h of+    Nothing -> do+      x <- newMemoWith (f k)+      unsafeLiftIO $ writeIORef r (MemoTbl1 (f, HashMap.insert k x h))+      runMemo x+    Just v -> runMemo v++newMemo2 :: GenHaxl u (MemoVar2 u a b c)+newMemo2 = unsafeLiftIO $ MemoVar2 <$> newIORef MemoEmpty2++newMemoWith2 :: (a -> b -> GenHaxl u c) -> GenHaxl u (MemoVar2 u a b c)+newMemoWith2 f = newMemo2 >>= \r -> prepareMemo2 r f >> return r++prepareMemo2 :: MemoVar2 u a b c -> (a -> b -> GenHaxl u c) -> GenHaxl u ()+prepareMemo2 (MemoVar2 r) f+  = unsafeLiftIO $ writeIORef r (MemoTbl2 (f, HashMap.empty))++runMemo2 :: (Eq a, Hashable a, Eq b, Hashable b)+         => MemoVar2 u a b c+         -> a -> b -> GenHaxl u c+runMemo2 (MemoVar2 r) k1 k2 = unsafeLiftIO (readIORef r) >>= \case+  MemoEmpty2 -> throw $ CriticalError "Attempting to run empty memo."+  MemoTbl2 (f, h1) -> case HashMap.lookup k1 h1 of+    Nothing -> do+      v <- newMemoWith (f k1 k2)+      unsafeLiftIO $ writeIORef r+        (MemoTbl2 (f, HashMap.insert k1 (HashMap.singleton k2 v) h1))+      runMemo v+    Just h2 -> case HashMap.lookup k2 h2 of+      Nothing -> do+        v <- newMemoWith (f k1 k2)+        unsafeLiftIO $ writeIORef r+          (MemoTbl2 (f, HashMap.insert k1 (HashMap.insert k2 v h2) h1))+        runMemo v+      Just v -> runMemo v

@@ -26,18 +26,30 @@   defaultFlags,   ifTrace,   ifReport,+  ifProfiling,    -- * Statistics   Stats(..),   RoundStats(..),   DataSourceRoundStats(..),   Microseconds,+  Round,   emptyStats,   numRounds,   numFetches,   ppStats,   ppRoundStats,   ppDataSourceRoundStats,+  Profile,+  emptyProfile,+  profile,+  profileRound,+  profileCache,+  ProfileLabel,+  ProfileData(..),+  emptyProfileData,+  AllocCount,+  MemoHitCount,    -- * Data fetching   DataSource(..),@@ -46,6 +58,11 @@   BlockedFetch(..),   PerformFetch(..), +  -- * DataCache+  DataCache(..),+  SubCache(..),+  emptyDataCache,+   -- * Result variables   ResultVar(..),   newEmptyResult,@@ -76,12 +93,18 @@ import Control.Monad import Data.Aeson import Data.Function (on)+import Data.Functor.Constant+import Data.Int import Data.Hashable import Data.HashMap.Strict (HashMap, toList) import qualified Data.HashMap.Strict as HashMap+import Data.HashSet (HashSet)+import qualified Data.HashSet as HashSet import Data.List (intercalate, sortBy)+import Data.Map (Map)+import qualified Data.Map as Map import Data.Text (Text, unpack)-import Data.Typeable (Typeable)+import Data.Typeable.Internal  #if __GLASGOW_HASKELL__ < 708 import Haxl.Core.Util (tryReadMVar)@@ -89,18 +112,27 @@ import Haxl.Core.Show1 import Haxl.Core.StateStore +-- ---------------------------------------------------------------------------+-- Flags+ -- | Flags that control the operation of the engine. data Flags = Flags-  { trace :: Int+  { trace :: {-# UNPACK #-} !Int     -- ^ Tracing level (0 = quiet, 3 = very verbose).-  , report :: Int-    -- ^ Report level (0 = quiet, 1 = # of requests, 2 = time, 3 = # of errors)+  , report :: {-# UNPACK #-} !Int+    -- ^ Report level (0 = quiet, 1 = # of requests, 2 = time, 3 = # of errors,+    -- 4 = profiling, 5 = log stack traces of dataFetch calls)+  , caching :: {-# UNPACK #-} !Int+    -- ^ Non-zero if caching is enabled.  If caching is disabled, then+    -- we still do batching and de-duplication within a round, but do+    -- not cache results between rounds.   }  defaultFlags :: Flags defaultFlags = Flags   { trace = 0   , report = 1+  , caching = 1   }  -- | Runs an action if the tracing level is above the given threshold.@@ -111,69 +143,168 @@ ifReport :: (Functor m, Monad m) => Flags -> Int -> m a -> m () ifReport flags i = when (report flags >= i) . void +ifProfiling :: (Functor m, Monad m) => Flags -> m a -> m ()+ifProfiling flags = when (report flags >= 4) . void++-- ---------------------------------------------------------------------------+-- Stats+ type Microseconds = Int+-- | Rounds are 1-indexed+type Round = Int  -- | Stats that we collect along the way. newtype Stats = Stats [RoundStats]-  deriving ToJSON+  deriving (Show, ToJSON)  -- | Pretty-print Stats. ppStats :: Stats -> String ppStats (Stats rss) =-  intercalate "\n" [ "Round: " ++ show i ++ " - " ++ ppRoundStats rs-                   | (i, rs) <- zip [(1::Int)..] (reverse rss) ]+  intercalate "\n"+     [ "Round: " ++ show i ++ " - " ++ ppRoundStats rs+     | (i, rs) <- zip [(1::Int)..] (filter isRoundStats (reverse rss)) ]+ where+  isRoundStats RoundStats{} = True+  isRoundStats _ = False  -- | 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.-data RoundStats = RoundStats-  { roundTime :: Microseconds-  , roundDataSources :: HashMap Text DataSourceRoundStats-  }+data RoundStats+    -- | Timing stats for a round of data fetching+  = RoundStats+    { roundTime :: Microseconds+    , roundAllocation :: Int+    , roundDataSources :: HashMap Text DataSourceRoundStats+    }+    -- | The stack trace of a call to 'dataFetch'.  These are collected+    -- only when profiling and reportLevel is 5 or greater.+  | FetchCall+    { fetchReq :: String+    , fetchStack :: [String]+    }+  deriving (Show)  -- | Pretty-print RoundStats. ppRoundStats :: RoundStats -> String-ppRoundStats (RoundStats t dss) =-    show t ++ "us\n"+ppRoundStats (RoundStats t a dss) =+    show t ++ "us " ++ show a ++ " bytes\n"       ++ unlines [ "  " ++ unpack nm ++ ": " ++ ppDataSourceRoundStats dsrs                  | (nm, dsrs) <- sortBy (compare `on` fst) (toList dss) ]+ppRoundStats (FetchCall r ss) = show r ++ '\n':show ss  instance ToJSON RoundStats where   toJSON RoundStats{..} = object     [ "time" .= roundTime+    , "allocation" .= roundAllocation     , "dataSources" .= roundDataSources     ]+  toJSON (FetchCall req strs) = object+    [ "request" .= req+    , "stack" .= strs+    ]  -- | Detailed stats of each data source in each round. data DataSourceRoundStats = DataSourceRoundStats   { dataSourceFetches :: Int   , dataSourceTime :: Maybe Microseconds-  }+  , dataSourceFailures :: Maybe Int+  , dataSourceAllocation :: Maybe Int+  } deriving (Show)  -- | 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+ppDataSourceRoundStats (DataSourceRoundStats fetches time failures allocs) =+  maybe id (\t s -> s ++ " (" ++ show t ++ "us)") time $+  maybe id (\a s -> s ++ " (" ++ show a ++ " bytes)") allocs $+  maybe id (\f s -> s ++ " " ++ show f ++ " failures") failures $+  show fetches ++ " fetches"  instance ToJSON DataSourceRoundStats where   toJSON DataSourceRoundStats{..} = object [k .= v | (k, Just v) <-     [ ("fetches", Just dataSourceFetches)     , ("time", dataSourceTime)+    , ("failures", dataSourceFailures)+    , ("allocation", dataSourceAllocation)     ]]  fetchesInRound :: RoundStats -> Int-fetchesInRound (RoundStats _ hm) =+fetchesInRound (RoundStats _ _ hm) =   sum $ map dataSourceFetches $ HashMap.elems hm+fetchesInRound _ = 0  emptyStats :: Stats emptyStats = Stats []  numRounds :: Stats -> Int-numRounds (Stats rs) = length rs+numRounds (Stats rs) = length [ s | s@RoundStats{} <- rs ]  numFetches :: Stats -> Int numFetches (Stats rs) = sum (map fetchesInRound rs)+++-- ---------------------------------------------------------------------------+-- Profiling++type ProfileLabel = Text+type AllocCount = Int64+type MemoHitCount = Int64++data Profile = Profile+  { profileRound :: {-# UNPACK #-} !Round+     -- ^ Keep track of what the current fetch round is.+  , profile      :: HashMap ProfileLabel ProfileData+     -- ^ Data on individual labels.+  , profileCache :: DataCache (Constant Round)+     -- ^ Keep track of the round requests first appear in.+  }++emptyProfile :: Profile+emptyProfile = Profile 1 HashMap.empty emptyDataCache++data ProfileData = ProfileData+  { profileAllocs :: {-# UNPACK #-} !AllocCount+     -- ^ allocations made by this label+  , profileDeps :: HashSet ProfileLabel+     -- ^ labels that this label depends on+  , profileFetches :: Map Round (HashMap Text Int)+     -- ^ map from round to {datasource name => fetch count}+  , profileMemoHits :: {-# UNPACK #-} !MemoHitCount+    -- ^ number of hits to memoized computation at this label+  }+  deriving Show++emptyProfileData :: ProfileData+emptyProfileData = ProfileData 0 HashSet.empty Map.empty 0++-- ---------------------------------------------------------------------------+-- DataCache++-- | The 'DataCache' maps things of type @f a@ to @'ResultVar' a@, for+-- any @f@ and @a@ provided @f a@ is an instance of 'Typeable'. In+-- practice @f a@ will be a request type parameterised by its result.+--+-- See the definition of 'ResultVar' for more details.++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 res =+  forall req a . (Hashable (req a), Eq (req a), Typeable (req a)) =>+       SubCache (req a -> String) (a -> String) ! (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'.+emptyDataCache :: DataCache res+emptyDataCache = DataCache HashMap.empty++-- ---------------------------------------------------------------------------+-- DataSource class  -- | The class of data sources, parameterised over the request type for -- that data source. Every data source must implement this class.

@@ -33,6 +33,7 @@      -- * Haxl and Fetching data     GenHaxl, dataFetch, DataSource, memo,+    memoize, memoize1, memoize2,      -- * Extra Monad and Applicative things     Applicative(..),@@ -70,7 +71,7 @@ import Haxl.Core.Monad  import Control.Applicative-import Control.Monad (foldM, join)+import Control.Monad (foldM, join, void) import Data.List (foldl', sort) import Data.Text (Text) import Data.Traversable hiding (forM, mapM, sequence)@@ -101,7 +102,7 @@ -- The equality constraint is necessary to convince the typechecker that -- this is valid: ----- > if getCountry ip .== "us" then ... else ...+-- > if ipGetCountry ip .== "us" then ... else ... -- instance (u1 ~ u2) => IfThenElse (GenHaxl u1 Bool) (GenHaxl u2 a) where   ifThenElse fb t e = do@@ -174,7 +175,7 @@  -- | See 'mapM'. mapM_ :: (Traversable t, Applicative f) => (a -> f b) -> t a -> f ()-mapM_ f t = const () <$> traverse f t+mapM_ f t = void $ traverse f t  forM_ :: (Traversable t, Applicative f) => t a -> (a -> f b) -> f () forM_ = flip mapM_@@ -185,7 +186,7 @@  -- | See 'mapM'. sequence_ :: (Traversable t, Applicative f) => t (f a) -> f ()-sequence_ t = const () <$> sequenceA t+sequence_ t = void $ sequenceA t  -- | See 'mapM'. filterM :: (Applicative f, Monad f) => (a -> f Bool) -> [a] -> f [a]

@@ -1,5 +1,5 @@ name:                haxl-version:             0.3.1.0+version:             0.4.0.0 synopsis:            A Haskell library for efficient, concurrent,                      and concise data access. homepage:            https://github.com/facebook/Haxl@@ -13,6 +13,10 @@ build-type:          Simple stability:           alpha cabal-version:       >= 1.10+tested-with:+  GHC==7.8.4,+  GHC==7.10.3,+  GHC==8.0.1  description:   Haxl is a library and EDSL for efficient scheduling of concurrent data@@ -39,18 +43,21 @@    build-depends:     HUnit >= 1.2 && < 1.4,-    aeson >= 0.6 && < 0.11,+    aeson >= 0.6 && < 1.1,     base == 4.*,+    binary >= 0.7 && < 0.9,     bytestring >= 0.9 && < 0.11,     containers == 0.5.*,     deepseq,     directory >= 1.1 && < 1.3,     exceptions >=0.8 && <0.9,     filepath >= 1.3 && < 1.5,+    ghc-prim,     hashable == 1.2.*,     pretty == 1.1.*,     text >= 1.1.0.1 && < 1.3,-    time >= 1.4 && < 1.6,+    time >= 1.4 && < 1.7,+    transformers,     unordered-containers == 0.2.*,     vector >= 0.10 && <0.12 @@ -58,12 +65,12 @@     Haxl.Core,     Haxl.Core.DataCache,     Haxl.Core.Exception,+    Haxl.Core.Memo,     Haxl.Core.Monad,     Haxl.Core.RequestStore,     Haxl.Core.StateStore,     Haxl.Core.Show1,     Haxl.Core.Types,-    Haxl.Core.Memo,     Haxl.Prelude    other-modules:@@ -82,10 +89,15 @@     HUnit,     aeson,     base == 4.*,+    binary,     bytestring,     containers,+    deepseq,+    filepath,     hashable,     haxl,+    test-framework,+    test-framework-hunit,     text,     unordered-containers @@ -98,7 +110,7 @@     tests    main-is:-    Main.hs+    TestMain.hs    other-modules:     BatchTests

@@ -39,9 +39,11 @@  * [The N+1 Selects Problem](example/sql/readme.md) explains how Haxl    can address a common performance problem with SQL queries by    automatically batching multiple queries into a single query,-   completely invisibly to the programmer.+   without the programmer having to specify this behavior.   * [Haxl Documentation](http://hackage.haskell.org/package/haxl) on    Hackage.   * [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.++[![Build Status](https://travis-ci.org/facebook/Haxl.svg?branch=master)](https://travis-ci.org/facebook/Haxl)

@@ -12,6 +12,7 @@  import Prelude() import Haxl.Prelude+import Data.IORef  -- ----------------------------------------------------------------------------- @@ -138,6 +139,15 @@   -- ensure no more data fetching rounds needed   expectRoundsWithEnv 0 12 batching7_ env2 +noCaching = do+  env <- makeTestEnv+  let env' = env{ flags = (flags env){caching = 0} }+  result <- runHaxl env' caching3_+  assertEqual "result" result 18+  stats <- readIORef (statsRef env)+  assertEqual "rounds" 2 (numRounds stats)+  assertEqual "fetches" 4 (numFetches stats)+ exceptionTest1 = expectRounds 1 []   $ withDefault [] $ friendsOf 101 @@ -180,6 +190,7 @@   , TestLabel "caching2" $ TestCase caching2   , TestLabel "caching3" $ TestCase caching3   , TestLabel "CacheReuse" $ TestCase cacheReuse+  , TestLabel "NoCaching" $ TestCase noCaching   , TestLabel "exceptionTest1" $ TestCase exceptionTest1   , TestLabel "exceptionTest2" $ TestCase exceptionTest2   , TestLabel "deterministicExceptions" $ TestCase deterministicExceptions

@@ -29,7 +29,7 @@   let cache =           DataCache.insert (Req 1 :: TestReq Int) m1 $           DataCache.insert (Req 2 :: TestReq String) m2 $-          DataCache.empty+          emptyDataCache    -- "Req 1" has a result of type Int, so if we try to look it up   -- with a result of type String, we should get Nothing, not a crash.

@@ -1,26 +0,0 @@-{-# LANGUAGE CPP, RebindableSyntax, OverloadedStrings #-}-module Main where--import TestExampleDataSource-import BatchTests-import CoreTests-import DataCacheTest-#ifdef HAVE_APPLICATIVEDO-import AdoTests-#endif--import Data.String-import Test.HUnit--import Haxl.Prelude--main :: IO Counts-main = runTestTT $ TestList-  [ TestLabel "ExampleDataSource" TestExampleDataSource.tests-  , TestLabel "BatchTests" BatchTests.tests-  , TestLabel "CoreTests" CoreTests.tests-  , TestLabel "DataCacheTests" DataCacheTest.tests-#ifdef HAVE_APPLICATIVEDO-  , TestLabel "AdoTests" AdoTests.tests-#endif-  ]

@@ -5,9 +5,12 @@ -- found in the LICENSE file. An additional grant of patent rights can -- be found in the PATENTS file. +-- | Benchmarking tool for core performance characteristics of the Haxl monad.+ module MonadBench (main) where  import Control.Monad+import Data.List as List import Data.Time.Clock import System.Environment import System.Exit@@ -17,6 +20,8 @@ import Haxl.Prelude as Haxl import Prelude() +import Haxl.Core.Monad (newMemoWith, runMemo)+ import Haxl.Core  import ExampleDataSource@@ -47,8 +52,64 @@        foldl andThen (return []) (map listWombats [1.. fromIntegral n])        return ()     "tree" -> runHaxl env $ void $ tree n+    -- No memoization+    "memo0" -> runHaxl env $+      Haxl.sequence_ [unionWombats | _ <- [1..n]]+    -- One put, N gets.+    "memo1" -> runHaxl env $+      Haxl.sequence_ [memo (42 :: Int) unionWombats | _ <- [1..n]]+    -- N puts, N gets.+    "memo2" -> runHaxl env $+      Haxl.sequence_ [memo (i :: Int) unionWombats | i <- [1..n]]+    "memo3" ->+      runHaxl env $ do+        ref <- newMemoWith unionWombats+        let c = runMemo ref+        Haxl.sequence_ [c | _ <- [1..n]]+    "memo4" ->+      runHaxl env $ do+        let f = unionWombatsTo+        Haxl.sequence_ [f x | x <- take n $ cycle [100, 200 .. 1000]]+    "memo5" ->+      runHaxl env $ do+        f <- memoize1 unionWombatsTo+        Haxl.sequence_ [f x | x <- take n $ cycle [100, 200 .. 1000]]+    "memo6" ->+      runHaxl env $ do+        let f = unionWombatsFromTo+        Haxl.sequence_ [ f x y+                       | x <- take n $ cycle [100, 200 .. 1000]+                       , let y = x + 1000+                       ]+    "memo7" ->+      runHaxl env $ do+        f <- memoize2 unionWombatsFromTo+        Haxl.sequence_ [ f x y+                       | x <- take n $ cycle [100, 200 .. 1000]+                       , let y = x + 1000+                       ]++    "cc1" -> runHaxl env $+      Haxl.sequence_ [ cachedComputation (ListWombats 1000) unionWombats+                     | _ <- [1..n]+                     ]+     _ -> do-      hPutStrLn stderr "syntax: monadbench par1|par2|seqr|seql NUM"+      hPutStrLn stderr $ "syntax: monadbench " ++ concat+        [ "par1"+        , "par2"+        , "seqr"+        , "seql"+        , "memo0"+        , "memo1"+        , "memo2"+        , "memo3"+        , "memo4"+        , "memo5"+        , "memo6"+        , "memo7"+        , "cc1"+        ]       exitWith (ExitFailure 1)   t1 <- getCurrentTime   printf "%d reqs: %.2fs\n" n (realToFrac (t1 `diffUTCTime` t0) :: Double)@@ -62,3 +123,12 @@   [ tree (n-1)   , listWombats (fromIntegral n), tree (n-1)   ]++unionWombats :: GenHaxl () [Id]+unionWombats = foldl List.union [] <$> Haxl.mapM listWombats [1..1000]++unionWombatsTo :: Id -> GenHaxl () [Id]+unionWombatsTo x = foldl List.union [] <$> Haxl.mapM listWombats [1..x]++unionWombatsFromTo :: Id -> Id -> GenHaxl () [Id]+unionWombatsFromTo x y = foldl List.union [] <$> Haxl.mapM listWombats [x..y]

@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, RebindableSyntax, MultiWayIf #-}+{-# LANGUAGE CPP, OverloadedStrings, RebindableSyntax, MultiWayIf #-} module TestExampleDataSource (tests) where  import Haxl.Prelude as Haxl@@ -11,6 +11,7 @@ import Test.HUnit import Data.IORef import Control.Exception+import System.FilePath  import ExampleDataSource import LoadCache@@ -173,5 +174,7 @@   env <- testEnv   runHaxl env loadCache   str <- runHaxl env dumpCacheAsHaskell-  loadcache <- readFile "sigma/haxl/core/tests/LoadCache.txt"-  assertEqual "dumpCacheAsHaskell" str loadcache+  loadcache <- readFile $ dropFileName __FILE__ </> "LoadCache.txt"+  -- The order of 'cacheRequest ...' calls is nondeterministic and+  -- differs among GHC versions, so we sort the lines for comparison.+  assertEqual "dumpCacheAsHaskell" (sort $ lines loadcache) (sort $ lines str)

@@ -0,0 +1,9 @@+{-# LANGUAGE CPP, OverloadedStrings #-}+module Main where++import Test.Framework (defaultMain)+import Test.Framework.Providers.HUnit (hUnitTestToTests)+import AllTests++main :: IO ()+main = defaultMain $ hUnitTestToTests allTests

@@ -10,6 +10,7 @@    ) where  import Data.Aeson+import Data.Binary (Binary) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.HashMap.Strict as HashMap@@ -36,7 +37,7 @@   newtype Id = Id Int-  deriving (Eq, Ord, Enum, Num, Integral, Real, Hashable, Typeable,+  deriving (Eq, Ord, Binary, Enum, Num, Integral, Real, Hashable, Typeable,             ToJSON, FromJSON)  instance Show Id where