haxl 0.2.0.0 → 0.3.0.0

raw patch · 20 files changed

+608/−176 lines, 20 filesdep +deepseqdep ~basedep ~hashabledep ~timenew-component:exe:monadbenchPVP ok

version bump matches the API change (PVP)

Dependencies added: deepseq

Dependency ranges changed: base, hashable, time

API changes (from Hackage documentation)

Files

• Haxl/Core.hs +76/−7
• Haxl/Core/DataCache.hs +46/−21
• Haxl/Core/Exception.hs +9/−7
• Haxl/Core/Memo.hs +93/−0
• Haxl/Core/Monad.hs +93/−26
• Haxl/Core/RequestStore.hs +2/−0
• Haxl/Core/Show1.hs +2/−0
• Haxl/Core/StateStore.hs +2/−0
• Haxl/Core/Types.hs +12/−24
• Haxl/Prelude.hs +3/−2
• PATENTS +28/−18
• changelog.md +19/−0
• haxl.cabal +33/−1
• tests/BatchTests.hs +26/−66
• tests/ExampleDataSource.hs +4/−3
• tests/Main.hs +7/−1
• tests/MockTAO.hs +4/−0
• tests/MonadBench.hs +64/−0
• tests/TestExampleDataSource.hs +18/−0
• tests/TestUtils.hs +67/−0

@@ -6,15 +6,84 @@ -- be found in the PATENTS file.  -- | 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.Monad-  , module Haxl.Core.Types-  , module Haxl.Core.Exception-  , module Haxl.Core.StateStore-  , module Haxl.Core.Show1+-- engine.+--+module Haxl.Core (+  -- * The monad and operations+  GenHaxl (..), runHaxl,++  -- ** Env+  Env(..), Caches, caches,+  -- *** Operations in the monad+  env, withEnv,+  -- *** Building the Env+  initEnvWithData, initEnv, emptyEnv,+  -- *** Building the StateStore+  StateStore, stateGet, stateSet, stateEmpty,++  -- ** Exceptions+  throw, catch, catchIf, try, tryToHaxlException,++  -- ** Data fetching and caching+  dataFetch, uncachedRequest,+  cacheRequest, cacheResult, cachedComputation,+  dumpCacheAsHaskell,++  -- ** Memoization+  memo, memoFingerprint, MemoFingerprintKey(..),++  -- ** Statistics+  Stats(..),+  RoundStats(..),+  DataSourceRoundStats(..),+  Microseconds,+  emptyStats,+  numRounds,+  numFetches,+  ppStats,+  ppRoundStats,+  ppDataSourceRoundStats,++  -- ** Tracing flags+  Flags(..),+  defaultFlags,+  ifTrace,+  ifReport,++  -- * Building data sources+  DataSource(..),+  Show1(..),+  DataSourceName(..),+  Request,+  BlockedFetch(..),+  PerformFetch(..),+  StateKey(..),++  -- ** Result variables+  ResultVar(..),+  newEmptyResult,+  newResult,+  putFailure,+  putResult,+  putSuccess,+  takeResult,+  tryReadResult,+  tryTakeResult,++  -- ** Default fetch implementations+  asyncFetch, asyncFetchWithDispatch,+  stubFetch,+  syncFetch,++  -- ** Utilities+  except,+  setError,++  -- * Exceptions+  module Haxl.Core.Exception   ) where +import Haxl.Core.Memo import Haxl.Core.Monad hiding (unsafeLiftIO {- Ask nicely to get this! -}) import Haxl.Core.Types import Haxl.Core.Exception

@@ -10,11 +10,14 @@ {-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -fno-warn-orphans #-} --- | A cache mapping data requests to their results.+-- | A cache mapping data requests to their results.  This module is+-- provided for access to Haxl internals only; most users should not+-- need to import it. module Haxl.Core.DataCache   ( DataCache   , empty   , insert+  , insertNotShowable   , lookup   , showCache   ) where@@ -47,8 +50,8 @@ -- 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), Show (req a), Show a) =>-       SubCache ! (HashMap (req a) (res a))+  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. @@ -67,13 +70,36 @@   -> DataCache res  insert req result (DataCache m) =-      DataCache $-        HashMap.insertWith fn (typeOf req)-                              (SubCache (HashMap.singleton req result)) m+  DataCache $+    HashMap.insertWith fn (typeOf req)+       (SubCache show show (HashMap.singleton req result)) m   where-    fn (SubCache new) (SubCache old) =-        SubCache (unsafeCoerce new `HashMap.union` old)+    fn (SubCache _ _ new) (SubCache showReq showRes old) =+      SubCache showReq showRes (unsafeCoerce new `HashMap.union` old) +-- | Inserts a request-result pair into the 'DataCache', without+-- requiring Show instances of the request or the result.  The cache+-- cannot be subsequently used with `showCache`.+insertNotShowable+  :: (Hashable (req a), Typeable (req a), Eq (req a))+  => req a+  -- ^ Request+  -> res a+  -- ^ Result+  -> 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)++notShowable :: a+notShowable = error "insertNotShowable"+ -- | Looks up the cached result of a request. lookup   :: Typeable (req a)@@ -85,12 +111,13 @@ lookup req (DataCache m) =       case HashMap.lookup (typeOf req) m of         Nothing -> Nothing-        Just (SubCache sc) ->+        Just (SubCache _ _ sc) ->            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'.+-- 'TypeRep'.  Note that this will fail if 'insertNotShowable' has+-- been used to insert any entries. -- showCache   :: DataCache ResultVar@@ -101,16 +128,14 @@   goSubCache     :: (TypeRep,SubCache ResultVar)     -> IO (TypeRep,[(String, Either SomeException String)])-  goSubCache (ty, SubCache hmap) = do+  goSubCache (ty, SubCache showReq showRes hmap) = do     elems <- catMaybes <$> mapM go (HashMap.toList hmap)     return (ty, elems)--  go :: (Show (req a), Show a)-     => (req a, ResultVar a)-     -> IO (Maybe (String, Either SomeException String))-  go (req, rvar) = do-    maybe_r <- tryReadResult rvar-    case maybe_r of-      Nothing -> return Nothing-      Just (Left e) -> return (Just (show req, Left e))-      Just (Right result) -> return (Just (show req, Right (show result)))+   where+    go  (req, rvar) = do+      maybe_r <- tryReadResult rvar+      case maybe_r of+        Nothing -> return Nothing+        Just (Left e) -> return (Just (showReq req, Left e))+        Just (Right result) ->+          return (Just (showReq req, Right (showRes result)))

@@ -24,7 +24,9 @@ -- 'withDefault' to be useful, for example, you'll want your -- exceptions to be children of 'LogicError' or 'TransientError' as -- appropriate.-+--+-- Most users should import "Haxl.Core" instead of importing this+-- module directly. module Haxl.Core.Exception (    HaxlException(..),@@ -188,7 +190,7 @@ -- | Generic \"critical\" exception. Something internal is -- borked. Panic. data CriticalError = CriticalError Text-  deriving (Typeable, Show)+  deriving (Typeable, Eq, Show)  instance Exception CriticalError where   toException   = internalErrorToException@@ -196,7 +198,7 @@  -- | Generic \"something was not found\" exception. data NotFound = NotFound Text-  deriving (Typeable, Show)+  deriving (Typeable, Eq, Show)  instance Exception NotFound where   toException = logicErrorToException@@ -204,7 +206,7 @@  -- | Generic \"something had the wrong type\" exception. data UnexpectedType = UnexpectedType Text-  deriving (Typeable, Show)+  deriving (Typeable, Eq, Show)  instance Exception UnexpectedType where   toException = logicErrorToException@@ -212,7 +214,7 @@  -- | Generic \"input list was empty\" exception. data EmptyList = EmptyList Text-  deriving (Typeable,Show)+  deriving (Typeable, Eq, Show)  instance Exception EmptyList where   toException = logicErrorToException@@ -220,7 +222,7 @@  -- | Generic \"Incorrect assumptions about JSON data\" exception. data JSONError = JSONError Text-  deriving (Typeable, Show)+  deriving (Typeable, Eq, Show)  instance Exception JSONError where   toException = logicErrorToException@@ -228,7 +230,7 @@  -- | Generic \"passing some invalid parameter\" exception. data InvalidParameter = InvalidParameter Text-  deriving (Typeable, Show)+  deriving (Typeable, Eq, Show)  instance Exception InvalidParameter where   toException = logicErrorToException

@@ -0,0 +1,93 @@+-- 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 DeriveDataTypeable, GADTs, OverloadedStrings,+    StandaloneDeriving #-}++-- | Most users should import "Haxl.Core" instead of importing this+-- module directly.+module Haxl.Core.Memo (memo, memoFingerprint, MemoFingerprintKey(..)) where++import Data.Text (Text)+import Data.Typeable+import Data.Hashable+import Data.Word++import Haxl.Core.Monad (GenHaxl, cachedComputation)++-- -----------------------------------------------------------------------------+-- A key type that can be used for memoizing computations by a Text key++-- | Memoize a computation using an arbitrary key.  The result will be+-- calculated once; the second and subsequent time it will be returned+-- immediately.  It is the caller's responsibility to ensure that for+-- every two calls @memo key haxl@, if they have the same @key@ then+-- they compute the same result.+memo+  :: (Typeable a, Typeable k, Hashable k, Eq k)+  => k -> GenHaxl u a -> GenHaxl u a+memo key = cachedComputation (MemoKey key)++{-# RULES "memo/Text"+  memo = memoText :: (Typeable a) => Text -> GenHaxl u a -> GenHaxl u a+ #-}++{-# NOINLINE memo #-}++data MemoKey k a where+  MemoKey :: (Typeable k, Hashable k, Eq k) => k -> MemoKey k a+  deriving Typeable++deriving instance Eq (MemoKey k a)++instance Hashable (MemoKey k a) where+  hashWithSalt s (MemoKey t) = hashWithSalt s t++-- An optimised memo key for Text keys.  This is used automatically+-- when the key is Text, due to the RULES pragma above.++data MemoTextKey a where+  MemoText :: Text -> MemoTextKey a+  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)++-- | 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+  deriving Typeable++deriving instance Eq (MemoFingerprintKey a)+deriving instance Show (MemoFingerprintKey a)++instance Hashable (MemoFingerprintKey a) where+  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+--+-- 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.+--+{-# NOINLINE memoFingerprint #-}+memoFingerprint+   :: (Show a, Typeable a) => MemoFingerprintKey a -> GenHaxl u a -> GenHaxl u a+memoFingerprint key = cachedComputation key

@@ -16,14 +16,15 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} --- | The implementation of the 'Haxl' monad.+-- | 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,+    env, withEnv,      -- * Env-    Env(..), caches, initEnvWithData, initEnv, emptyEnv,+    Env(..), Caches, caches, initEnvWithData, initEnv, emptyEnv,      -- * Exceptions     throw, catch, catchIf, try, tryToHaxlException,@@ -55,15 +56,20 @@ #endif import Control.Monad import qualified Control.Exception as Exception+#if __GLASGOW_HASKELL__ < 710 import Control.Applicative hiding (Const)+#endif+import Control.DeepSeq import GHC.Exts (IsString(..)) #if __GLASGOW_HASKELL__ < 706 import Prelude hiding (catch) #endif+import Data.Hashable import Data.IORef import Data.List import Data.Monoid import Data.Time+import Data.Typeable import qualified Data.HashMap.Strict as HashMap import Text.Printf import Text.PrettyPrint hiding ((<>))@@ -107,7 +113,7 @@     , statsRef = sref     } --- | Initializes an environment with 'DataStates' and an input map.+-- | Initializes an environment with 'StateStore' and an input map. initEnv :: StateStore -> u -> IO (Env u) initEnv states e = do   cref <- newIORef DataCache.empty@@ -144,8 +150,46 @@ data Result u a   = Done a   | Throw SomeException-  | Blocked (GenHaxl u a)+  | Blocked (Cont u a) +data Cont u a+  = Cont (GenHaxl u a)+  | forall b. Cont u b :>>= (b -> GenHaxl u a)+  | forall b. (Cont u (b -> a)) :<*> (Cont u b)+  | forall b. (b -> a) :<$> (Cont u b)++toHaxl :: Cont u a -> GenHaxl u a+toHaxl (Cont haxl)           = haxl+toHaxl ((m :>>= k1) :>>= k2) = toHaxl (m :>>= (k1 >=> k2)) -- for seql+toHaxl (c :>>= k)            = toHaxl c >>= k+toHaxl ((f :<$> i) :<*> (g :<$> j)) =+  toHaxl (((\x y -> f x (g y)) :<$> i) :<*> j)          -- See Note [Tree]+toHaxl (f :<*> x)            = toHaxl f <*> toHaxl x+toHaxl (f :<$> (g :<$> x))   = toHaxl ((f . g) :<$> x)  -- fmap fusion+toHaxl (f :<$> x)            = fmap f (toHaxl x)++-- Note [Tree]+-- This implements the following re-association:+--+--           <*>+--          /   \+--       <$>     <$>+--      /   \   /   \+--     f     i g     j+--+-- to:+--+--           <*>+--          /   \+--       <$>     j+--      /   \         where h = (\x y -> f x (g y))+--     h     i+--+-- I suspect this is mostly useful because it eliminates one :<$> constructor+-- within the Blocked returned by `tree 1`, which is replicated a lot by the+-- tree benchmark (tree 1 is near the leaves). So this rule might just be+-- optimizing for a microbenchmark.+ instance (Show a) => Show (Result u a) where   show (Done a) = printf "Done(%s)" $ show a   show (Throw e) = printf "Throw(%s)" $ show e@@ -158,10 +202,18 @@     case e of       Done a       -> unHaxl (k a) env ref       Throw e      -> return (Throw e)-      Blocked cont -> return (Blocked (cont >>= k))+      Blocked cont -> return (Blocked (cont :>>= k)) +  -- We really want the Applicative version of >>+  (>>) = (*>)+ instance Functor (GenHaxl u) where-  fmap f m = pure f <*> m+  fmap f (GenHaxl m) = GenHaxl $ \env ref -> do+    r <- m env ref+    case r of+      Done a -> return (Done (f a))+      Throw e -> return (Throw e)+      Blocked a' -> return (Blocked (f :<$> a'))  instance Applicative (GenHaxl u) where   pure = return@@ -174,22 +226,22 @@         case ra of           Done a'    -> return (Done (f' a'))           Throw e    -> return (Throw e)-          Blocked a' -> return (Blocked (f' <$> a'))+          Blocked a' -> return (Blocked (f' :<$> a'))       Blocked f' -> do         ra <- a env ref  -- left is blocked, explore the right         case ra of-          Done a'    -> return (Blocked (f' <*> return a'))-          Throw e    -> return (Blocked (f' <*> throw e))-          Blocked a' -> return (Blocked (f' <*> a'))+          Done a'    -> return (Blocked (($ a') :<$> f'))+          Throw e    -> return (Blocked (f' :<*> Cont (throw e)))+          Blocked a' -> return (Blocked (f' :<*> a'))  -- | 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+  let go !n env c = do         traceEventIO "START computation"         ref <- newIORef noRequests-        e <- haxl env ref+        e <- toHaxl c env ref         traceEventIO "STOP computation"         case e of           Done a       -> return a@@ -202,7 +254,7 @@             traceEventIO "STOP performFetches"             go n' env cont   traceEventIO "START runHaxl"-  r <- go 0 env h+  r <- go 0 env (Cont h)   traceEventIO "STOP runHaxl"   return r #else@@ -216,13 +268,23 @@       bs <- readIORef ref       writeIORef ref noRequests -- Note [RoundId]       void (performFetches 0 env bs)-      runHaxl env cont+      runHaxl env (toHaxl cont) #endif  -- | Extracts data from the 'Env'. env :: (Env u -> a) -> GenHaxl u a env f = GenHaxl $ \env _ref -> return (Done (f env)) +-- | Returns a version of the Haxl computation which always uses the+-- provided 'Env', ignoring the one specified by 'runHaxl'.+withEnv :: Env u -> GenHaxl u a -> GenHaxl u a+withEnv newEnv (GenHaxl m) = GenHaxl $ \_env ref -> do+  r <- m newEnv ref+  case r of+    Done a -> return (Done a)+    Throw e -> return (Throw e)+    Blocked k -> return (Blocked (Cont (withEnv newEnv (toHaxl k))))+ -- ----------------------------------------------------------------------------- -- Exceptions @@ -241,7 +303,7 @@      Done a    -> return (Done a)      Throw e | Just e' <- fromException e -> unHaxl (h e') env ref              | otherwise -> return (Throw e)-     Blocked k -> return (Blocked (catch k h))+     Blocked k -> return (Blocked (Cont (catch (toHaxl k) h)))  -- | Catch exceptions that satisfy a predicate catchIf@@ -272,7 +334,7 @@ unsafeToHaxlException (GenHaxl m) = GenHaxl $ \env ref -> do   r <- m env ref `Exception.catch` \e -> return (Throw e)   case r of-    Blocked c -> return (Blocked (unsafeToHaxlException c))+    Blocked c -> return (Blocked (Cont (unsafeToHaxlException (toHaxl c))))     other -> return other  -- | Like 'try', but lifts all exceptions into the 'HaxlException'@@ -331,12 +393,12 @@     -- will be fetched in the next round.     Uncached rvar -> do       modifyIORef' ref $ \bs -> addRequest (BlockedFetch req rvar) bs-      return $ Blocked (continueFetch req rvar)+      return $ Blocked (Cont (continueFetch 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 (continueFetch req rvar)+      $ Blocked (Cont (continueFetch req rvar))      -- Cached: either a result, or an exception     Cached (Left ex) -> return (Throw ex)@@ -357,7 +419,7 @@ uncachedRequest req = GenHaxl $ \_env ref -> do   rvar <- newEmptyResult   modifyIORef' ref $ \bs -> addRequest (BlockedFetch req rvar) bs-  return $ Blocked (continueFetch req rvar)+  return $ Blocked (Cont (continueFetch req rvar))  continueFetch   :: (DataSource u r, Request r a, Show a)@@ -526,7 +588,7 @@   let roundtime = realToFrac (diffUTCTime t1 t0) :: Double    ifReport f 1 $-    modifyIORef' sref $ \(Stats rounds) ->+    modifyIORef' sref $ \(Stats rounds) -> roundstats `deepseq`       Stats (RoundStats (microsecs roundtime) dsroundstats: rounds)    ifTrace f 1 $@@ -645,21 +707,26 @@ -- of 'dumpCacheAsHaskell'. -- cachedComputation-   :: forall req u a. (Request req a)+   :: forall req u 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.insert req (MemoVar memovar) cache+      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 (retryMemo req))+          | 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.@@ -688,8 +755,8 @@       Done a -> complete memovar (Right a)       Throw e -> complete memovar (Left e)       Blocked cont -> do-        writeIORef memovar (MemoInProgress ref cont)-        return (Blocked (retryMemo req))+        writeIORef memovar (MemoInProgress ref (toHaxl cont))+        return (Blocked (Cont (retryMemo req)))    -- We're finished: store the final result   complete memovar r = do

@@ -16,6 +16,8 @@ -- of requests, the 'contents' operation extracts the fetches, bucketed -- by 'DataSource'. --+-- This module is provided for access to Haxl internals only; most+-- users should not need to import it. module Haxl.Core.RequestStore (     BlockedFetches(..), RequestStore,     noRequests, addRequest, contents

@@ -5,6 +5,8 @@ -- found in the LICENSE file. An additional grant of patent rights can -- be found in the PATENTS file. +-- Most users should import "Haxl.Core" instead of importing this+-- module directly. module Haxl.Core.Show1   ( Show1(..)   ) where

@@ -11,6 +11,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE CPP #-} +-- | Most users should import "Haxl.Core" instead of importing this+-- module directly. module Haxl.Core.StateStore (     StateKey(..), StateStore, stateGet, stateSet, stateEmpty   ) where

@@ -17,12 +17,10 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} --- | Base types used by all of Haxl.+-- | Base types used by all of Haxl. Most users should import+-- "Haxl.Core" instead of importing this module directly. module Haxl.Core.Types ( -  -- * Initialization strategies-  InitStrategy(..),-   -- * Tracing flags   Flags(..),   defaultFlags,@@ -91,16 +89,6 @@ import Haxl.Core.Show1 import Haxl.Core.StateStore --- | Initialization strategy. 'FullInit' will do as much initialization as--- possible. 'FastInit' will postpone part of initialization or omit part of--- initialization by sharing more resources. Use 'FastInit' if you want--- fast initialization but don't care much about performance, for example, in--- interactive environment.-data InitStrategy-  = FullInit-  | FastInit-  deriving (Enum, Eq, Show)- -- | Flags that control the operation of the engine. data Flags = Flags   { trace :: Int@@ -201,7 +189,7 @@ class (DataSourceName req, StateKey req, Show1 req) => DataSource u req where    -- | Issues a list of fetches to this 'DataSource'. The 'BlockedFetch'-  -- objects contain both the request and the 'MVar's into which to put+  -- objects contain both the request and the 'ResultVar's into which to put   -- the results.   fetch     :: State req@@ -263,7 +251,7 @@ -- --   * The request to fetch (with result type @a@) -----   * An 'MVar' to store either the result or an error+--   * A 'ResultVar' to store either the result or an error -- -- We often want to collect together multiple requests, but they return -- different types, and the type system wouldn't let us put them@@ -271,10 +259,10 @@ -- same type. So we wrap up these types inside the 'BlockedFetch' type, -- so that they all look the same and we can put them in a list. ----- When we unpack the 'BlockedFetch' and get the request and the 'MVar'+-- When we unpack the 'BlockedFetch' and get the request and the 'ResultVar' -- out, the type system knows that the result type of the request--- matches the type parameter of the 'MVar', so it will let us take the--- result of the request and store it in the 'MVar'.+-- matches the type parameter of the 'ResultVar', so it will let us take the+-- result of the request and store it in the 'ResultVar'. -- data BlockedFetch r = forall a. BlockedFetch (r a) (ResultVar a) @@ -285,9 +273,11 @@ except :: (Exception e) => e -> Either SomeException a except = Left . toException --- | A sink for the result of a data fetch, used by 'BlockedFetch' and the--- 'DataCache'. Why do we need an 'MVar' here?  The reason is that the cache--- serves two purposes:+-- | A sink for the result of a data fetch in 'BlockedFetch'+newtype ResultVar a = ResultVar (MVar (Either SomeException a))++-- Why do we need an 'MVar' here?  The reason is that the+-- cache serves two purposes: -- --  1. To cache the results of requests that were submitted in a previous round. --@@ -304,8 +294,6 @@ --     current round, and after the round we can read the result of each request --     from its 'MVar'. All instances of identical requests will share the same --     'MVar' to obtain the result.----newtype ResultVar a = ResultVar (MVar (Either SomeException a))  newResult :: a -> IO (ResultVar a) newResult x = ResultVar <$> newMVar (Right x)

@@ -13,7 +13,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}  -- | Support for using Haxl as a DSL.  This module provides most of--- the standard Prelude, plus a selection of stuff that makes it+-- the standard Prelude, plus a selection of stuff that makes -- Haxl client code cleaner and more concise. -- -- We intend Haxl client code to:@@ -32,7 +32,7 @@     module Prelude,      -- * Haxl and Fetching data-    GenHaxl, dataFetch, DataSource,+    GenHaxl, dataFetch, DataSource, memo,      -- * Extra Monad and Applicative things     Applicative(..),@@ -66,6 +66,7 @@  import Haxl.Core.Types import Haxl.Core.Exception+import Haxl.Core.Memo import Haxl.Core.Monad  import Control.Applicative

@@ -1,23 +1,33 @@-Additional Grant of Patent Rights+Additional Grant of Patent Rights Version 2  "Software" means the Haxl software distributed by Facebook, Inc. -Facebook hereby grants you a perpetual, worldwide, royalty-free, non-exclusive,-irrevocable (subject to the termination provision below) license under any-rights in any patent claims owned by Facebook, to make, have made, use, sell,-offer to sell, import, and otherwise transfer the Software. For avoidance of-doubt, no license is granted under Facebook's rights in any patent claims that-are infringed by (i) modifications to the Software made by you or a third party,-or (ii) the Software in combination with any software or other technology-provided by you or a third party.+Facebook, Inc. ("Facebook") hereby grants to each recipient of the Software+("you") a perpetual, worldwide, royalty-free, non-exclusive, irrevocable+(subject to the termination provision below) license under any Necessary+Claims, to make, have made, use, sell, offer to sell, import, and otherwise+transfer the Software. For avoidance of doubt, no license is granted under+Facebook’s rights in any patent claims that are infringed by (i) modifications+to the Software made by you or any third party or (ii) the Software in+combination with any software or other technology.  The license granted hereunder will terminate, automatically and without notice,-for anyone that makes any claim (including by filing any lawsuit, assertion or-other action) alleging (a) direct, indirect, or contributory infringement or-inducement to infringe any patent: (i) by Facebook or any of its subsidiaries or-affiliates, whether or not such claim is related to the Software, (ii) by any-party if such claim arises in whole or in part from any software, product or-service of Facebook or any of its subsidiaries or affiliates, whether or not-such claim is related to the Software, or (iii) by any party relating to the-Software; or (b) that any right in any patent claim of Facebook is invalid or-unenforceable.+if you (or any of your subsidiaries, corporate affiliates or agents) initiate+directly or indirectly, or take a direct financial interest in, any Patent+Assertion: (i) against Facebook or any of its subsidiaries or corporate+affiliates, (ii) against any party if such Patent Assertion arises in whole or+in part from any software, technology, product or service of Facebook or any of+its subsidiaries or corporate affiliates, or (iii) against any party relating+to the Software. Notwithstanding the foregoing, if Facebook or any of its+subsidiaries or corporate affiliates files a lawsuit alleging patent+infringement against you in the first instance, and you respond by filing a+patent infringement counterclaim in that lawsuit against that party that is+unrelated to the Software, the license granted hereunder will not terminate+under section (i) of this paragraph due to such counterclaim.++A "Necessary Claim" is a claim of a patent owned by Facebook that is+necessarily infringed by the Software standing alone.++A "Patent Assertion" is any lawsuit or other action alleging direct, indirect,+or contributory infringement or inducement to infringe any patent, including a+cross-claim or counterclaim.

@@ -0,0 +1,19 @@+# Changes in version 0.3.0.0++  * Some performance improvements, including avoiding quadratic+    slowdown with left-associated binds.++  * Documentation cleanup; Haxl.Core is the single entry point for the+    core and engine docs.++  * (>>) is now defined to be (*>), and therefore no longer forces+    sequencing.  This can have surprising consequences if you are+    using Haxl with side-effecting data sources, so watch out!++  * New function withEnv, for running a sub-computation in a local Env++  * Add a higher-level memoization API, see 'memo'++  * Show is no longer required for keys in cachedComputation++  * Exceptions now have `Eq` instances

@@ -1,5 +1,5 @@ name:                haxl-version:             0.2.0.0+version:             0.3.0.0 synopsis:            A Haskell library for efficient, concurrent,                      and concise data access. homepage:            https://github.com/facebook/Haxl@@ -17,11 +17,23 @@ description:   Haxl is a library and EDSL for efficient scheduling of concurrent data   accesses with a concise applicative API.+  .+  To use Haxl, you need to implement one or more /data sources/, which+  provide the means for accessing remote data or other I/O that you+  want to perform using Haxl.+  .+  Haxl provides two top-level modules:+  .+  * /Data-source implementations/ import "Haxl.Core",+  .+  * /Client code/ import your data sources and "Haxl.Prelude", or some+   other client-level API that you provide.  extra-source-files:   readme.md   PATENTS   tests/LoadCache.txt+  changelog.md  library @@ -31,6 +43,7 @@     base == 4.*,     bytestring >= 0.9 && < 0.11,     containers == 0.5.*,+    deepseq,     directory >= 1.1 && < 1.3,     filepath >= 1.3 && < 1.5,     hashable == 1.2.*,@@ -49,6 +62,7 @@     Haxl.Core.StateStore,     Haxl.Core.Show1,     Haxl.Core.Types,+    Haxl.Core.Memo,     Haxl.Prelude    other-modules:@@ -94,8 +108,26 @@     MockTAO     TestExampleDataSource     TestTypes+    TestUtils    type:     exitcode-stdio-1.0    default-language: Haskell2010++executable monadbench+  default-language:+    Haskell2010+  hs-source-dirs:+    tests+  build-depends:+    base,+    haxl,+    hashable,+    time+  main-is:+    MonadBench.hs+  other-modules:+    ExampleDataSource+  ghc-options:+    -O2 -main-is MonadBench -rtsopts

@@ -2,13 +2,11 @@ module BatchTests (tests) where  import TestTypes+import TestUtils import MockTAO  import Control.Applicative-import Data.IORef-import Data.Aeson import Test.HUnit-import qualified Data.HashMap.Strict as HashMap  import Haxl.Core @@ -17,51 +15,6 @@  -- ----------------------------------------------------------------------------- -testinput :: Object-testinput = HashMap.fromList [-  "A" .= (1 :: Int),-  "B" .= (2 :: Int),-  "C" .= (3 :: Int),-  "D" .= (4 :: Int) ]--makeTestEnv :: IO (Env UserEnv)-makeTestEnv = do-  tao <- MockTAO.initGlobalState-  let st = stateSet tao stateEmpty-  initEnv st testinput--expectRoundsWithEnv-  :: (Eq a, Show a) => Int -> a -> Haxl a -> Env UserEnv -> Assertion-expectRoundsWithEnv n result haxl env = do-  a <- runHaxl env haxl-  assertEqual "result" result a-  stats <- readIORef (statsRef env)-  assertEqual "rounds" n (numRounds stats)--expectRounds :: (Eq a, Show a) => Int -> a -> Haxl a -> Assertion-expectRounds n result haxl = do-  env <- makeTestEnv-  expectRoundsWithEnv n result haxl env--expectFetches :: (Eq a, Show a) => Int -> Haxl a -> Assertion-expectFetches n haxl = do-  env <- makeTestEnv-  _ <- runHaxl env haxl-  stats <- readIORef (statsRef env)-  assertEqual "fetches" n (numFetches stats)--friendsOf :: Id -> Haxl [Id]-friendsOf = assocRangeId2s friendsAssoc--id1 :: Haxl Id-id1 = lookupInput "A"--id2 :: Haxl Id-id2 = lookupInput "B"--id3 :: Haxl Id-id3 = lookupInput "C"- -- -- Test batching over multiple arguments in liftA2 --@@ -142,6 +95,12 @@   b = length <$> (id2 >>= friendsOf)   c = length <$> (id3 >>= friendsOf) +-- (>>) should batch, so we expect one round+batching9 = expectRounds 1 6 batching9_++batching9_ :: Haxl Int+batching9_ = (id1 >>= friendsOf) >> (length <$> (id2 >>= friendsOf))+ -- -- Test data caching, numFetches --@@ -179,24 +138,6 @@   -- ensure no more data fetching rounds needed   expectRoundsWithEnv 0 12 batching7_ env2 -tests = TestList-  [ TestLabel "batching1" $ TestCase batching1-  , TestLabel "batching2" $ TestCase batching2-  , TestLabel "batching3" $ TestCase batching3-  , TestLabel "batching4" $ TestCase batching4-  , TestLabel "batching5" $ TestCase batching5-  , TestLabel "batching6" $ TestCase batching6-  , TestLabel "batching7" $ TestCase batching7-  , TestLabel "batching8" $ TestCase batching8-  , TestLabel "caching1" $ TestCase caching1-  , TestLabel "caching2" $ TestCase caching2-  , TestLabel "caching3" $ TestCase caching3-  , TestLabel "CacheReuse" $ TestCase cacheReuse-  , TestLabel "exceptionTest1" $ TestCase exceptionTest1-  , TestLabel "exceptionTest2" $ TestCase exceptionTest2-  , TestLabel "deterministicExceptions" $ TestCase deterministicExceptions-  ]- exceptionTest1 = expectRounds 1 []   $ withDefault [] $ friendsOf 101 @@ -224,3 +165,22 @@     case r of      Left (NotFound "xxx") -> True      _ -> False++tests = TestList+  [ TestLabel "batching1" $ TestCase batching1+  , TestLabel "batching2" $ TestCase batching2+  , TestLabel "batching3" $ TestCase batching3+  , TestLabel "batching4" $ TestCase batching4+  , TestLabel "batching5" $ TestCase batching5+  , TestLabel "batching6" $ TestCase batching6+  , TestLabel "batching7" $ TestCase batching7+  , TestLabel "batching8" $ TestCase batching8+  , TestLabel "batching9" $ TestCase batching9+  , TestLabel "caching1" $ TestCase caching1+  , TestLabel "caching2" $ TestCase caching2+  , TestLabel "caching3" $ TestCase caching3+  , TestLabel "CacheReuse" $ TestCase cacheReuse+  , TestLabel "exceptionTest1" $ TestCase exceptionTest1+  , TestLabel "exceptionTest2" $ TestCase exceptionTest2+  , TestLabel "deterministicExceptions" $ TestCase deterministicExceptions+  ]

@@ -12,7 +12,7 @@     initGlobalState,      -- * requests for this data source-    ExampleReq(..),+    Id(..), ExampleReq(..),     countAardvarks,     listWombats,   ) where@@ -142,8 +142,9 @@ fetch1 (BlockedFetch (CountAardvarks str) m) =   putSuccess m (length (filter (== 'a') str)) fetch1 (BlockedFetch (ListWombats a) r) =-  if a > 99 then putFailure r $ FetchError "too large"-            else putSuccess r $ take (fromIntegral a) [1..]+  if a > 999999+    then putFailure r $ FetchError "too large"+    else putSuccess r $ take (fromIntegral a) [1..]   -- Normally a data source will provide some convenient wrappers for

@@ -1,10 +1,13 @@-{-# LANGUAGE RebindableSyntax, OverloadedStrings #-}+{-# 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@@ -17,4 +20,7 @@   , TestLabel "BatchTests" BatchTests.tests   , TestLabel "CoreTests" CoreTests.tests   , TestLabel "DataCacheTests" DataCacheTest.tests+#ifdef HAVE_APPLICATIVEDO+  , TestLabel "AdoTests" AdoTests.tests+#endif   ]

@@ -12,6 +12,7 @@     initGlobalState,     assocRangeId2s,     friendsAssoc,+    friendsOf,   ) where  import Data.Hashable@@ -72,3 +73,6 @@  assocRangeId2s :: Id -> Id -> Haxl [Id] assocRangeId2s a b = dataFetch (AssocRangeId2s a b)++friendsOf :: Id -> Haxl [Id]+friendsOf = assocRangeId2s friendsAssoc

@@ -0,0 +1,64 @@+-- 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.++module MonadBench (main) where++import Control.Monad+import Data.Time.Clock+import System.Environment+import System.Exit+import System.IO+import Text.Printf++import Haxl.Prelude as Haxl+import Prelude()++import Haxl.Core++import ExampleDataSource++testEnv :: IO (Env ())+testEnv = do+  exstate <- ExampleDataSource.initGlobalState+  let st = stateSet exstate stateEmpty+  initEnv st ()++main = do+  [test,n_] <- getArgs+  let n = read n_+  env <- testEnv+  t0 <- getCurrentTime+  case test of+    -- parallel, identical queries+    "par1" -> runHaxl env $+       Haxl.sequence_ (replicate n (listWombats 3))+    -- parallel, distinct queries+    "par2" -> runHaxl env $+       Haxl.sequence_ (map listWombats [1..fromIntegral n])+    -- sequential, identical queries+    "seqr" -> runHaxl env $+       foldr andThen (return ()) (replicate n (listWombats 3))+    -- sequential, left-associated, distinct queries+    "seql" -> runHaxl env $ do+       foldl andThen (return []) (map listWombats [1.. fromIntegral n])+       return ()+    "tree" -> runHaxl env $ void $ tree n+    _ -> do+      hPutStrLn stderr "syntax: monadbench par1|par2|seqr|seql NUM"+      exitWith (ExitFailure 1)+  t1 <- getCurrentTime+  printf "%d reqs: %.2fs\n" n (realToFrac (t1 `diffUTCTime` t0) :: Double)+ where+  -- can't use >>, it is aliased to *> and we want the real bind here+  andThen x y = x >>= const y++tree :: Int -> GenHaxl () [Id]+tree 0 = listWombats 0+tree n = concat <$> Haxl.sequence+  [ tree (n-1)+  , listWombats (fromIntegral n), tree (n-1)+  ]

@@ -31,6 +31,7 @@   TestLabel "orderTest" orderTest,   TestLabel "preCacheTest" preCacheTest,   TestLabel "cachedComputationTest" cachedComputationTest,+  TestLabel "memoTest" memoTest,   TestLabel "dataSourceExceptionTest" dataSourceExceptionTest,   TestLabel "dumpCacheAsHaskell" dumpCacheTest] @@ -118,6 +119,23 @@   r <- runHaxl env' $ x + x + countAardvarks "baba"    assertEqual "cachedComputationTest1" 62 r++  stats <- readIORef (statsRef env)+  assertEqual "fetches" 3 (numFetches stats)++-- Pretend CountAardvarks is a request computed by some Haxl code+memoTest = TestCase $ do+  env <- testEnv+  let env' = env { flags = (flags env){trace = 3} }++  let x = memo (CountAardvarks "ababa") $ do+        a <- length <$> listWombats 10+        b <- length <$> listWombats 20+        return (a + b)++  r <- runHaxl env' $ x + x + countAardvarks "baba"++  assertEqual "memoTest1" 62 r    stats <- readIORef (statsRef env)   assertEqual "fetches" 3 (numFetches stats)

@@ -0,0 +1,67 @@+{-# LANGUAGE OverloadedStrings #-}+module TestUtils+  ( makeTestEnv+  , expectRoundsWithEnv+  , expectRounds+  , expectFetches+  , testinput+  , id1, id2, id3, id4+  ) where++import TestTypes+import MockTAO++import Data.IORef+import Data.Aeson+import Test.HUnit+import qualified Data.HashMap.Strict as HashMap++import Haxl.Core++import Prelude()+import Haxl.Prelude++testinput :: Object+testinput = HashMap.fromList [+  "A" .= (1 :: Int),+  "B" .= (2 :: Int),+  "C" .= (3 :: Int),+  "D" .= (4 :: Int) ]++id1 :: Haxl Id+id1 = lookupInput "A"++id2 :: Haxl Id+id2 = lookupInput "B"++id3 :: Haxl Id+id3 = lookupInput "C"++id4 :: Haxl Id+id4 = lookupInput "D"++makeTestEnv :: IO (Env UserEnv)+makeTestEnv = do+  tao <- MockTAO.initGlobalState+  let st = stateSet tao stateEmpty+  initEnv st testinput++expectRoundsWithEnv+  :: (Eq a, Show a) => Int -> a -> Haxl a -> Env UserEnv -> Assertion+expectRoundsWithEnv n result haxl env = do+  a <- runHaxl env haxl+  assertEqual "result" result a+  stats <- readIORef (statsRef env)+  assertEqual "rounds" n (numRounds stats)++expectRounds :: (Eq a, Show a) => Int -> a -> Haxl a -> Assertion+expectRounds n result haxl = do+  env <- makeTestEnv+  expectRoundsWithEnv n result haxl env++expectFetches :: (Eq a, Show a) => Int -> Haxl a -> Assertion+expectFetches n haxl = do+  env <- makeTestEnv+  _ <- runHaxl env haxl+  stats <- readIORef (statsRef env)+  assertEqual "fetches" n (numFetches stats)