haxl 0.5.1.0 → 2.0.0.0

raw patch · 44 files changed

+3547/−2190 lines, 44 filesdep +semigroupsdep +stmdep ~HUnitdep ~aesondep ~basenew-component:exe:cachebenchPVP ok

version bump matches the API change (PVP)

Dependencies added: semigroups, stm

Dependency ranges changed: HUnit, aeson, base, exceptions, hashable, time

API changes (from Hackage documentation)

Files

• Haxl/Core.hs +80/−76
• Haxl/Core/DataCache.hs +38/−9
• Haxl/Core/DataSource.hs +390/−0
• Haxl/Core/Exception.hs +3/−2
• Haxl/Core/Fetch.hs +538/−0
• Haxl/Core/Flags.hs +75/−0
• Haxl/Core/Memo.hs +272/−16
• Haxl/Core/Monad.hs +761/−1257
• Haxl/Core/Parallel.hs +84/−0
• Haxl/Core/Profile.hs +158/−0
• Haxl/Core/RequestStore.hs +13/−6
• Haxl/Core/Run.hs +220/−0
• Haxl/Core/ShowP.hs +3/−2
• Haxl/Core/StateStore.hs +22/−16
• Haxl/Core/Stats.hs +209/−0
• Haxl/Core/Types.hs +0/−636
• Haxl/Core/Util.hs +3/−20
• Haxl/DataSource/ConcurrentIO.hs +83/−0
• Haxl/Prelude.hs +4/−3
• PATENTS +0/−33
• changelog.md +23/−0
• haxl.cabal +57/−14
• readme.md +9/−0
• tests/AdoTests.hs +10/−4
• tests/AllTests.hs +11/−2
• tests/BadDataSource.hs +6/−0
• tests/BatchTests.hs +41/−33
• tests/Bench.hs +9/−3
• tests/CoreTests.hs +85/−4
• tests/DataCacheTest.hs +29/−8
• tests/ExampleDataSource.hs +10/−5
• tests/FullyAsyncTest.hs +66/−0
• tests/LoadCache.hs +6/−0
• tests/MemoizationTests.hs +7/−1
• tests/MockTAO.hs +13/−4
• tests/MonadBench.hs +4/−9
• tests/ProfileTests.hs +38/−8
• tests/SleepDataSource.hs +46/−0
• tests/TestBadDataSource.hs +6/−0
• tests/TestExampleDataSource.hs +42/−9
• tests/TestMain.hs +6/−0
• tests/TestTypes.hs +6/−0
• tests/TestUtils.hs +17/−10
• tests/WorkDataSource.hs +44/−0

@@ -2,103 +2,107 @@ -- 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.+-- found in the LICENSE file.  -- | Everything needed to define data sources and to invoke the -- engine. -- module Haxl.Core (-  -- * The monad and operations-  GenHaxl (..), runHaxl,+    -- * The monad and operations+    GenHaxl (..), runHaxl -  -- ** Env-  Env(..), Caches, caches,-  -- *** Operations in the monad-  env, withEnv, withLabel,-  -- *** Building the Env-  initEnvWithData, initEnv, emptyEnv,-  -- *** Building the StateStore-  StateStore, stateGet, stateSet, stateEmpty,+    -- ** Env+  , Env(..), Caches, caches+    -- *** Operations in the monad+  , env, withEnv, withLabel+    -- *** Building the Env+  , initEnvWithData, initEnv, emptyEnv+    -- *** Building the StateStore+  , StateStore, stateGet, stateSet, stateEmpty -  -- ** Exceptions-  throw, catch, catchIf, try, tryToHaxlException,+    -- ** Exceptions+  , throw, catch, catchIf, try, tryToHaxlException -  -- ** Data fetching and caching-  dataFetch, uncachedRequest,-  cacheRequest, cacheResult, cacheResultWithShow, cachedComputation,-  dumpCacheAsHaskell,+    -- ** Data fetching and caching+  , dataFetch, uncachedRequest+  , cacheRequest, cacheResult, cacheResultWithShow+  , cachedComputation, preCacheComputation+  , dumpCacheAsHaskell -  -- ** Memoization-  memo, memoize, memoize1, memoize2,-  memoFingerprint, MemoFingerprintKey(..),+    -- ** Memoization+  , newMemo, newMemoWith, prepareMemo, runMemo+  , memo, memoize, memoize1, memoize2+  , memoFingerprint, MemoFingerprintKey(..) -  -- ** Conditionals-  pAnd, pOr,+    -- ** Conditionals+  , pAnd, pOr -  -- ** Statistics-  Stats(..),-  RoundStats(..),-  DataSourceRoundStats(..),-  Microseconds,-  emptyStats,-  numRounds,-  numFetches,-  ppStats,-  ppRoundStats,-  ppDataSourceRoundStats,-  Profile,-  emptyProfile,-  profile,-  profileRound,-  profileCache,-  ProfileLabel,-  ProfileData(..),-  emptyProfileData,+    -- ** Statistics+  , Stats(..)+  , FetchStats(..)+  , Microseconds+  , Timestamp+  , emptyStats+  , numRounds+  , numFetches+  , ppStats+  , ppFetchStats+  , Profile+  , emptyProfile+  , profile+  , ProfileLabel+  , ProfileData(..)+  , emptyProfileData+  , AllocCount+  , MemoHitCount -  -- ** Tracing flags-  Flags(..),-  defaultFlags,-  ifTrace,-  ifReport,-  ifProfiling,+    -- ** Tracing flags+  , Flags(..)+  , defaultFlags+  , ifTrace+  , ifReport+  , ifProfiling -  -- * Building data sources-  DataSource(..),-  ShowP(..),-  DataSourceName(..),-  Request,-  BlockedFetch(..),-  PerformFetch(..),-  StateKey(..),+    -- * Building data sources+  , DataSource(..)+  , ShowP(..)+  , DataSourceName(..)+  , Request+  , BlockedFetch(..)+  , PerformFetch(..)+  , StateKey(..)+  , SchedulerHint(..) -  -- ** Result variables-  ResultVar(..),-  newEmptyResult,-  newResult,-  putFailure,-  putResult,-  putSuccess,-  takeResult,-  tryReadResult,-  tryTakeResult,+    -- ** Result variables+  , ResultVar(..)+  , mkResultVar+  , putFailure+  , putResult+  , putSuccess+  , putResultFromChildThread -  -- ** Default fetch implementations-  asyncFetch, asyncFetchWithDispatch, asyncFetchAcquireRelease,-  stubFetch,-  syncFetch,+    -- ** Default fetch implementations+  , asyncFetch, asyncFetchWithDispatch, asyncFetchAcquireRelease+  , stubFetch+  , syncFetch -  -- ** Utilities-  except,-  setError,+    -- ** Utilities+  , except+  , setError -  -- * Exceptions-  module Haxl.Core.Exception+    -- * Exceptions+  , module Haxl.Core.Exception   ) where +import Haxl.Core.DataSource+import Haxl.Core.Flags import Haxl.Core.Memo import Haxl.Core.Monad hiding (unsafeLiftIO {- Ask nicely to get this! -})-import Haxl.Core.Types+import Haxl.Core.Fetch+import Haxl.Core.Parallel+import Haxl.Core.Profile+import Haxl.Core.Run+import Haxl.Core.Stats import Haxl.Core.Exception import Haxl.Core.ShowP (ShowP(..)) import Haxl.Core.StateStore

@@ -2,17 +2,19 @@ -- 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.+-- found in the LICENSE file.  {-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} --- | A cache mapping data requests to their results.  This module is+-- |+-- 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(..)   , SubCache(..)@@ -24,19 +26,44 @@   , showCache   ) where +import Control.Exception import Data.Hashable import Prelude hiding (lookup) import Unsafe.Coerce+import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Typeable import Data.Maybe #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) #endif-import Control.Exception -import Haxl.Core.Types+-- ---------------------------------------------------------------------------+-- DataCache +-- | A @'DataCache' res@ maps things of type @req a@ to @res a@, for+-- any @req@ and @a@ provided @req a@ is an instance of 'Typeable'. In+-- practice @req a@ will be a request type parameterised by its result.+--+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++ -- | Inserts a request-result pair into the 'DataCache'. insert   :: (Hashable (req a), Typeable (req a), Eq (req a), Show (req a), Show a)@@ -109,20 +136,22 @@ -- 'insertNotShowable' has been used to insert any entries. -- showCache-  :: DataCache ResultVar+  :: forall res+  .  DataCache res+  -> (forall a . res a -> IO (Maybe (Either SomeException a)))   -> IO [(TypeRep, [(String, Either SomeException String)])] -showCache (DataCache cache) = mapM goSubCache (HashMap.toList cache)+showCache (DataCache cache) readRes = mapM goSubCache (HashMap.toList cache)  where   goSubCache-    :: (TypeRep,SubCache ResultVar)+    :: (TypeRep, SubCache res)     -> IO (TypeRep,[(String, Either SomeException String)])   goSubCache (ty, SubCache showReq showRes hmap) = do     elems <- catMaybes <$> mapM go (HashMap.toList hmap)     return (ty, elems)    where     go  (req, rvar) = do-      maybe_r <- tryReadResult rvar+      maybe_r <- readRes rvar       case maybe_r of         Nothing -> return Nothing         Just (Left e) -> return (Just (showReq req, Left e))

@@ -0,0 +1,390 @@+-- Copyright (c) 2014-present, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file.++{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- The 'DataSource' class and related types and functions.  This+-- module is provided for access to Haxl internals only; most users+-- should import "Haxl.Core" instead.+--+module Haxl.Core.DataSource+  (+  -- * Data fetching+    DataSource(..)+  , DataSourceName(..)+  , Request+  , BlockedFetch(..)+  , PerformFetch(..)+  , SchedulerHint(..)++  -- * Result variables+  , ResultVar(..)+  , mkResultVar+  , putFailure+  , putResult+  , putResultFromChildThread+  , putSuccess++  -- * Default fetch implementations+  , asyncFetch, asyncFetchWithDispatch+  , asyncFetchAcquireRelease+  , stubFetch+  , syncFetch++  -- * Utilities+  , except+  , setError+  ) where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+#endif+import Control.Exception+import Data.Hashable+import Data.Text (Text)+#if __GLASGOW_HASKELL__ >= 802+import Data.Typeable+#else+import Data.Typeable.Internal+#endif++import Haxl.Core.Exception+import Haxl.Core.Flags+import Haxl.Core.ShowP+import Haxl.Core.StateStore+++-- ---------------------------------------------------------------------------+-- DataSource class++-- | The class of data sources, parameterised over the request type for+-- that data source. Every data source must implement this class.+--+-- A data source keeps track of its state by creating an instance of+-- 'StateKey' to map the request type to its state. In this case, the+-- type of the state should probably be a reference type of some kind,+-- such as 'IORef'.+--+-- For a complete example data source, see+-- <https://github.com/facebook/Haxl/tree/master/example Examples>.+--+class (DataSourceName req, StateKey req, ShowP req) => DataSource u req where++  -- | Issues a list of fetches to this 'DataSource'. The 'BlockedFetch'+  -- objects contain both the request and the 'ResultVar's into which to put+  -- the results.+  fetch+    :: State req+      -- ^ Current state.+    -> Flags+      -- ^ Tracing flags.+    -> u+      -- ^ User environment.+    -> PerformFetch req+      -- ^ Fetch the data; see 'PerformFetch'.++  schedulerHint :: u -> SchedulerHint req+  schedulerHint _ = TryToBatch++class DataSourceName (req :: * -> *) where+  -- | The name of this 'DataSource', used in tracing and stats. Must+  -- take a dummy request.+  dataSourceName :: Proxy req -> Text++-- The 'ShowP' class is a workaround for the fact that we can't write+-- @'Show' (req a)@ as a superclass of 'DataSource', without also+-- parameterizing 'DataSource' over @a@, which is a pain (I tried+-- it). 'ShowP' seems fairly benign, though.++-- | A convenience only: package up 'Eq', 'Hashable', 'Typeable', and 'Show'+-- for requests into a single constraint.+type Request req a =+  ( Eq (req a)+  , Hashable (req a)+  , Typeable (req a)+  , Show (req a)+  , Show a+  )++-- | Hints to the scheduler about this data source+data SchedulerHint (req :: * -> *)+  = TryToBatch+    -- ^ Hold data-source requests while we execute as much as we can, so+    -- that we can hopefully collect more requests to batch.+  | SubmitImmediately+    -- ^ Submit a request via fetch as soon as we have one, don't try to+    -- batch multiple requests.  This is really only useful if the data source+    -- returns BackgroundFetch, otherwise requests to this data source will+    -- be performed synchronously, one at a time.++-- | A data source can fetch data in one of four ways.+--+data PerformFetch req+  = SyncFetch  ([BlockedFetch req] -> IO ())+    -- ^ Fully synchronous, returns only when all the data is fetched.+    -- See 'syncFetch' for an example.+  | AsyncFetch ([BlockedFetch req] -> IO () -> IO ())+    -- ^ Asynchronous; performs an arbitrary IO action while the data+    -- is being fetched, but only returns when all the data is+    -- fetched.  See 'asyncFetch' for an example.+  | BackgroundFetch ([BlockedFetch req] -> IO ())+    -- ^ Fetches the data in the background, calling 'putResult' at+    -- any time in the future.  This is the best kind of fetch,+    -- because it provides the most concurrency.+  | FutureFetch ([BlockedFetch req] -> IO (IO ()))+    -- ^ Returns an IO action that, when performed, waits for the data+    -- to be received.  This is the second-best type of fetch, because+    -- the scheduler still has to perform the blocking wait at some+    -- point in the future, and when it has multiple blocking waits to+    -- perform, it can't know which one will return first.+    --+    -- Why not just forkIO the IO action to make a FutureFetch into a+    -- BackgroundFetch?  The blocking wait will probably do a safe FFI+    -- call, which means it needs its own OS thread.  If we don't want+    -- to create an arbitrary number of OS threads, then FutureFetch+    -- enables all the blocking waits to be done on a single thread.+    -- Also, you might have a data source that requires all calls to+    -- be made in the same OS thread.+++-- | A 'BlockedFetch' is a pair of+--+--   * The request to fetch (with result type @a@)+--+--   * 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+-- together in a list because all the elements of the list must have the+-- 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 'ResultVar'+-- out, the type system knows that the result type of the request+-- 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)+++-- -----------------------------------------------------------------------------+-- ResultVar++-- | A sink for the result of a data fetch in 'BlockedFetch'+newtype ResultVar a = ResultVar (Either SomeException a -> Bool -> IO ())+  -- The Bool here is True if result was returned by a child thread,+  -- rather than the main runHaxl thread.  see Note [tracking allocation in+  -- child threads]++mkResultVar :: (Either SomeException a -> Bool -> IO ()) -> ResultVar a+mkResultVar = ResultVar++putFailure :: (Exception e) => ResultVar a -> e -> IO ()+putFailure r = putResult r . except++putSuccess :: ResultVar a -> a -> IO ()+putSuccess r = putResult r . Right++putResult :: ResultVar a -> Either SomeException a -> IO ()+putResult (ResultVar io) res =  io res False++-- | Like `putResult`, but used to get correct accounting when work is+-- being done in child threads.  This is particularly important for+-- data sources that are using 'BackgroundFetch', The allocation performed+-- in the child thread up to this point will be propagated back to the+-- thread that called 'runHaxl'.+--+-- Note: if you're doing multiple 'putResult' calls in the same thread+-- ensure that only the /last/ one is 'putResultFromChildThread'.  If you+-- make multiple 'putResultFromChildThread' calls, the allocation will be+-- counted multiple times.+--+-- If you are reusing a thread for multiple fetches, you should call+-- @System.Mem.setAllocationCounter 0@ after+-- 'putResultFromChildThread', so that allocation is not counted+-- multiple times.+putResultFromChildThread :: ResultVar a -> Either SomeException a -> IO ()+putResultFromChildThread (ResultVar io) res =  io res True+  -- see Note [tracking allocation in child threads]++-- | Function for easily setting a fetch to a particular exception+setError :: (Exception e) => (forall a. r a -> e) -> BlockedFetch r -> IO ()+setError e (BlockedFetch req m) = putFailure m (e req)++except :: (Exception e) => e -> Either SomeException a+except = Left . toException+++-- -----------------------------------------------------------------------------+-- Fetch templates++stubFetch+  :: (Exception e) => (forall a. r a -> e)+  -> State r -> Flags -> u -> PerformFetch r+stubFetch e _state _flags _si = SyncFetch $ mapM_ (setError e)++-- | Common implementation templates for 'fetch' of 'DataSource'.+--+-- Example usage:+--+-- > fetch = syncFetch MyDS.withService MyDS.retrieve+-- >   $ \service request -> case request of+-- >     This x -> MyDS.fetchThis service x+-- >     That y -> MyDS.fetchThat service y+--+asyncFetchWithDispatch+  :: ((service -> IO ()) -> IO ())+  -- ^ Wrapper to perform an action in the context of a service.++  -> (service -> IO ())+  -- ^ Dispatch all the pending requests++  -> (service -> IO ())+  -- ^ Wait for the results++  -> (forall a. service -> request a -> IO (IO (Either SomeException a)))+  -- ^ Enqueue an individual request to the service.++  -> State request+  -- ^ Currently unused.++  -> Flags+  -- ^ Currently unused.++  -> u+  -- ^ Currently unused.++  -> PerformFetch request++asyncFetch, syncFetch+  :: ((service -> IO ()) -> IO ())+  -- ^ Wrapper to perform an action in the context of a service.++  -> (service -> IO ())+  -- ^ Dispatch all the pending requests and wait for the results++  -> (forall a. service -> request a -> IO (IO (Either SomeException a)))+  -- ^ Submits an individual request to the service.++  -> State request+  -- ^ Currently unused.++  -> Flags+  -- ^ Currently unused.++  -> u+  -- ^ Currently unused.++  -> PerformFetch request++asyncFetchWithDispatch+  withService dispatch wait enqueue _state _flags _si =+  AsyncFetch $ \requests inner -> withService $ \service -> do+    getResults <- mapM (submitFetch service enqueue) requests+    dispatch service+    inner+    wait service+    sequence_ getResults++asyncFetch withService wait enqueue _state _flags _si =+  AsyncFetch $ \requests inner -> withService $ \service -> do+    getResults <- mapM (submitFetch service enqueue) requests+    inner+    wait service+    sequence_ getResults++syncFetch withService dispatch enqueue _state _flags _si =+  SyncFetch $ \requests -> withService $ \service -> do+  getResults <- mapM (submitFetch service enqueue) requests+  dispatch service+  sequence_ getResults+++{- |+A version of 'asyncFetch' (actually 'asyncFetchWithDispatch') that+handles exceptions correctly.  You should use this instead of+'asyncFetch' or 'asyncFetchWithDispatch'.  The danger with+'asyncFetch' is that if an exception is thrown by @withService@, the+@inner@ action won't be executed, and we'll drop some data-fetches in+the same round.++'asyncFetchAcquireRelease' behaves like the following:++> asyncFetchAcquireRelease acquire release dispatch wait enqueue =+>   AsyncFetch $ \requests inner ->+>     bracket acquire release $ \service -> do+>       getResults <- mapM (submitFetch service enqueue) requests+>       dispatch service+>       inner+>       wait service+>       sequence_ getResults++except that @inner@ is run even if @acquire@, @enqueue@, or @dispatch@ throws,+/unless/ an async exception is received.+-}++asyncFetchAcquireRelease+  :: IO service+  -- ^ Resource acquisition for this datasource++  -> (service -> IO ())+  -- ^ Resource release++  -> (service -> IO ())+  -- ^ Dispatch all the pending requests and wait for the results++  -> (service -> IO ())+  -- ^ Wait for the results++  -> (forall a. service -> request a -> IO (IO (Either SomeException a)))+  -- ^ Submits an individual request to the service.++  -> State request+  -- ^ Currently unused.++  -> Flags+  -- ^ Currently unused.++  -> u+  -- ^ Currently unused.++  -> PerformFetch request++asyncFetchAcquireRelease+  acquire release dispatch wait enqueue _state _flags _si =+  AsyncFetch $ \requests inner -> mask $ \restore -> do+    r1 <- tryWithRethrow acquire+    case r1 of+      Left err -> do restore inner; throwIO (err :: SomeException)+      Right service -> do+        flip finally (release service) $ restore $ do+          r2 <- tryWithRethrow $ do+            getResults <- mapM (submitFetch service enqueue) requests+            dispatch service+            return getResults+          inner  --  we assume this cannot throw, ensured by performFetches+          case r2 of+            Left err -> throwIO (err :: SomeException)+            Right getResults -> do wait service; sequence_ getResults++-- | Used by 'asyncFetch' and 'syncFetch' to retrieve the results of+-- requests to a service.+submitFetch+  :: service+  -> (forall a. service -> request a -> IO (IO (Either SomeException a)))+  -> BlockedFetch request+  -> IO (IO ())+submitFetch service fetch (BlockedFetch request result)+  = (putResult result =<<) <$> fetch service request

@@ -2,8 +2,7 @@ -- 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.+-- found in the LICENSE file.  {-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -29,6 +28,7 @@ -- -- Most users should import "Haxl.Core" instead of importing this -- module directly.+-- module Haxl.Core.Exception (    HaxlException(..),@@ -53,6 +53,7 @@   -- ** Internal exceptions   CriticalError(..),   DataSourceError(..),+  NonHaxlException(..),    -- ** Logic exceptions   NotFound(..),

@@ -0,0 +1,538 @@+-- Copyright (c) 2014-present, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file.++{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Implementation of data-fetching operations.  Most users should+-- import "Haxl.Core" instead.+--+module Haxl.Core.Fetch+  ( dataFetch+  , dataFetchWithShow+  , uncachedRequest+  , cacheResult+  , cacheResultWithShow+  , cacheRequest+  , performFetches+  , performRequestStore+  , ShowReq+  ) where++import Control.Concurrent.STM+import Control.Exception as Exception+import Control.Monad+import Data.Either+import Data.Hashable+import Data.IORef+import Data.Int+import Data.List+import Data.Monoid+import Data.Typeable+import Data.Text (Text)+import qualified Data.Text as Text+import Text.Printf+#ifdef PROFILING+import GHC.Stack+#endif++import Haxl.Core.DataSource+import Haxl.Core.DataCache as DataCache+import Haxl.Core.Exception+import Haxl.Core.Flags+import Haxl.Core.Monad+import Haxl.Core.Profile+import Haxl.Core.RequestStore+import Haxl.Core.ShowP+import Haxl.Core.Stats+import Haxl.Core.StateStore+import Haxl.Core.Util++-- -----------------------------------------------------------------------------+-- Data fetching and caching++-- | Possible responses when checking the cache.+data CacheResult u a+  -- | The request hadn't been seen until now.+  = Uncached+       (ResultVar a)+       {-# UNPACK #-} !(IVar u a)++  -- | The request has been seen before, but its result has not yet been+  -- fetched.+  | CachedNotFetched+      {-# UNPACK #-} !(IVar u a)++  -- | The request has been seen before, and its result has already been+  -- fetched.+  | Cached (ResultVal a)+++-- | 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.++cachedWithInsert+  :: forall r a u .+     Typeable (r a)+  => (r a -> String)    -- See Note [showFn]+  -> (r a -> IVar u a -> DataCache (IVar u) -> DataCache (IVar u))+  -> Env u -> r a -> IO (CacheResult u a)+cachedWithInsert showFn insertFn Env{..} req = do+  cache <- readIORef cacheRef+  let+    doFetch = do+      ivar <- newIVar+      let !rvar = stdResultVar ivar completions+      writeIORef cacheRef $! insertFn req ivar cache+      return (Uncached rvar ivar)+  case DataCache.lookup req cache of+    Nothing -> doFetch+    Just (IVar cr) -> do+      e <- readIORef cr+      case e of+        IVarEmpty _ -> return (CachedNotFetched (IVar cr))+        IVarFull r -> do+          ifTrace flags 3 $ putStrLn $ case r of+            ThrowIO _ -> "Cached error: " ++ showFn req+            ThrowHaxl _ -> "Cached error: " ++ showFn req+            Ok _ -> "Cached request: " ++ showFn req+          return (Cached r)+++-- | Make a ResultVar with the standard function for sending a CompletionReq+-- to the scheduler.+stdResultVar :: IVar u a -> TVar [CompleteReq u] -> ResultVar a+stdResultVar ivar completions = mkResultVar $ \r isChildThread -> do+  allocs <- if isChildThread+    then+      -- In a child thread, return the current allocation counter too,+      -- for correct tracking of allocation.+      getAllocationCounter+    else+      return 0+  atomically $ do+    cs <- readTVar completions+    writeTVar completions (CompleteReq r ivar allocs : cs)+{-# INLINE stdResultVar #-}+++-- | Record the call stack for a data fetch in the Stats.  Only useful+-- when profiling.+logFetch :: Env u -> (r a -> String) -> r a -> IO ()+#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 = 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+  :: forall u r a+   . (DataSource u r, Eq (r a), Hashable (r a), Typeable (r a))+  => (r a -> String)    -- See Note [showFn]+  -> (r a -> IVar u a -> DataCache (IVar u) -> DataCache (IVar u))+  -> r a+  -> GenHaxl u a+dataFetchWithInsert showFn insertFn req =+  GenHaxl $ \env@Env{..} -> do+  -- First, check the cache+  res <- cachedWithInsert showFn insertFn env req+  ifProfiling flags $ addProfileFetch env req+  case res of+    -- This request has not been seen before+    Uncached rvar ivar -> do+      logFetch env showFn req+      --+      -- Check whether the data source wants to submit requests+      -- eagerly, or batch them up.+      --+      case schedulerHint userEnv :: SchedulerHint r of+        SubmitImmediately -> do+          (_,ios) <- performFetches 0 env+            [BlockedFetches [BlockedFetch req rvar]]+          when (not (null ios)) $+            error "bad data source:SubmitImmediately but returns FutureFetch"+        TryToBatch ->+          -- add the request to the RequestStore and continue+          modifyIORef' reqStoreRef $ \bs ->+            addRequest (BlockedFetch req rvar) bs+      --+      return $ Blocked ivar (Cont (getIVar ivar))++    -- Seen before but not fetched yet.  We're blocked, but we don't have+    -- to add the request to the RequestStore.+    CachedNotFetched ivar -> return $ Blocked ivar (Cont (getIVar ivar))++    -- Cached: either a result, or an exception+    Cached r -> done r++-- | 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+-- properties that we expect Haxl computations to respect: that data+-- fetches can be arbitrarily reordered, and identical requests can be+-- commoned up, for example.+--+-- 'uncachedRequest' is useful for performing writes, provided those+-- are done in a safe way - that is, not mixed with reads that might+-- conflict in the same Haxl computation.+--+-- if we are recording or running a test, we fallback to using dataFetch+-- This allows us to store the request in the cache when recording, which+-- allows a transparent run afterwards. Without this, the test would try to+-- call the datasource during testing and that would be an exception.+uncachedRequest :: (DataSource u r, Request r a) => r a -> GenHaxl u a+uncachedRequest req = do+  isRecordingFlag <- env (recording . flags)+  if isRecordingFlag /= 0+    then dataFetch req+    else GenHaxl $ \Env{..} -> do+      ivar <- newIVar+      let !rvar = stdResultVar ivar completions+      modifyIORef' reqStoreRef $ \bs ->+        addRequest (BlockedFetch req rvar) bs+      return $ Blocked ivar (Cont (getIVar ivar))+++-- | Transparently provides caching. Useful for datasources that can+-- return immediately, but also caches values.  Exceptions thrown by+-- the IO operation (except for asynchronous exceptions) are+-- propagated into the Haxl monad and can be caught by 'catch' and+-- 'try'.+cacheResult :: Request r a => r a -> IO a -> GenHaxl u a+cacheResult = 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 -> IVar u a -> DataCache (IVar u) -> DataCache (IVar u)) -> r a+  -> IO a -> GenHaxl u a+cacheResultWithInsert showFn insertFn req val = GenHaxl $ \env -> do+  let !ref = cacheRef env+  cache <- readIORef ref+  case DataCache.lookup req cache of+    Nothing -> do+      eitherResult <- Exception.try val+      case eitherResult of+        Left e -> rethrowAsyncExceptions e+        _ -> return ()+      let result = eitherToResultThrowIO eitherResult+      ivar <- newFullIVar result+      writeIORef ref $! insertFn req ivar cache+      done result+    Just (IVar cr) -> do+      e <- readIORef cr+      case e of+        IVarEmpty _ -> corruptCache+        IVarFull r -> done r+  where+    corruptCache = raise . DataSourceError $ Text.concat+      [ 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."+      ]++-- | Inserts a request/result pair into the cache. Throws an exception+-- if the request has already been issued, either via 'dataFetch' or+-- 'cacheRequest'.+--+-- This can be used to pre-populate the cache when running tests, to+-- avoid going to the actual data source and ensure that results are+-- deterministic.+--+cacheRequest+  :: Request req a => req a -> Either SomeException a -> GenHaxl u ()+cacheRequest request result = GenHaxl $ \env -> do+  cache <- readIORef (cacheRef env)+  case DataCache.lookup request cache of+    Nothing -> do+      cr <- newFullIVar (eitherToResult result)+      writeIORef (cacheRef env) $! DataCache.insert request cr cache+      return (Done ())++    -- It is an error if the request is already in the cache.  We can't test+    -- whether the cached result is the same without adding an Eq constraint,+    -- and we don't necessarily have Eq for all results.+    _other -> raise $+      DataSourceError "cacheRequest: request is already in the cache"++performRequestStore+   :: forall u. Int -> Env u -> RequestStore u -> IO (Int, [IO ()])+performRequestStore n env reqStore =+  performFetches n env (contents reqStore)++-- | Issues a batch of fetches in a 'RequestStore'. After+-- 'performFetches', all the requests in the 'RequestStore' are+-- complete, and all of the 'ResultVar's are full.+performFetches+  :: forall u. Int -> Env u -> [BlockedFetches u] -> IO (Int, [IO ()])+performFetches n env@Env{flags=f, statsRef=sref} jobs = do+  let !n' = n + length jobs++  t0 <- getTimestamp++  let+    roundstats =+      [ (dataSourceName (Proxy :: Proxy r), length reqs)+      | BlockedFetches (reqs :: [BlockedFetch r]) <- jobs ]++  ifTrace f 1 $+    printf "Batch data fetch (%s)\n" $+      intercalate (", "::String) $+        map (\(name,num) -> printf "%d %s" num (Text.unpack name)) roundstats++  ifTrace f 3 $+    forM_ jobs $ \(BlockedFetches reqs) ->+      forM_ reqs $ \(BlockedFetch r _) -> putStrLn (showp r)++  let+    applyFetch i (BlockedFetches (reqs :: [BlockedFetch r])) =+      case stateGet (states env) of+        Nothing ->+          return (FetchToDo reqs (SyncFetch (mapM_ (setError e))))+         where+           e :: ShowP req => req a -> DataSourceError+           e req = DataSourceError $ "data source not initialized: " <> dsName+                  <> ": "+                  <> Text.pack (showp req)+        Just state ->+          return+            $ FetchToDo reqs+            $ (if report f >= 2+                then wrapFetchInStats sref dsName (length reqs)+                else id)+            $ wrapFetchInTrace i (length reqs) dsName+            $ wrapFetchInCatch reqs+            $ fetch state f (userEnv env)+      where+        dsName = dataSourceName (Proxy :: Proxy r)++  fetches <- zipWithM applyFetch [n..] jobs++  waits <- scheduleFetches fetches++  t1 <- getTimestamp+  let roundtime = fromIntegral (t1 - t0) / 1000000 :: Double++  ifTrace f 1 $+    printf "Batch data fetch done (%.2fs)\n" (realToFrac roundtime :: Double)++  return (n', waits)++data FetchToDo where+  FetchToDo :: [BlockedFetch req] -> PerformFetch req -> FetchToDo++-- Catch exceptions arising from the data source and stuff them into+-- the appropriate requests.  We don't want any exceptions propagating+-- directly from the data sources, because we want the exception to be+-- thrown by dataFetch instead.+--+wrapFetchInCatch :: [BlockedFetch req] -> PerformFetch req -> PerformFetch req+wrapFetchInCatch reqs fetch =+  case fetch of+    SyncFetch f ->+      SyncFetch $ \reqs -> f reqs `Exception.catch` handler+    AsyncFetch f ->+      AsyncFetch $ \reqs io -> f reqs io `Exception.catch` handler+      -- this might be wrong: if the outer 'fio' throws an exception,+      -- then we don't know whether we have executed the inner 'io' or+      -- not.  If not, then we'll likely get some errors about "did+      -- not set result var" later, because we haven't executed some+      -- data fetches.  But we can't execute 'io' in the handler,+      -- because we might have already done it.  It isn't possible to+      -- do it completely right here, so we have to rely on data+      -- sources themselves to catch (synchronous) exceptions.  Async+      -- exceptions aren't a problem because we're going to rethrow+      -- them all the way to runHaxl anyway.+    FutureFetch f ->+      FutureFetch $ \reqs -> f reqs `Exception.catch` (+                     \e -> handler e >> return (return ()))+    BackgroundFetch f ->+      BackgroundFetch $ \reqs -> f reqs `Exception.catch` handler+  where+    handler :: SomeException -> IO ()+    handler e = do+      rethrowAsyncExceptions e+      mapM_ (forceError e) reqs++    -- Set the exception even if the request already had a result.+    -- Otherwise we could be discarding an exception.+    forceError e (BlockedFetch _ rvar) =+      putResult rvar (except e)+++wrapFetchInStats+  :: IORef Stats+  -> Text+  -> Int+  -> PerformFetch req+  -> PerformFetch req++wrapFetchInStats !statsRef dataSource batchSize perform = do+  case perform of+    SyncFetch f ->+      SyncFetch $ \reqs -> do+        fail_ref <- newIORef 0+        (t0,t,alloc,_) <- statsForIO (f (map (addFailureCount fail_ref) reqs))+        failures <- readIORef fail_ref+        updateFetchStats t0 t alloc batchSize failures+    AsyncFetch f -> do+      AsyncFetch $ \reqs inner -> do+        inner_r <- newIORef (0, 0)+        fail_ref <- newIORef 0+        let inner' = do+              (_,t,alloc,_) <- statsForIO inner+              writeIORef inner_r (t,alloc)+            reqs' = map (addFailureCount fail_ref) reqs+        (t0, totalTime, totalAlloc, _) <- statsForIO (f reqs' inner')+        (innerTime, innerAlloc) <- readIORef inner_r+        failures <- readIORef fail_ref+        updateFetchStats t0 (totalTime - innerTime) (totalAlloc - innerAlloc)+          batchSize failures+    FutureFetch submit ->+      FutureFetch $ \reqs -> do+        fail_ref <- newIORef 0+        let reqs' = map (addFailureCount fail_ref) reqs+        (t0, submitTime, submitAlloc, wait) <- statsForIO (submit reqs')+        return $ do+          (_, waitTime, waitAlloc, _) <- statsForIO wait+          failures <- readIORef fail_ref+          updateFetchStats t0 (submitTime + waitTime) (submitAlloc + waitAlloc)+            batchSize failures+    BackgroundFetch io -> do+      BackgroundFetch $ \reqs -> do+        startTime <- getTimestamp+        io (map (addTimer startTime) reqs)+  where+    statsForIO io = do+      prevAlloc <- getAllocationCounter+      (t0,t,a) <- time io+      postAlloc <- getAllocationCounter+      return (t0,t, fromIntegral $ prevAlloc - postAlloc, a)++    addTimer t0 (BlockedFetch req (ResultVar fn)) =+      BlockedFetch req $ ResultVar $ \result isChildThread -> do+        t1 <- getTimestamp+        updateFetchStats t0 (t1 - t0)+          0 -- allocs: we can't measure this easily for BackgroundFetch+          1 -- batch size: we don't know if this is a batch or not+          (if isLeft result then 1 else 0) -- failures+        fn result isChildThread++    updateFetchStats+      :: Timestamp -> Microseconds -> Int64 -> Int -> Int -> IO ()+    updateFetchStats start time space batch failures = do+      let this = FetchStats { fetchDataSource = dataSource+                            , fetchBatchSize = batch+                            , fetchStart = start+                            , fetchDuration = time+                            , fetchSpace = space+                            , fetchFailures = failures }+      atomicModifyIORef' statsRef $ \(Stats fs) -> (Stats (this : fs), ())++    addFailureCount :: IORef Int -> BlockedFetch r -> BlockedFetch r+    addFailureCount ref (BlockedFetch req (ResultVar fn)) =+      BlockedFetch req $ ResultVar $ \result isChildThread -> do+        when (isLeft result) $ atomicModifyIORef' ref (\r -> (r+1,()))+        fn result isChildThread++wrapFetchInTrace+  :: Int+  -> Int+  -> Text+  -> PerformFetch req+  -> PerformFetch req+#ifdef EVENTLOG+wrapFetchInTrace i n dsName f =+  case f of+    SyncFetch io -> SyncFetch (wrapF "Sync" io)+    AsyncFetch fio -> AsyncFetch (wrapF "Async" . fio . unwrapF "Async")+  where+    d = Text.unpack dsName+    wrapF :: String -> IO a -> IO a+    wrapF ty = bracket_ (traceEventIO $ printf "START %d %s (%d %s)" i d n ty)+                        (traceEventIO $ printf "STOP %d %s (%d %s)" i d n ty)+    unwrapF :: String -> IO a -> IO a+    unwrapF ty = bracket_ (traceEventIO $ printf "STOP %d %s (%d %s)" i d n ty)+                          (traceEventIO $ printf "START %d %s (%d %s)" i d n ty)+#else+wrapFetchInTrace _ _ _ f = f+#endif++time :: IO a -> IO (Timestamp,Microseconds,a)+time io = do+  t0 <- getTimestamp+  a <- io+  t1 <- getTimestamp+  return (t0, t1 - t0, a)++-- | Start all the async fetches first, then perform the sync fetches before+-- getting the results of the async fetches.+scheduleFetches :: [FetchToDo] -> IO [IO ()]+scheduleFetches fetches = do+  fully_async_fetches+  waits <- future_fetches+  async_fetches sync_fetches+  return waits+ where+  fully_async_fetches :: IO ()+  fully_async_fetches =+    sequence_ [f reqs | FetchToDo reqs (BackgroundFetch f) <- fetches]++  future_fetches :: IO [IO ()]+  future_fetches = sequence [f reqs | FetchToDo reqs (FutureFetch f) <- fetches]++  async_fetches :: IO () -> IO ()+  async_fetches = compose [f reqs | FetchToDo reqs (AsyncFetch f) <- fetches]++  sync_fetches :: IO ()+  sync_fetches = sequence_ [f reqs | FetchToDo reqs (SyncFetch f) <- fetches]

@@ -0,0 +1,75 @@+-- Copyright (c) 2014-present, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file.++{-# LANGUAGE CPP #-}++-- |+-- The 'Flags' type and related functions.  This module is provided+-- for access to Haxl internals only; most users should import+-- "Haxl.Core" instead.+--+module Haxl.Core.Flags+  (+    -- * Tracing flags+    Flags(..)+  , defaultFlags+  , ifTrace+  , ifReport+  , ifProfiling+  ) where++import Control.Monad++-- ---------------------------------------------------------------------------+-- Flags++-- | Flags that control the operation of the engine.+data Flags = Flags+  { trace :: {-# UNPACK #-} !Int+    -- ^ Tracing level (0 = quiet, 3 = very verbose).+  , report :: {-# UNPACK #-} !Int+    -- ^ Report level:+    --    * 0 = quiet+    --    * 1 = quiet (legacy, this used to do something)+    --    * 2 = data fetch stats & errors+    --    * 3 = (same as 2, this used to enable 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, but do not cache+    -- results.+  , recording :: {-# UNPACK #-} !Int+    -- ^ Non-zero if recording is enabled. This allows tests to record cache+    -- calls for datasources by making uncachedRequest behave like dataFetch+  }++defaultFlags :: Flags+defaultFlags = Flags+  { trace = 0+  , report = 0+  , caching = 1+  , recording = 0+  }++#if __GLASGOW_HASKELL__ >= 710+#define FUNMONAD Monad m+#else+#define FUNMONAD (Functor m, Monad m)+#endif++-- | Runs an action if the tracing level is above the given threshold.+ifTrace :: FUNMONAD => Flags -> Int -> m a -> m ()+ifTrace flags i = when (trace flags >= i) . void++-- | Runs an action if the report level is above the given threshold.+ifReport :: FUNMONAD => Flags -> Int -> m a -> m ()+ifReport flags i = when (report flags >= i) . void++ifProfiling :: FUNMONAD => Flags -> m a -> m ()+ifProfiling flags = when (report flags >= 4) . void++#undef FUNMONAD

@@ -2,28 +2,48 @@ -- 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.+-- found in the LICENSE file. +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-} --- | Most users should import "Haxl.Core" instead of importing this--- module directly.-module Haxl.Core.Memo (-  memo,-  memoFingerprint,-  MemoFingerprintKey(..),-  memoize, memoize1, memoize2-) where+-- |+-- Memoization support. This module is provided for access to Haxl+-- internals only; most users should import "Haxl.Core" instead.+--+module Haxl.Core.Memo+  (+    -- * Basic memoization+    cachedComputation+  , preCacheComputation +    -- * High-level memoization+  , memo+  , memoFingerprint+  , MemoFingerprintKey(..)+  , memoize, memoize1, memoize2++    -- * Local memoization+  , newMemo+  , newMemoWith+  , prepareMemo+  , runMemo+  ) where+ #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif+import Control.Exception as Exception hiding (throw)+import Data.IORef+import qualified Data.HashMap.Strict as HashMap import Data.Text (Text) import Data.Typeable import Data.Hashable@@ -31,9 +51,245 @@  import GHC.Prim (Addr#) +import Haxl.Core.Exception+import Haxl.Core.DataCache as DataCache+import Haxl.Core.Flags import Haxl.Core.Monad+import Haxl.Core.Profile  -- -----------------------------------------------------------------------------+-- Memoization++-- | 'cachedComputation' memoizes a Haxl computation.  The key is a+-- request.+--+-- /Note:/ These cached computations will /not/ be included in the output+-- of 'dumpCacheAsHaskell'.+--+cachedComputation+   :: 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@Env{..} -> do+  cache <- readIORef memoRef+  ifProfiling flags $+     modifyIORef' profRef (incrementMemoHitCounterFor profLabel)+  case DataCache.lookup req cache of+    Just ivar -> unHaxl (getIVar ivar) env+    Nothing -> do+      ivar <- newIVar+      writeIORef memoRef $! DataCache.insertNotShowable req ivar cache+      unHaxl (execMemoNow haxl ivar) env+++-- | Like 'cachedComputation', but fails if the cache is already+-- populated.+--+-- Memoization can be (ab)used to "mock" a cached computation, by+-- pre-populating the cache with an alternative implementation. In+-- that case we don't want the operation to populate the cache to+-- silently succeed if the cache is already populated.+--+preCacheComputation+  :: forall req u a.+     ( Eq (req a)+     , Hashable (req a)+     , Typeable (req a))+  => req a -> GenHaxl u a -> GenHaxl u a+preCacheComputation req haxl = GenHaxl $ \env@Env{..} -> do+  cache <- readIORef memoRef+  ifProfiling flags $+     modifyIORef' profRef (incrementMemoHitCounterFor profLabel)+  case DataCache.lookup req cache of+    Just _ -> return $ Throw $ toException $ InvalidParameter+      "preCacheComputation: key is already cached"+    Nothing -> do+      ivar <- newIVar+      writeIORef memoRef $! DataCache.insertNotShowable req ivar cache+      unHaxl (execMemoNow haxl ivar) env++-- -----------------------------------------------------------------------------+-- Memoization++newtype MemoVar u a = MemoVar (IORef (MemoStatus u a))++data MemoStatus u a+  = MemoEmpty+  | MemoReady (GenHaxl u a)+  | MemoRun {-# UNPACK #-} !(IVar u a)++-- | Create a new @MemoVar@ for storing a memoized computation. The created+-- @MemoVar@ is initially empty, not tied to any specific computation. Running+-- this memo (with @runMemo@) without preparing it first (with @prepareMemo@)+-- will result in an exception.+newMemo :: GenHaxl u (MemoVar u a)+newMemo = 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 (MemoReady 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 memoRef) = GenHaxl $ \env -> do+  stored <- readIORef memoRef+  case stored of+    -- Memo was not prepared first; throw an exception.+    MemoEmpty -> raise $ CriticalError "Attempting to run empty memo."+    -- Memo has been prepared but not run yet+    MemoReady cont -> do+      ivar <- newIVar+      writeIORef memoRef (MemoRun ivar)+      unHaxl (execMemoNow cont ivar) env+    -- The memo has already been run, get (or wait for) for the result+    MemoRun ivar -> unHaxl (getIVar ivar) env+++execMemoNow :: GenHaxl u a -> IVar u a -> GenHaxl u a+execMemoNow cont ivar = GenHaxl $ \env -> do+  let !ienv = imperative env   -- don't speculate under memoized things+  r <- Exception.try $ unHaxl cont ienv+  case r of+    Left e -> do+      rethrowAsyncExceptions e+      putIVar ivar (ThrowIO e) env+      throwIO e+    Right (Done a) -> do+      putIVar ivar (Ok a) env+      return (Done a)+    Right (Throw ex) -> do+      putIVar ivar (ThrowHaxl ex) env+      return (Throw ex)+    Right (Blocked ivar' cont) -> do+      addJob env (toHaxl cont) ivar ivar'+      return (Blocked ivar (Cont (getIVar ivar)))++-- -----------------------------------------------------------------------------+-- 1-ary and 2-ary memo functions++newtype MemoVar1 u a b = MemoVar1 (IORef (MemoStatus1 u a b))+newtype MemoVar2 u a b c = MemoVar2 (IORef (MemoStatus2 u a b c))++data MemoStatus1 u a b+  = MemoEmpty1+  | MemoTbl1 (a -> GenHaxl u b) (HashMap.HashMap a (MemoVar u b))++data MemoStatus2 u a b c+  = MemoEmpty2+  | MemoTbl2+      (a -> b -> GenHaxl u c)+      (HashMap.HashMap a (HashMap.HashMap b (MemoVar u c)))++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++-- ----------------------------------------------------------------------------- -- 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@@ -115,8 +371,8 @@ -- 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+memoize :: GenHaxl u a -> GenHaxl u (GenHaxl u a)+memoize a = runMemo <$> newMemoWith a  -- | Transform a 1-argument function returning a Haxl computation into a -- memoized version of itself.@@ -127,10 +383,10 @@ -- -- e.g.: ----- allFriends :: [Int] -> GenHaxl u [Int]--- allFriends ids = do---   memoizedFriendsOf <- memoize1 friendsOf---   concat <$> mapM memoizeFriendsOf ids+-- > 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@.

@@ -2,1260 +2,764 @@ -- 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 BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-#if __GLASGOW_HASKELL >= 800-{-# OPTIONS_GHC -Wno-name-shadowing #-}-#else-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}-#endif---- | 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, withLabel, withFingerprintLabel,--    -- * Env-    Env(..), Caches, caches, initEnvWithData, initEnv, emptyEnv,--    -- * Exceptions-    throw, catch, catchIf, try, tryToHaxlException,--    -- * Data fetching and caching-    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,--    -- * Parallel operaitons-    pAnd, pOr-  ) where--import Haxl.Core.Types-import Haxl.Core.ShowP-import Haxl.Core.StateStore-import Haxl.Core.Exception-import Haxl.Core.RequestStore-import Haxl.Core.Util-import Haxl.Core.DataCache as DataCache--import qualified Data.Text as Text-import qualified Control.Monad.Catch as Catch-import Control.Exception (Exception(..), SomeException)-#if __GLASGOW_HASKELL__ >= 710-import GHC.Conc (getAllocationCounter, setAllocationCounter)-#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(..), 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 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     :: {-# 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     :: {-# 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'.-  }--type Caches u = (IORef (DataCache ResultVar), IORef (DataCache (MemoVar u)))--caches :: Env u -> Caches u-caches env = (cacheRef env, memoRef env)---- | Initialize an environment with a 'StateStore', an input map, a--- preexisting 'DataCache', and a seed for the random number generator.-initEnvWithData :: StateStore -> u -> Caches u -> IO (Env u)-initEnvWithData states e (cref, mref) = do-  sref <- newIORef emptyStats-  pref <- newIORef emptyProfile-  return Env-    { cacheRef = cref-    , memoRef = mref-    , flags = defaultFlags-    , 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 emptyDataCache-  mref <- newIORef emptyDataCache-  initEnvWithData states e (cref,mref)---- | A new, empty environment.-emptyEnv :: u -> IO (Env u)-emptyEnv = initEnv stateEmpty---- -------------------------------------------------------------------------------- | The Haxl monad, which does several things:------  * It is a reader monad for 'Env' and 'IORef' 'RequestStore', The---    latter is the current batch of unsubmitted data fetch requests.------  * It is a concurrency, or resumption, monad. A computation may run---    partially and return 'Blocked', in which case the framework should---    perform the outstanding requests in the 'RequestStore', and then---    resume the computation.------  * The Applicative combinator '<*>' explores /both/ branches in the---    event that the left branch is 'Blocked', so that we can collect---    multiple requests and submit them as a batch.------  * It contains IO, so that we can perform real data fetching.----newtype GenHaxl u a = GenHaxl-  { unHaxl :: Env u -> IORef (RequestStore u) -> IO (Result u a) }---- | The result of a computation is either 'Done' with a value, 'Throw'--- with an exception, or 'Blocked' on the result of a data fetch with--- a continuation.-data Result u a-  = Done a-  | Throw SomeException-  | 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-  show Blocked{} = "Blocked"--instance Monad (GenHaxl u) where-  return a = GenHaxl $ \_env _ref -> return (Done a)-  GenHaxl m >>= k = GenHaxl $ \env ref -> do-    e <- m env ref-    case e of-      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 >>-  (>>) = (*>)--instance Functor (GenHaxl u) where-  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-  GenHaxl f <*> GenHaxl a = GenHaxl $ \env ref -> do-    r <- f env ref-    case r of-      Throw e -> return (Throw e)-      Done f' -> do-        ra <- a env ref-        case ra of-          Done a'    -> return (Done (f' a'))-          Throw e    -> return (Throw e)-          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 (($ 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 c = do-        traceEventIO "START computation"-        ref <- newIORef noRequests-        e <- (unHaxl $ toHaxl c) env ref-        traceEventIO "STOP computation"-        case e of-          Done a       -> return a-          Throw e      -> Exception.throw e-          Blocked cont -> do-            bs <- readIORef ref-            writeIORef ref noRequests -- Note [RoundId]-            traceEventIO "START performFetches"-            n' <- performFetches n env bs-            traceEventIO "STOP performFetches"-            when (caching (flags env) == 0) $-              writeIORef (cacheRef env) emptyDataCache-            go n' env cont-  traceEventIO "START runHaxl"-  r <- go 0 env (Cont h)-  traceEventIO "STOP runHaxl"-  return r-#else-runHaxl env (GenHaxl haxl) = do-  ref <- newIORef noRequests-  e <- haxl env ref-  case e of-    Done a       -> return a-    Throw e      -> Exception.throw e-    Blocked cont -> do-      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---- | 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))))---- | 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---- | Throw an exception in the Haxl monad-throw :: (Exception e) => e -> GenHaxl u a-throw e = GenHaxl $ \_env _ref -> raise e--raise :: (Exception e) => e -> IO (Result u a)-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-catch (GenHaxl m) h = GenHaxl $ \env ref -> do-   r <- m env ref-   case r of-     Done a    -> return (Done a)-     Throw e | Just e' <- fromException e -> unHaxl (h e') env ref-             | otherwise -> return (Throw e)-     Blocked k -> return (Blocked (Cont (catch (toHaxl k) h)))---- | Catch exceptions that satisfy a predicate-catchIf-  :: Exception e => (e -> Bool) -> GenHaxl u a -> (e -> GenHaxl u a)-  -> GenHaxl u a-catchIf cond haxl handler =-  catch haxl $ \e -> if cond e then handler e else throw e---- | Returns @'Left' e@ if the computation throws an exception @e@, or--- @'Right' a@ if it returns a result @a@.-try :: Exception e => GenHaxl u a -> GenHaxl u (Either e a)-try haxl = (Right <$> haxl) `catch` (return . Left)---- | @since 0.3.1.0-instance Catch.MonadThrow (GenHaxl u) where throwM = Haxl.Core.Monad.throw--- | @since 0.3.1.0-instance Catch.MonadCatch (GenHaxl u) where catch = Haxl.Core.Monad.catch---- -------------------------------------------------------------------------------- Unsafe operations---- | Under ordinary circumstances this is unnecessary; users of the Haxl--- monad should generally /not/ perform arbitrary IO.-unsafeLiftIO :: IO a -> GenHaxl u a-unsafeLiftIO m = GenHaxl $ \_env _ref -> Done <$> m---- | Convert exceptions in the underlying IO monad to exceptions in--- the Haxl monad.  This is morally unsafe, because you could then--- catch those exceptions in Haxl and observe the underlying execution--- order.  Not to be exposed to user code.-unsafeToHaxlException :: GenHaxl u a -> GenHaxl u a-unsafeToHaxlException (GenHaxl m) = GenHaxl $ \env ref -> do-  r <- m env ref `Exception.catch` \e -> return (Throw e)-  case r of-    Blocked c -> return (Blocked (Cont (unsafeToHaxlException (toHaxl c))))-    other -> return other---- | Like 'try', but lifts all exceptions into the 'HaxlException'--- hierarchy.  Uses 'unsafeToHaxlException' internally.  Typically--- this is used at the top level of a Haxl computation, to ensure that--- all exceptions are caught.-tryToHaxlException :: GenHaxl u a -> GenHaxl u (Either HaxlException a)-tryToHaxlException h = left asHaxlException <$> try (unsafeToHaxlException h)----- -------------------------------------------------------------------------------- Data fetching and caching---- | Possible responses when checking the cache.-data CacheResult a-  -- | The request hadn't been seen until now.-  = Uncached (ResultVar a)--  -- | The request has been seen before, but its result has not yet been-  -- fetched.-  | CachedNotFetched (ResultVar a)--  -- | The request has been seen before, and its result has already been-  -- fetched.-  | Cached (Either SomeException a)---- | Checks the data cache for the result of a request.-cached :: Request r a => Env u -> r a -> IO (CacheResult a)-cached = 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-    doFetch insertFn request cache = do-      rvar <- newEmptyResult-      writeIORef (cacheRef env) $! insertFn request rvar cache-      return (Uncached rvar)-  cache <- readIORef (cacheRef env)-  case DataCache.lookup req cache of-    Nothing -> doFetch insertFn req cache-    Just rvar -> do-      mb <- tryReadResult rvar-      case mb of-        Nothing -> return (CachedNotFetched rvar)-        -- Use the cached result, even if it was an error.-        Just r -> do-          ifTrace (flags env) 3 $ putStrLn $ case r of-            Left _ -> "Cached error: " ++ 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 = 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 <- 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 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 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--- properties that we expect Haxl computations to respect: that data--- fetches can be aribtrarily reordered, and identical requests can be--- commoned up, for example.------ 'uncachedRequest' is useful for performing writes, provided those--- are done in a safe way - that is, not mixed with reads that might--- conflict in the same Haxl computation.----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 show req rvar))--continueFetch-  :: (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 $-      Text.pack (showFn req) <> " did not set contents of result var"-    Just r -> done r---- | Transparently provides caching. Useful for datasources that can--- return immediately, but also caches values.  Exceptions thrown by--- the IO operation (except for asynchronous exceptions) are--- propagated into the Haxl monad and can be caught by 'catch' and--- 'try'.-cacheResult :: Request r a => r a -> IO a -> GenHaxl u a-cacheResult = 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-      putResult rvar result-      case result of-        Left e -> do rethrowAsyncExceptions e; done result-        _other -> done result-    Cached result -> done result-    CachedNotFetched _ -> corruptCache-  where-    corruptCache = raise . DataSourceError $ Text.concat-      [ 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."-      ]---- | Inserts a request/result pair into the cache. Throws an exception--- if the request has already been issued, either via 'dataFetch' or--- 'cacheRequest'.------ This can be used to pre-populate the cache when running tests, to--- avoid going to the actual data source and ensure that results are--- deterministic.----cacheRequest-  :: Request req a => req a -> Either SomeException a -> GenHaxl u ()-cacheRequest request result = GenHaxl $ \env _ref -> do-  res <- cached env request-  case res of-    Uncached rvar -> do-      -- request was not in the cache: insert the result and continue-      putResult rvar result-      return $ Done ()--    -- It is an error if the request is already in the cache.  We can't test-    -- whether the cached result is the same without adding an Eq constraint,-    -- and we don't necessarily have Eq for all results.-    _other -> raise $-      DataSourceError "cacheRequest: request is already in the cache"--instance IsString a => IsString (GenHaxl u a) where-  fromString s = return (fromString s)---- | Issues a batch of fetches in a 'RequestStore'. After--- 'performFetches', all the requests in the 'RequestStore' are--- complete, and all of the 'ResultVar's are full.-performFetches :: forall u. Int -> Env u -> RequestStore u -> IO Int-performFetches n env reqs = do-  let f = flags env-      sref = statsRef env-      jobs = contents reqs-      !n' = n + length jobs--  t0 <- getCurrentTime-  a0 <- getAllocationCounter--  let-    roundstats =-      [ (dataSourceName (getReq reqs), length reqs)-      | BlockedFetches reqs <- jobs ]-      where-      getReq :: [BlockedFetch r] -> r a-      getReq = undefined--  ifTrace f 1 $-    printf "Batch data fetch (%s)\n" $-      intercalate (", "::String) $-        map (\(name,num) -> printf "%d %s" num (Text.unpack name)) roundstats--  ifTrace f 3 $-    forM_ jobs $ \(BlockedFetches reqs) ->-      forM_ reqs $ \(BlockedFetch r _) -> putStrLn (showp r)--  let-    applyFetch (i, BlockedFetches (reqs :: [BlockedFetch r])) =-      case stateGet (states env) of-        Nothing ->-          return (SyncFetch (mapM_ (setError e) reqs))-          where e req = DataSourceError $-                  "data source not initialized: " <>-                  dataSourceName req <>-                  ": " <>-                  Text.pack (showp req)-        Just state ->-          return $ wrapFetchInTrace i (length reqs)-                    (dataSourceName (undefined :: r a))-                 $ wrapFetchInCatch reqs-                 $ fetch state f (userEnv env) reqs--  fetches <- mapM applyFetch $ zip [n..] jobs--  deepStats <--    if report f >= 2-    then do-      (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 = dsfetch-                                       , dataSourceTime = fst <$> dsStats-                                       , dataSourceAllocation = snd <$> dsStats-                                       , dataSourceFailures = dsfailure-                                       })-         | ((name, dsfetch), dsStats, dsfailure) <--             zip3 roundstats deepStats failures]--  a1 <- getAllocationCounter-  t1 <- getCurrentTime-  let-    roundtime = realToFrac (diffUTCTime t1 t0) :: Double-    allocation = fromIntegral $ a0 - a1--  ifReport f 1 $-    modifyIORef' sref $ \(Stats rounds) -> roundstats `deepseq`-      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--- the appropriate requests.  We don't want any exceptions propagating--- directly from the data sources, because we want the exception to be--- thrown by dataFetch instead.----wrapFetchInCatch :: [BlockedFetch req] -> PerformFetch -> PerformFetch-wrapFetchInCatch reqs fetch =-  case fetch of-    SyncFetch io ->-      SyncFetch (io `Exception.catch` handler)-    AsyncFetch fio ->-      AsyncFetch (\io -> fio io `Exception.catch` handler)-      -- this might be wrong: if the outer 'fio' throws an exception,-      -- then we don't know whether we have executed the inner 'io' or-      -- not.  If not, then we'll likely get some errors about "did-      -- not set result var" later, because we haven't executed some-      -- data fetches.  But we can't execute 'io' in the handler,-      -- because we might have already done it.  It isn't possible to-      -- do it completely right here, so we have to rely on data-      -- sources themselves to catch (synchronous) exceptions.  Async-      -- exceptions aren't a problem because we're going to rethrow-      -- them all the way to runHaxl anyway.-  where-    handler :: SomeException -> IO ()-    handler e = do-      rethrowAsyncExceptions e-      mapM_ (forceError e) reqs--    -- Set the exception even if the request already had a result.-    -- Otherwise we could be discarding an exception.-    forceError e (BlockedFetch _ rvar) = do-      void $ tryTakeResult rvar-      putResult rvar (except e)--wrapFetchInStats :: PerformFetch -> IO (IORef (Microseconds, Int), PerformFetch)-wrapFetchInStats f = do-  r <- newIORef (0, 0)-  case f of-    SyncFetch io -> return (r, SyncFetch (statsForIO io >>= writeIORef r))-    AsyncFetch f -> do-       inner_r <- newIORef (0, 0)-       return (r, AsyncFetch $ \inner -> do-         (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-wrapFetchInTrace i n dsName f =-  case f of-    SyncFetch io -> SyncFetch (wrapF "Sync" io)-    AsyncFetch fio -> AsyncFetch (wrapF "Async" . fio . unwrapF "Async")-  where-    d = Text.unpack dsName-    wrapF :: String -> IO a -> IO a-    wrapF ty = bracket_ (traceEventIO $ printf "START %d %s (%d %s)" i d n ty)-                        (traceEventIO $ printf "STOP %d %s (%d %s)" i d n ty)-    unwrapF :: String -> IO a -> IO a-    unwrapF ty = bracket_ (traceEventIO $ printf "STOP %d %s (%d %s)" i d n ty)-                          (traceEventIO $ printf "START %d %s (%d %s)" i d n ty)-#else-wrapFetchInTrace _ _ _ f = f-#endif--time :: IO () -> IO Microseconds-time io = do-  t0 <- getCurrentTime-  io-  t1 <- getCurrentTime-  return . microsecs . realToFrac $ t1 `diffUTCTime` t0--microsecs :: Double -> Microseconds-microsecs t = round (t * 10^(6::Int))---- | Start all the async fetches first, then perform the sync fetches before--- getting the results of the async fetches.-scheduleFetches :: [PerformFetch] -> IO()-scheduleFetches fetches = async_fetches sync_fetches- where-  async_fetches :: IO () -> IO ()-  async_fetches = compose [f | AsyncFetch f <- fetches]--  sync_fetches :: IO ()-  sync_fetches = sequence_ [io | SyncFetch io <- fetches]----- -------------------------------------------------------------------------------- Memoization---- | 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)--  -- | A fully evaluated memo; here is the result.-  | MemoDone (Either SomeException a)--  -- | 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]--A token representing the round.  This needs to be unique per round,-and it needs to support Eq.  Fortunately the IORef RequestStore is-exactly what we need: IORef supports Eq, and we make a new one for-each round.  There's a danger that storing this in the DataCache could-cause a space leak, so we stub out the contents after each round (see-runHaxl).--}---- | 'cachedComputation' memoizes a Haxl computation.  The key is a--- request.------ /Note:/ These cached computations will /not/ be included in the output--- of 'dumpCacheAsHaskell'.----cachedComputation-   :: forall req u a.-      ( Eq (req a)-      , Hashable (req a)-      , Typeable (req a))-   => req a -> GenHaxl u a -> GenHaxl u a-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--- compiled and run, will recreate the same cache contents.  For--- example, the generated code looks something like this:------ > loadCache :: GenHaxl u ()--- > loadCache = do--- >   cacheRequest (ListWombats 3) (Right ([1,2,3]))--- >   cacheRequest (CountAardvarks "abcabc") (Right (2))----dumpCacheAsHaskell :: GenHaxl u String-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-  let-    mk_cr (req, res) =-      text "cacheRequest" <+> parens (text req) <+> parens (result res)-    result (Left e) = text "except" <+> parens (text (show e))-    result (Right s) = text "Right" <+> parens (text s)--  return $ show $-    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----- -------------------------------------------------------------------------------- Parallel operations---- Bind more tightly than .&&, .||-infixr 5 `pAnd`-infixr 4 `pOr`---- | Parallel version of '(.||)'.  Both arguments are evaluated in--- parallel, and if either returns 'True' then the other is--- not evaluated any further.------ WARNING: exceptions may be unpredictable when using 'pOr'.  If one--- argument returns 'True' before the other completes, then 'pOr'--- returns 'True' immediately, ignoring a possible exception that--- the other argument may have produced if it had been allowed to--- complete.-pOr :: GenHaxl u Bool -> GenHaxl u Bool -> GenHaxl u Bool-GenHaxl a `pOr` GenHaxl b = GenHaxl $ \env ref -> do-  ra <- a env ref-  case ra of-    Done True -> return (Done True)-    Done False -> b env ref-    Throw _ -> return ra-    Blocked a' -> do-      rb <- b env ref-      case rb of-        Done True -> return (Blocked (Cont (return True)))-          -- Note [tricky pOr/pAnd]-        Done False -> return ra-        Throw e -> return (Blocked (Cont (throw e)))-        Blocked b' -> return (Blocked (Cont (toHaxl a' `pOr` toHaxl b')))---- | Parallel version of '(.&&)'.  Both arguments are evaluated in--- parallel, and if either returns 'False' then the other is--- not evaluated any further.------ WARNING: exceptions may be unpredictable when using 'pAnd'.  If one--- argument returns 'False' before the other completes, then 'pAnd'--- returns 'False' immediately, ignoring a possible exception that--- the other argument may have produced if it had been allowed to--- complete.-pAnd :: GenHaxl u Bool -> GenHaxl u Bool -> GenHaxl u Bool-GenHaxl a `pAnd` GenHaxl b = GenHaxl $ \env ref -> do-  ra <- a env ref-  case ra of-    Done False -> return (Done False)-    Done True -> b env ref-    Throw _ -> return ra-    Blocked a' -> do-      rb <- b env ref-      case rb of-        Done False -> return (Blocked (Cont (return False)))-          -- Note [tricky pOr/pAnd]-        Done True -> return ra-        Throw _ -> return rb-        Blocked b' -> return (Blocked (Cont (toHaxl a' `pAnd` toHaxl b')))--{--Note [tricky pOr/pAnd]--If one branch returns (Done True) and the other returns (Blocked _),-even though we know the result will be True (in the case of pOr), we-must return Blocked.  This is because there are data fetches to-perform, and if we don't do this, the cache is left with an empty-ResultVar, and the next fetch for the same request will fail.--Alternatives:-- * Test for a non-empty RequestStore in runHaxl when we get Done, but-   that would penalise every runHaxl.-- * Try to abandon the fetches. This is hard: we've already stored the-   requests and a ResultVars in the cache, and we don't know how to-   find the right fetches to remove from the cache.  Furthermore, we-   might have partially computed some memoized computations.--}+-- found in the LICENSE file.++{- TODO++- do EVENTLOG stuff, track the data fetch numbers for performFetch++- timing: we should be using clock_gettime(CLOCK_MONOTONIC) instead of+  getCurrentTime, which will be affected by NTP and leap seconds.++- write different scheduling policies++-}++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TupleSections #-}++-- |+-- 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(..)+  , Result(..)++    -- * Cont+  , Cont(..)+  , toHaxl++    -- * IVar+  , IVar(..)+  , IVarContents(..)+  , newIVar+  , newFullIVar+  , getIVar+  , putIVar++    -- * ResultVal+  , ResultVal(..)+  , done+  , eitherToResult+  , eitherToResultThrowIO++    -- * CompleteReq+  , CompleteReq(..)++    -- * Env+  , Env(..)+  , Caches+  , caches+  , initEnvWithData+  , initEnv+  , emptyEnv+  , env, withEnv+  , speculate+  , imperative++    -- * JobList+  , JobList(..)+  , appendJobList+  , lengthJobList+  , addJob++    -- * Exceptions+  , throw+  , raise+  , catch+  , catchIf+  , try+  , tryToHaxlException++    -- * Dumping the cache+  , dumpCacheAsHaskell+  , dumpCacheAsHaskellFn++    -- * Unsafe operations+  ,  unsafeLiftIO, unsafeToHaxlException+  ) where++import Haxl.Core.Flags+import Haxl.Core.Stats+import Haxl.Core.StateStore+import Haxl.Core.Exception+import Haxl.Core.RequestStore as RequestStore+import Haxl.Core.DataCache as DataCache++import Control.Arrow (left)+import Control.Concurrent.STM+import qualified Data.Text as Text+import qualified Control.Monad.Catch as Catch+import Control.Exception (Exception(..), SomeException, throwIO)+import Control.Monad+import qualified Control.Exception as Exception+#if __GLASGOW_HASKELL__ < 710+import Control.Applicative hiding (Const)+#endif+#if __GLASGOW_HASKELL__ < 706+import Prelude hiding (catch)+#endif+import Data.IORef+import Data.Int+import GHC.Exts (IsString(..))+import Text.PrettyPrint hiding ((<>))+import Text.Printf+#ifdef EVENTLOG+import Control.Exception (bracket_)+import Debug.Trace (traceEventIO)+#endif++#ifdef PROFILING+import GHC.Stack+#endif+++trace_ :: String -> a -> a+trace_ _ = id+--trace_ = Debug.Trace.trace++-- -----------------------------------------------------------------------------+-- The environment++-- | The data we carry around in the Haxl monad.+data Env u = Env+  { cacheRef     :: {-# UNPACK #-} !(IORef (DataCache (IVar u)))+      -- ^ cached data fetches++  , memoRef      :: {-# UNPACK #-} !(IORef (DataCache (IVar u)))+      -- ^ memoized computations++  , flags        :: !Flags+      -- conservatively not unpacking, because this is passed+      -- to 'fetch' and would need to be rebuilt.++  , userEnv      :: u+      -- ^ user-supplied data, retrievable with 'env'++  , statsRef     :: {-# UNPACK #-} !(IORef Stats)+      -- ^ statistics, collected according to the 'report' level in 'flags'.++  , profLabel    :: ProfileLabel+      -- ^ current profiling label, see 'withLabel'++  , profRef      :: {-# UNPACK #-} !(IORef Profile)+      -- ^ profiling data, collected according to the 'report' level in 'flags'.++  , states       :: StateStore+      -- ^ Data sources and other components can store their state in+      -- here. Items in this store must be instances of 'StateKey'.++  , reqStoreRef :: {-# UNPACK #-} !(IORef (RequestStore u))+       -- ^ The set of requests that we have not submitted to data sources yet.+       -- Owned by the scheduler.++  , runQueueRef :: {-# UNPACK #-} !(IORef (JobList u))+       -- ^ runnable computations. Things get added to here when we wake up+       -- a computation that was waiting for something.  When the list is+       -- empty, either we're finished, or we're waiting for some data fetch+       -- to return.++  , completions :: {-# UNPACK #-} !(TVar [CompleteReq u])+       -- ^ Requests that have completed.  Modified by data sources+       -- (via putResult) and the scheduler.  Waiting for this list to+       -- become non-empty is how the scheduler blocks waiting for+       -- data fetches to return.++  , pendingWaits :: [IO ()]+       -- ^ this is a list of IO actions returned by 'FutureFetch'+       -- data sources.  These do a blocking wait for the results of+       -- some data fetch.++  , speculative :: {-# UNPACK #-} !Int+  }++type Caches u = (IORef (DataCache (IVar u)), IORef (DataCache (IVar u)))++caches :: Env u -> Caches u+caches env = (cacheRef env, memoRef env)++-- | Initialize an environment with a 'StateStore', an input map, a+-- preexisting 'DataCache', and a seed for the random number generator.+initEnvWithData :: StateStore -> u -> Caches u -> IO (Env u)+initEnvWithData states e (cref, mref) = do+  sref <- newIORef emptyStats+  pref <- newIORef emptyProfile+  rs <- newIORef noRequests          -- RequestStore+  rq <- newIORef JobNil+  comps <- newTVarIO []              -- completion queue+  return Env+    { cacheRef = cref+    , memoRef = mref+    , flags = defaultFlags+    , userEnv = e+    , states = states+    , statsRef = sref+    , profLabel = "MAIN"+    , profRef = pref+    , reqStoreRef = rs+    , runQueueRef = rq+    , completions = comps+    , pendingWaits = []+    , speculative = 0+    }++-- | Initializes an environment with 'StateStore' and an input map.+initEnv :: StateStore -> u -> IO (Env u)+initEnv states e = do+  cref <- newIORef emptyDataCache+  mref <- newIORef emptyDataCache+  initEnvWithData states e (cref,mref)++-- | A new, empty environment.+emptyEnv :: u -> IO (Env u)+emptyEnv = initEnv stateEmpty++speculate :: Env u -> Env u+speculate env@Env{..}+  | speculative == 0 = env { speculative = 1 }+  | otherwise = env++imperative :: Env u -> Env u+imperative env@Env{..}+  | speculative == 1 = env { speculative = 0 }+  | otherwise = env++-- -----------------------------------------------------------------------------+-- | The Haxl monad, which does several things:+--+--  * It is a reader monad for 'Env', which contains the current state+--    of the scheduler, including unfetched requests and the run queue+--    of computations.+--+--  * It is a concurrency, or resumption, monad. A computation may run+--    partially and return 'Blocked', in which case the framework should+--    perform the outstanding requests in the 'RequestStore', and then+--    resume the computation.+--+--  * The Applicative combinator '<*>' explores /both/ branches in the+--    event that the left branch is 'Blocked', so that we can collect+--    multiple requests and submit them as a batch.+--+--  * It contains IO, so that we can perform real data fetching.+--+newtype GenHaxl u a = GenHaxl+  { unHaxl :: Env u -> IO (Result u a) }+++instance IsString a => IsString (GenHaxl u a) where+  fromString s = return (fromString s)++-- -----------------------------------------------------------------------------+-- JobList++-- | A list of computations together with the IVar into which they+-- should put their result.+--+-- This could be an ordinary list, but the optimised representation+-- saves space and time.+--+data JobList u+ = JobNil+ | forall a . JobCons+     (Env u)          -- See Note [make withEnv work] below.+     (GenHaxl u a)+     {-# UNPACK #-} !(IVar u a)+     (JobList u)++-- Note [make withEnv work]+--+-- The withEnv operation supplies a new Env for the scope of a GenHaxl+-- computation.  The problem is that the computation might be split+-- into pieces and put onto various JobLists, so we have to be sure to+-- use the correct Env when we execute the pieces. Furthermore, if one+-- of these pieces blocks and gets run again later, we must ensure to+-- restart it with the correct Env.  So we stash the Env along with+-- the continuation in the JobList.++appendJobList :: JobList u -> JobList u -> JobList u+appendJobList JobNil c = c+appendJobList c JobNil = c+appendJobList (JobCons a b c d) e = JobCons a b c $! appendJobList d e++lengthJobList :: JobList u -> Int+lengthJobList JobNil = 0+lengthJobList (JobCons _ _ _ j) = 1 + lengthJobList j+++-- -----------------------------------------------------------------------------+-- IVar++-- | A synchronisation point.  It either contains a value, or a list+-- of computations waiting for the value.+newtype IVar u a = IVar (IORef (IVarContents u a))++data IVarContents u a+  = IVarFull (ResultVal a)+  | IVarEmpty (JobList u)+    -- morally this is a list of @a -> GenHaxl u ()@, but instead of+    -- using a function, each computation begins with `getIVar` to grab+    -- the value it is waiting for.  This is less type safe but a little+    -- faster (benchmarked with tests/MonadBench.hs).++newIVar :: IO (IVar u a)+newIVar = IVar <$> newIORef (IVarEmpty JobNil)++newFullIVar :: ResultVal a -> IO (IVar u a)+newFullIVar r = IVar <$> newIORef (IVarFull r)++getIVar :: IVar u a -> GenHaxl u a+getIVar (IVar !ref) = GenHaxl $ \_env -> do+  e <- readIORef ref+  case e of+    IVarFull (Ok a) -> return (Done a)+    IVarFull (ThrowHaxl e) -> return (Throw e)+    IVarFull (ThrowIO e) -> throwIO e+    IVarEmpty _ -> return (Blocked (IVar ref) (Cont (getIVar (IVar ref))))++-- Just a specialised version of getIVar, for efficiency in <*>+getIVarApply :: IVar u (a -> b) -> a -> GenHaxl u b+getIVarApply (IVar !ref) a = GenHaxl $ \_env -> do+  e <- readIORef ref+  case e of+    IVarFull (Ok f) -> return (Done (f a))+    IVarFull (ThrowHaxl e) -> return (Throw e)+    IVarFull (ThrowIO e) -> throwIO e+    IVarEmpty _ ->+      return (Blocked (IVar ref) (Cont (getIVarApply (IVar ref) a)))++putIVar :: IVar u a -> ResultVal a -> Env u -> IO ()+putIVar (IVar ref) a Env{..} = do+  e <- readIORef ref+  case e of+    IVarEmpty jobs -> do+      writeIORef ref (IVarFull a)+      modifyIORef' runQueueRef (appendJobList jobs)+    IVarFull{} -> error "putIVar: multiple put"++{-# INLINE addJob #-}+addJob :: Env u -> GenHaxl u b -> IVar u b -> IVar u a -> IO ()+addJob env !haxl !resultIVar (IVar !ref) =+  modifyIORef' ref $ \contents ->+    case contents of+      IVarEmpty list -> IVarEmpty (JobCons env haxl resultIVar list)+      _ -> addJobPanic++addJobPanic :: forall a . a+addJobPanic = error "addJob: not empty"+++-- -----------------------------------------------------------------------------+-- ResultVal++-- | The contents of a full IVar.  We have to distinguish exceptions+-- thrown in the IO monad from exceptions thrown in the Haxl monad, so+-- that when the result is fetched using getIVar, we can throw the+-- exception in the right way.+data ResultVal a+  = Ok a+  | ThrowHaxl SomeException+  | ThrowIO SomeException++done :: ResultVal a -> IO (Result u a)+done (Ok a) = return (Done a)+done (ThrowHaxl e) = return (Throw e)+done (ThrowIO e) = throwIO e++eitherToResultThrowIO :: Either SomeException a -> ResultVal a+eitherToResultThrowIO (Right a) = Ok a+eitherToResultThrowIO (Left e)+  | Just HaxlException{} <- fromException e = ThrowHaxl e+  | otherwise = ThrowIO e++eitherToResult :: Either SomeException a -> ResultVal a+eitherToResult (Right a) = Ok a+eitherToResult (Left e) = ThrowHaxl e+++-- -----------------------------------------------------------------------------+-- CompleteReq++-- | A completed request from a data source, containing the result,+-- and the 'IVar' representing the blocked computations.  The job of a+-- data source is just to add these to a queue ('completions') using+-- 'putResult'; the scheduler collects them from the queue and unblocks+-- the relevant computations.+data CompleteReq u+  = forall a . CompleteReq+      (Either SomeException a)+      !(IVar u a)  -- IVar because the result is cached+      {-# UNPACK #-} !Int64 -- see Note [tracking allocation in child threads]+++{- Note [tracking allocation in child threads]++For a BackgroundFetch, we might be doing some of the work in a+separate thread, but we want to make sure that the parent thread gets+charged for the allocation, so that allocation limits still work.++The design is a bit tricky here.  We want to track the allocation+accurately but without adding much overhead.++The best way to propagate the allocation back from the child thread is+through putResult.  If we had some other method, we would also need a+way to synchronise it with the main runHaxl loop; the advantage of+putResult is that this is already a synchronisation method, because+runHaxl is waiting for the result of the dataFetch.++(slight wrinkle here: runHaxl might not wait for the result of the+dataFetch in the case where we do some speculative execution in+pAnd/pOr)++We need a special version of putResult for child threads+(putResultFromChildThread), because we don't want to propagate any+allocation from the runHaxl thread back to itself and count it twice.++We also want to capture the allocation as late as possible, so that we+count everything.  For that reason, we pass a Bool down from putResult+into the function in the ResultVar, and it reads the allocation+counter as the last thing before adding the result to the completions+TVar.++The other problem to consider is how to capture the allocation when+the child thread is doing multiple putResults.  Our solution here is+to ensure that the *last* one is a putResultFromChildThread, so it+captures all the allocation from everything leading up to it.++Why not reset the counter each time, so we could do multiple+putResultFromChildThreads?  Because the child thread might be using an+allocation limit itself, and changing the counter would mess it up.+-}++-- -----------------------------------------------------------------------------+-- Result++-- | The result of a computation is either 'Done' with a value, 'Throw'+-- with an exception, or 'Blocked' on the result of a data fetch with+-- a continuation.+data Result u a+  = Done a+  | Throw SomeException+  | forall b . Blocked+      {-# UNPACK #-} !(IVar u b)+      (Cont u a)+         -- ^ The 'IVar' is what we are blocked on; 'Cont' is the+         -- continuation.  This might be wrapped further if we're+         -- nested inside multiple '>>=', before finally being added+         -- to the 'IVar'.  Morally @b -> GenHaxl u a@, but see+         -- 'IVar',++instance (Show a) => Show (Result u a) where+  show (Done a) = printf "Done(%s)" $ show a+  show (Throw e) = printf "Throw(%s)" $ show e+  show Blocked{} = "Blocked"++{- Note [Exception]++How do we want to represent Haxl exceptions (those that are thrown by+"throw" in the Haxl monad)?++1) Explicitly via a Throw constructor in the Result type+2) Using throwIO in the IO monad++If we did (2), we would have to use an exception handler in <*>,+because an exception in the right-hand argument of <*> should not+necessarily be thrown by the whole computation - an exception on the+left should get priority, and the left might currently be Blocked.++We must be careful about turning IO monad exceptions into Haxl+exceptions.  An IO monad exception will normally propagate right+out of runHaxl and terminate the whole computation, whereas a Haxl+exception can get dropped on the floor, if it is on the right of+<*> and the left side also throws, for example.  So turning an IO+monad exception into a Haxl exception is a dangerous thing to do.+In particular, we never want to do it for an asynchronous exception+(AllocationLimitExceeded, ThreadKilled, etc.), because these are+supposed to unconditionally terminate the computation.++There are three places where we take an arbitrary IO monad exception and+turn it into a Haxl exception:++ * wrapFetchInCatch.  Here we want to propagate a failure of the+   data source to the callers of the data source, but if the+   failure came from elsewhere (an asynchronous exception), then we+   should just propagate it++ * cacheResult (cache the results of IO operations): again,+   failures of the IO operation should be visible to the caller as+   a Haxl exception, but we exclude asynchronous exceptions from+   this.++ * unsafeToHaxlException: assume the caller knows what they're+   doing, and just wrap all exceptions.+-}+++-- -----------------------------------------------------------------------------+-- Cont++-- | A data representation of a Haxl continuation.  This is to avoid+-- repeatedly traversing a left-biased tree in a continuation, leading+-- O(n^2) complexity for some pathalogical cases - see the "seql" benchmark+-- in tests/MonadBench.hs.+-- See "A Smart View on Datatypes", Jaskelioff/Rivas, ICFP'15+data Cont u a+  = Cont (GenHaxl u a)+  | forall b. Cont u b :>>= (b -> GenHaxl u a)+  | forall b. (b -> a) :<$> (Cont u b)++toHaxl :: Cont u a -> GenHaxl u a+toHaxl (Cont haxl) = haxl+toHaxl (m :>>= k) = toHaxlBind m k+toHaxl (f :<$> x) = toHaxlFmap f x++toHaxlBind :: Cont u b -> (b -> GenHaxl u a) -> GenHaxl u a+toHaxlBind (m :>>= k) k2 = toHaxlBind m (k >=> k2)+toHaxlBind (Cont haxl) k = haxl >>= k+toHaxlBind (f :<$> x) k = toHaxlBind x (k . f)++toHaxlFmap :: (a -> b) -> Cont u a -> GenHaxl u b+toHaxlFmap f (m :>>= k) = toHaxlBind m (k >=> return . f)+toHaxlFmap f (Cont haxl) = f <$> haxl+toHaxlFmap f (g :<$> x) = toHaxlFmap (f . g) x+++-- -----------------------------------------------------------------------------+-- Monad/Applicative instances++instance Monad (GenHaxl u) where+  return a = GenHaxl $ \_env -> return (Done a)+  GenHaxl m >>= k = GenHaxl $ \env -> do+    e <- m env+    case e of+      Done a -> unHaxl (k a) env+      Throw e -> return (Throw e)+      Blocked ivar cont -> trace_ ">>= Blocked" $+        return (Blocked ivar (cont :>>= k))+  fail msg = GenHaxl $ \_env ->+    return $ Throw $ toException $ MonadFail $ Text.pack msg++  -- We really want the Applicative version of >>+  (>>) = (*>)++instance Functor (GenHaxl u) where+  fmap f (GenHaxl m) = GenHaxl $ \env -> do+    r <- m env+    case r of+      Done a -> return (Done (f a))+      Throw e -> return (Throw e)+      Blocked ivar cont -> trace_ "fmap Blocked" $+        return (Blocked ivar (f :<$> cont))++instance Applicative (GenHaxl u) where+  pure = return+  GenHaxl ff <*> GenHaxl aa = GenHaxl $ \env -> do+    rf <- ff env+    case rf of+      Done f -> do+        ra <- aa env+        case ra of+          Done a -> trace_ "Done/Done" $ return (Done (f a))+          Throw e -> trace_ "Done/Throw" $ return (Throw e)+          Blocked ivar fcont -> trace_ "Done/Blocked" $+            return (Blocked ivar (f :<$> fcont))+      Throw e -> trace_ "Throw" $ return (Throw e)+      Blocked ivar1 fcont -> do+         ra <- aa env+         case ra of+           Done a -> trace_ "Blocked/Done" $+             return (Blocked ivar1 (($ a) :<$> fcont))+           Throw e -> trace_ "Blocked/Throw" $+             return (Blocked ivar1 (fcont :>>= (\_ -> throw e)))+           Blocked ivar2 acont -> trace_ "Blocked/Blocked" $ do+             -- Note [Blocked/Blocked]+              if speculative env /= 0+                then+                  return (Blocked ivar1+                            (Cont (toHaxl fcont <*> toHaxl acont)))+                else do+                  i <- newIVar+                  addJob env (toHaxl fcont) i ivar1+                  let cont = acont :>>= \a -> getIVarApply i a+                  return (Blocked ivar2 cont)++-- Note [Blocked/Blocked]+--+-- This is the tricky case: we're blocked on both sides of the <*>.+-- We need to divide the computation into two pieces that may continue+-- independently when the resources they are blocked on become+-- available.  Moreover, the computation as a whole depends on the two+-- pieces.  It works like this:+--+--   ff <*> aa+--+-- becomes+--+--   (ff >>= putIVar i) <*> (a <- aa; f <- getIVar i; return (f a)+--+-- where the IVar i is a new synchronisation point.  If the right side+-- gets to the `getIVar` first, it will block until the left side has+-- called 'putIVar'.+--+-- We can also do it the other way around:+--+--   (do ff <- f; getIVar i; return (ff a)) <*> (a >>= putIVar i)+--+-- The first was slightly faster according to tests/MonadBench.hs.++++-- -----------------------------------------------------------------------------+-- Env utils++-- | Extracts data from the 'Env'.+env :: (Env u -> a) -> GenHaxl u a+env f = GenHaxl $ \env -> return (Done (f env))++-- | Returns a version of the Haxl computation which always uses the+-- provided 'Env', ignoring the one specified by 'runHaxl'.+withEnv :: Env u -> GenHaxl u a -> GenHaxl u a+withEnv newEnv (GenHaxl m) = GenHaxl $ \_env -> do+  r <- m newEnv+  case r of+    Done a -> return (Done a)+    Throw e -> return (Throw e)+    Blocked ivar k ->+      return (Blocked ivar (Cont (withEnv newEnv (toHaxl k))))+++-- -----------------------------------------------------------------------------+-- Exceptions++-- | Throw an exception in the Haxl monad+throw :: (Exception e) => e -> GenHaxl u a+throw e = GenHaxl $ \_env -> raise e++raise :: (Exception e) => e -> IO (Result u a)+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+catch (GenHaxl m) h = GenHaxl $ \env -> do+   r <- m env+   case r of+     Done a    -> return (Done a)+     Throw e | Just e' <- fromException e -> unHaxl (h e') env+             | otherwise -> return (Throw e)+     Blocked ivar k -> return (Blocked ivar (Cont (catch (toHaxl k) h)))++-- | Catch exceptions that satisfy a predicate+catchIf+  :: Exception e => (e -> Bool) -> GenHaxl u a -> (e -> GenHaxl u a)+  -> GenHaxl u a+catchIf cond haxl handler =+  catch haxl $ \e -> if cond e then handler e else throw e++-- | Returns @'Left' e@ if the computation throws an exception @e@, or+-- @'Right' a@ if it returns a result @a@.+try :: Exception e => GenHaxl u a -> GenHaxl u (Either e a)+try haxl = (Right <$> haxl) `catch` (return . Left)++-- | @since 0.3.1.0+instance Catch.MonadThrow (GenHaxl u) where throwM = Haxl.Core.Monad.throw+-- | @since 0.3.1.0+instance Catch.MonadCatch (GenHaxl u) where catch = Haxl.Core.Monad.catch+++-- -----------------------------------------------------------------------------+-- Unsafe operations++-- | Under ordinary circumstances this is unnecessary; users of the Haxl+-- monad should generally /not/ perform arbitrary IO.+unsafeLiftIO :: IO a -> GenHaxl u a+unsafeLiftIO m = GenHaxl $ \_env -> Done <$> m++-- | Convert exceptions in the underlying IO monad to exceptions in+-- the Haxl monad.  This is morally unsafe, because you could then+-- catch those exceptions in Haxl and observe the underlying execution+-- order.  Not to be exposed to user code.+unsafeToHaxlException :: GenHaxl u a -> GenHaxl u a+unsafeToHaxlException (GenHaxl m) = GenHaxl $ \env -> do+  r <- m env `Exception.catch` \e -> return (Throw e)+  case r of+    Blocked cvar c ->+      return (Blocked cvar (Cont (unsafeToHaxlException (toHaxl c))))+    other -> return other++-- | Like 'try', but lifts all exceptions into the 'HaxlException'+-- hierarchy.  Uses 'unsafeToHaxlException' internally.  Typically+-- this is used at the top level of a Haxl computation, to ensure that+-- all exceptions are caught.+tryToHaxlException :: GenHaxl u a -> GenHaxl u (Either HaxlException a)+tryToHaxlException h = left asHaxlException <$> try (unsafeToHaxlException h)+++-- -----------------------------------------------------------------------------++-- | Dump the contents of the cache as Haskell code that, when+-- compiled and run, will recreate the same cache contents.  For+-- example, the generated code looks something like this:+--+-- > loadCache :: GenHaxl u ()+-- > loadCache = do+-- >   cacheRequest (ListWombats 3) (Right ([1,2,3]))+-- >   cacheRequest (CountAardvarks "abcabc") (Right (2))+--+dumpCacheAsHaskell :: GenHaxl u String+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.+  let+    readIVar (IVar ref) = do+      r <- readIORef ref+      case r of+        IVarFull (Ok a) -> return (Just (Right a))+        IVarFull (ThrowHaxl e) -> return (Just (Left e))+        IVarFull (ThrowIO e) -> return (Just (Left e))+        IVarEmpty _ -> return Nothing++    mk_cr (req, res) =+      text "cacheRequest" <+> parens (text req) <+> parens (result res)+    result (Left e) = text "except" <+> parens (text (show e))+    result (Right s) = text "Right" <+> parens (text s)++  entries <- unsafeLiftIO $ do+    cache <- readIORef ref+    showCache cache readIVar++  return $ show $+    text (fnName ++ " :: " ++ fnType) $$+    text (fnName ++ " = do") $$+      nest 2 (vcat (map mk_cr (concatMap snd entries))) $$+    text "" -- final newline

@@ -0,0 +1,84 @@+-- Copyright (c) 2014-present, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file.++{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RecordWildCards #-}++-- | Psuedo-parallel operations.  Most users should import "Haxl.Core"+-- instead.+--+module Haxl.Core.Parallel+  ( -- * Parallel operations+    pAnd+  , pOr+  ) where++import Haxl.Core.Monad++-- -----------------------------------------------------------------------------+-- Parallel operations++-- Bind more tightly than .&&, .||+infixr 5 `pAnd`+infixr 4 `pOr`++-- | Parallel version of '(.||)'.  Both arguments are evaluated in+-- parallel, and if either returns 'True' then the other is+-- not evaluated any further.+--+-- WARNING: exceptions may be unpredictable when using 'pOr'.  If one+-- argument returns 'True' before the other completes, then 'pOr'+-- returns 'True' immediately, ignoring a possible exception that+-- the other argument may have produced if it had been allowed to+-- complete.+pOr :: GenHaxl u Bool -> GenHaxl u Bool -> GenHaxl u Bool+GenHaxl a `pOr` GenHaxl b = GenHaxl $ \env@Env{..} -> do+  let !senv = speculate env+  ra <- a senv+  case ra of+    Done True -> return (Done True)+    Done False -> b env  -- not speculative+    Throw _ -> return ra+    Blocked ia a' -> do+      rb <- b senv+      case rb of+        Done True -> return rb+        Done False -> return ra+        Throw _ -> return rb+        Blocked _ b' -> return (Blocked ia (Cont (toHaxl a' `pOr` toHaxl b')))+          -- Note [pOr Blocked/Blocked]+          -- This will only wake up when ia is filled, which+          -- is whatever the left side was waiting for.  This is+          -- suboptimal because the right side might wake up first,+          -- but handling this non-determinism would involve a much+          -- more complicated implementation here.++-- | Parallel version of '(.&&)'.  Both arguments are evaluated in+-- parallel, and if either returns 'False' then the other is+-- not evaluated any further.+--+-- WARNING: exceptions may be unpredictable when using 'pAnd'.  If one+-- argument returns 'False' before the other completes, then 'pAnd'+-- returns 'False' immediately, ignoring a possible exception that+-- the other argument may have produced if it had been allowed to+-- complete.+pAnd :: GenHaxl u Bool -> GenHaxl u Bool -> GenHaxl u Bool+GenHaxl a `pAnd` GenHaxl b = GenHaxl $ \env@Env{..} -> do+  let !senv = speculate env+  ra <- a senv+  case ra of+    Done False -> return (Done False)+    Done True -> b env+    Throw _ -> return ra+    Blocked ia a' -> do+      rb <- b senv+      case rb of+        Done False -> return rb+        Done True -> return ra+        Throw _ -> return rb+        Blocked _ b' -> return (Blocked ia (Cont (toHaxl a' `pAnd` toHaxl b')))+         -- See Note [pOr Blocked/Blocked]

@@ -0,0 +1,158 @@+-- Copyright (c) 2014-present, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file.++{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Implementation of lightweight profiling.  Most users should+-- import "Haxl.Core" instead.+--+module Haxl.Core.Profile+  ( withLabel+  , withFingerprintLabel+  , addProfileFetch+  , incrementMemoHitCounterFor+  , collectProfileData+  , profileCont+  ) where++import Data.IORef+import Data.Hashable+import Data.Monoid+import Data.Text (Text)+import Data.Typeable+import qualified Data.HashMap.Strict as HashMap+import qualified Data.HashSet as HashSet+import GHC.Exts+import qualified Data.Text as Text++import Haxl.Core.DataSource+import Haxl.Core.Flags+import Haxl.Core.Stats+import Haxl.Core.Monad++-- -----------------------------------------------------------------------------+-- Profiling++-- | 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 ->+  if report (flags env) < 4+     then m env+     else collectProfileData l m env++-- | 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 ->+  if report (flags env) < 4+     then m env+     else collectProfileData+            (Text.unpackCString# mnPtr <> "." <> Text.unpackCString# nPtr)+            m env++-- | Collect profiling data and attribute it to given label.+collectProfileData+  :: ProfileLabel+  -> (Env u -> IO (Result u a))+  -> Env u+  -> IO (Result u a)+collectProfileData l m env = do+   a0 <- getAllocationCounter+   r <- m env{profLabel=l} -- 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 ivar k -> return (Blocked ivar (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 }+++-- Like collectProfileData, but intended to be run from the scheduler.+--+-- * doesn't add a dependency (the original withLabel did this)+--+-- * doesn't subtract allocs from the caller (we're evaluating this+--   cont from the top level, so we don't need this)+--+-- * doesn't wrap a Blocked continuation in withLabel (the scheduler+--   will call profileCont the next time this cont runs)+--+profileCont+  :: (Env u -> IO (Result u a))+  -> Env u+  -> IO (Result u a)+profileCont m env = do+  a0 <- getAllocationCounter+  r <- m env+  a1 <- getAllocationCounter+  let+    allocs = a0 - a1+    newEntry = emptyProfileData { profileAllocs = allocs }+    updEntry _ old = old { profileAllocs = profileAllocs old + allocs }+  modifyIORef' (profRef env) $ \ p ->+    p { profile =+         HashMap.insertWith updEntry (profLabel env) newEntry $+         profile p }+  -- So we do not count the allocation overhead of modifyProfileData+  setAllocationCounter a1+  return r+{-# INLINE profileCont #-}+++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) }++{-# NOINLINE addProfileFetch #-}+addProfileFetch+  :: forall r u a . (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+      dsName = dataSourceName (Proxy :: Proxy r)++      upd :: ProfileData -> ProfileData+      upd d = d { profileFetches =+        HashMap.insertWith (+) dsName 1 (profileFetches d) }++    in p { profile = HashMap.adjust upd (profLabel env) (profile p) }+  -- So we do not count the allocation overhead of addProfileFetch+  setAllocationCounter c

@@ -2,8 +2,7 @@ -- 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.+-- found in the LICENSE file.  {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-}@@ -18,12 +17,17 @@ -- -- 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+--+module Haxl.Core.RequestStore+  ( BlockedFetches(..)+  , RequestStore+  , isEmpty+  , noRequests+  , addRequest+  , contents   ) where -import Haxl.Core.Types+import Haxl.Core.DataSource import Data.Map (Map) import qualified Data.Map.Strict as Map import Data.Typeable@@ -38,6 +42,9 @@ -- | A batch of 'BlockedFetch' objects for a single 'DataSource' data BlockedFetches u =   forall r. (DataSource u r) => BlockedFetches [BlockedFetch r]++isEmpty :: RequestStore u -> Bool+isEmpty (RequestStore m) = Map.null m  -- | A new empty 'RequestStore'. noRequests :: RequestStore u

@@ -0,0 +1,220 @@+-- Copyright (c) 2014-present, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file.++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Defines 'runHaxl'.  Most users should import "Haxl.Core" instead.+--+module Haxl.Core.Run+  ( runHaxl+  ) where++import Control.Concurrent.STM+import Control.Exception as Exception+import Control.Monad+import Data.IORef+import Text.Printf+import Unsafe.Coerce++import Haxl.Core.DataCache+import Haxl.Core.Exception+import Haxl.Core.Flags+import Haxl.Core.Monad+import Haxl.Core.Fetch+import Haxl.Core.Profile+import Haxl.Core.RequestStore as RequestStore+import Haxl.Core.Stats+++-- -----------------------------------------------------------------------------+-- runHaxl++-- | Runs a 'Haxl' computation in the given 'Env'.+runHaxl :: forall u a. Env u -> GenHaxl u a -> IO a+runHaxl env@Env{..} haxl = do++  result@(IVar resultRef) <- newIVar -- where to put the final result+  let+    -- Run a job, and put its result in the given IVar+    schedule :: Env u -> JobList u -> GenHaxl u b -> IVar u b -> IO ()+    schedule env@Env{..} rq (GenHaxl run) (IVar !ref) = do+      ifTrace flags 3 $ printf "schedule: %d\n" (1 + lengthJobList rq)+      let {-# INLINE result #-}+          result r = do+            e <- readIORef ref+            case e of+              IVarFull _ -> error "multiple put"+              IVarEmpty haxls -> do+                writeIORef ref (IVarFull r)+                -- Have we got the final result now?+                if ref == unsafeCoerce resultRef+                        -- comparing IORefs of different types is safe, it's+                        -- pointer-equality on the MutVar#.+                   then+                     -- We have a result, but don't discard unfinished+                     -- computations in the run queue. See+                     -- Note [runHaxl and unfinished requests].+                     -- Nothing can depend on the final IVar, so haxls must+                     -- be empty.+                     case rq of+                       JobNil -> return ()+                       _ -> modifyIORef' runQueueRef (appendJobList rq)+                   else reschedule env (appendJobList haxls rq)+      r <-+        if report flags >= 4          -- withLabel unfolded+          then Exception.try $ profileCont run env+          else Exception.try $ run env+      case r of+        Left e -> do+          rethrowAsyncExceptions e+          result (ThrowIO e)+        Right (Done a) -> result (Ok a)+        Right (Throw ex) -> result (ThrowHaxl ex)+        Right (Blocked ivar fn) -> do+          addJob env (toHaxl fn) (IVar ref) ivar+          reschedule env rq++    -- Here we have a choice:+    --   - If the requestStore is non-empty, we could submit those+    --     requests right away without waiting for more.  This might+    --     be good for latency, especially if the data source doesn't+    --     support batching, or if batching is pessimal.+    --   - To optimise the batch sizes, we want to execute as much as+    --     we can and only submit requests when we have no more+    --     computation to do.+    --   - compromise: wait at least Nms for an outstanding result+    --     before giving up and submitting new requests.+    --+    -- For now we use the batching strategy in the scheduler, but+    -- individual data sources can request that their requests are+    -- sent eagerly by using schedulerHint.+    --+    reschedule :: Env u -> JobList u -> IO ()+    reschedule env@Env{..} haxls = do+      case haxls of+        JobNil -> do+          rq <- readIORef runQueueRef+          case rq of+            JobNil -> emptyRunQueue env+            JobCons env' a b c -> do+              writeIORef runQueueRef JobNil+              schedule env' c a b+        JobCons env' a b c ->+          schedule env' c a b++    emptyRunQueue :: Env u -> IO ()+    emptyRunQueue env@Env{..} = do+      ifTrace flags 3 $ printf "emptyRunQueue\n"+      haxls <- checkCompletions env+      case haxls of+        JobNil -> do+          case pendingWaits of+            [] -> checkRequestStore env+            wait:waits -> do+              ifTrace flags 3 $ printf "invoking wait\n"+              wait+              emptyRunQueue env { pendingWaits = waits } -- check completions+        _ -> reschedule env haxls++    checkRequestStore :: Env u -> IO ()+    checkRequestStore env@Env{..} = do+      reqStore <- readIORef reqStoreRef+      if RequestStore.isEmpty reqStore+        then waitCompletions env+        else do+          writeIORef reqStoreRef noRequests+          (_, waits) <- performRequestStore 0 env reqStore+          ifTrace flags 3 $ printf "performFetches: %d waits\n" (length waits)+          -- empty the cache if we're not caching.  Is this the best+          -- place to do it?  We do get to de-duplicate requests that+          -- happen simultaneously.+          when (caching flags == 0) $+            writeIORef cacheRef emptyDataCache+          emptyRunQueue env{ pendingWaits = waits ++ pendingWaits }++    checkCompletions :: Env u -> IO (JobList u)+    checkCompletions Env{..} = do+      ifTrace flags 3 $ printf "checkCompletions\n"+      comps <- atomically $ do+        c <- readTVar completions+        writeTVar completions []+        return c+      case comps of+        [] -> return JobNil+        _ -> do+          ifTrace flags 3 $ printf "%d complete\n" (length comps)+          let+              getComplete (CompleteReq a (IVar cr) allocs) = do+                when (allocs < 0) $ do+                  cur <- getAllocationCounter+                  setAllocationCounter (cur + allocs)+                r <- readIORef cr+                case r of+                  IVarFull _ -> do+                    ifTrace flags 3 $ printf "existing result\n"+                    return JobNil+                    -- this happens if a data source reports a result,+                    -- and then throws an exception.  We call putResult+                    -- a second time for the exception, which comes+                    -- ahead of the original request (because it is+                    -- pushed on the front of the completions list) and+                    -- therefore overrides it.+                  IVarEmpty cv -> do+                    writeIORef cr (IVarFull (eitherToResult a))+                    return cv+          jobs <- mapM getComplete comps+          return (foldr appendJobList JobNil jobs)++    waitCompletions :: Env u -> IO ()+    waitCompletions env@Env{..} = do+      ifTrace flags 3 $ printf "waitCompletions\n"+      atomically $ do+        c <- readTVar completions+        when (null c) retry+      emptyRunQueue env++  --+  schedule env JobNil haxl result+  r <- readIORef resultRef+  case r of+    IVarEmpty _ -> throwIO (CriticalError "runHaxl: missing result")+    IVarFull (Ok a)  -> return a+    IVarFull (ThrowHaxl e)  -> throwIO e+    IVarFull (ThrowIO e)  -> throwIO e+++{- Note [runHaxl and unfinished requests]++runHaxl returns immediately when the supplied computation has returned+a result.  This doesn't necessarily mean that the whole computaiton+graph has completed, however.  In particular, when using pAnd and pOr,+we might have created some data fetches that have not completed, but+weren't required, because the other branch of the pAnd/pOr subsumed+the result.++When runHaxl returns, it might be that:+- reqStoreRef contains some unsubmitted requests+- runQueueRef contains some jobs+- there are in-flight BackgroundFetch requests, that will return their+  results to the completions queue in due course.+- there are various unfilled IVars in the cache and/or memo tables++This should be all safe, we can even restart runHaxl with the same Env+after it has stopped and the in-progress computations will+continue. But don't discard the contents of+reqStoreRef/runQueueRef/completions, because then we'll deadlock if we+discover one of the unfilled IVars in the cache or memo table.+-}++{- TODO: later+data SchedPolicy+  = SubmitImmediately+  | WaitAtLeast Int{-ms-}+  | WaitForAllPendingRequests+-}

@@ -2,11 +2,12 @@ -- 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.+-- found in the LICENSE file. +-- | -- Most users should import "Haxl.Core" instead of importing this -- module directly.+-- module Haxl.Core.ShowP   ( ShowP(..)   ) where

@@ -2,8 +2,7 @@ -- 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.+-- found in the LICENSE file.  {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-}@@ -11,10 +10,16 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE CPP #-} --- | Most users should import "Haxl.Core" instead of importing this+-- |+-- Most users should import "Haxl.Core" instead of importing this -- module directly.-module Haxl.Core.StateStore (-    StateKey(..), StateStore, stateGet, stateSet, stateEmpty+--+module Haxl.Core.StateStore+  ( StateKey(..)+  , StateStore+  , stateGet+  , stateSet+  , stateEmpty   ) where  import Data.Map (Map)@@ -28,12 +33,17 @@ -- #if __GLASGOW_HASKELL__ >= 708 class Typeable f => StateKey (f :: * -> *) where-  data State f #else class Typeable1 f => StateKey (f :: * -> *) where-  data State f #endif+  data State f +  -- | We default this to typeOf1, but if f is itself a complex type that is+  -- already applied to some paramaters, we want to be able to use the same+  -- state by using typeOf2, etc+  getStateType :: Proxy f -> TypeRep+  getStateType = typeRep+ -- | The 'StateStore' maps a 'StateKey' to the 'State' for that type. newtype StateStore = StateStore (Map TypeRep StateStoreData) @@ -48,22 +58,18 @@ -- | Inserts a `State` in the `StateStore` container. stateSet :: forall f . StateKey f => State f -> StateStore -> StateStore stateSet st (StateStore m) =-  StateStore (Map.insert (getType st) (StateStoreData st) m)+  StateStore (Map.insert (getStateType (Proxy :: Proxy f)) (StateStoreData st) m)  -- | Retrieves a `State` from the `StateStore` container. stateGet :: forall r . StateKey r => StateStore -> Maybe (State r) stateGet (StateStore m) =   case Map.lookup ty m of      Nothing -> Nothing-     Just (StateStoreData st)-       | getType st == ty  -> Just (unsafeCoerce st)-       | otherwise         -> Nothing+     Just (StateStoreData (st :: State f))+       | getStateType (Proxy :: Proxy f) == ty -> Just (unsafeCoerce st)+       | otherwise             -> Nothing           -- the dynamic type check here should be unnecessary, but if           -- there are bugs in `Typeable` or `Map` then we'll get an           -- error instead of a crash.  The overhead is a few percent.  where-  ty = getType (undefined :: State r)---- | Returns the 'TypeRep' associated with a particular 'State'.-getType :: forall f . StateKey f => State f -> TypeRep-getType _ = typeOf1 (undefined :: f a)+  ty = getStateType (Proxy :: Proxy r)

@@ -0,0 +1,209 @@+-- Copyright (c) 2014-present, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file.++{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- |+-- Types and operations for statistics and profiling.  Most users+-- should import "Haxl.Core" instead of importing this module+-- directly.+--+module Haxl.Core.Stats+  (+  -- * Data-source stats+    Stats(..)+  , FetchStats(..)+  , Microseconds+  , Timestamp+  , getTimestamp+  , emptyStats+  , numRounds+  , numFetches+  , ppStats+  , ppFetchStats++  -- * Profiling+  , Profile+  , emptyProfile+  , profile+  , ProfileLabel+  , ProfileData(..)+  , emptyProfileData+  , AllocCount+  , MemoHitCount++  -- * Allocation+  , getAllocationCounter+  , setAllocationCounter+  ) where++import Data.Aeson+import Data.HashMap.Strict (HashMap)+import Data.HashSet (HashSet)+import Data.Int+import Data.List (intercalate, maximumBy, minimumBy)+#if __GLASGOW_HASKELL__ < 710+import Data.Monoid+#endif+import Data.Semigroup (Semigroup)+import Data.Ord (comparing)+import Data.Text (Text)+import Data.Time.Clock.POSIX+import Text.Printf+import qualified Data.HashMap.Strict as HashMap+import qualified Data.HashSet as HashSet+import qualified Data.Text as Text++#if __GLASGOW_HASKELL__ >= 710+import GHC.Conc (getAllocationCounter, setAllocationCounter)+#endif++-- ---------------------------------------------------------------------------+-- Measuring time++type Microseconds = Int64+type Timestamp = Microseconds -- since an epoch++getTimestamp :: IO Timestamp+getTimestamp = do+  t <- getPOSIXTime -- for now, TODO better+  return (round (t * 1000000))++-- ---------------------------------------------------------------------------+-- Stats++-- | Stats that we collect along the way.+newtype Stats = Stats [FetchStats]+  deriving (Show, ToJSON, Semigroup, Monoid)++-- | Pretty-print Stats.+ppStats :: Stats -> String+ppStats (Stats rss) =+  intercalate "\n"+    [ "["+    ++ [+      if fetchWasRunning rs+          (minStartTime + (t - 1) * usPerDash)+          (minStartTime + t * usPerDash)+        then '*'+        else '-'+      | t <- [1..numDashes]+      ]+    ++ "] " ++ show i ++ " - " ++ ppFetchStats rs+    | (i, rs) <- zip [(1::Int)..] validFetchStats ]+  where+    isFetchStats FetchStats{} = True+    isFetchStats _ = False+    validFetchStats = filter isFetchStats (reverse rss)+    numDashes = 50+    minStartTime = fetchStart $ minimumBy (comparing fetchStart) validFetchStats+    lastFs = maximumBy (comparing (\fs -> fetchStart fs + fetchDuration fs))+      validFetchStats+    usPerDash = (fetchStart lastFs + fetchDuration lastFs - minStartTime)+      `div` numDashes+    fetchWasRunning :: FetchStats -> Timestamp -> Timestamp -> Bool+    fetchWasRunning fs t1 t2 =+      (fetchStart fs + fetchDuration fs) >= t1 && fetchStart fs < t2+++-- | 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 FetchStats+    -- | Timing stats for a (batched) data fetch+  = FetchStats+    { fetchDataSource :: Text+    , fetchBatchSize :: {-# UNPACK #-} !Int+    , fetchStart :: !Timestamp          -- TODO should be something else+    , fetchDuration :: {-# UNPACK #-} !Microseconds+    , fetchSpace :: {-# UNPACK #-} !Int64+    , fetchFailures :: {-# UNPACK #-} !Int+    }++    -- | 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.+ppFetchStats :: FetchStats -> String+ppFetchStats FetchStats{..} =+  printf "%s: %d fetches (%.2fms, %d bytes, %d failures)"+    (Text.unpack fetchDataSource) fetchBatchSize+    (fromIntegral fetchDuration / 1000 :: Double)  fetchSpace fetchFailures+ppFetchStats (FetchCall r ss) = show r ++ '\n':show ss++instance ToJSON FetchStats where+  toJSON FetchStats{..} = object+    [ "datasource" .= fetchDataSource+    , "fetches" .= fetchBatchSize+    , "start" .= fetchStart+    , "duration" .= fetchDuration+    , "allocation" .= fetchSpace+    , "failures" .= fetchFailures+    ]+  toJSON (FetchCall req strs) = object+    [ "request" .= req+    , "stack" .= strs+    ]++emptyStats :: Stats+emptyStats = Stats []++numRounds :: Stats -> Int+numRounds (Stats rs) = length rs        -- not really++numFetches :: Stats -> Int+numFetches (Stats rs) = sum [ fetchBatchSize | FetchStats{..} <- rs ]+++-- ---------------------------------------------------------------------------+-- Profiling++type ProfileLabel = Text+type AllocCount = Int64+type MemoHitCount = Int64++newtype Profile = Profile+  { profile      :: HashMap ProfileLabel ProfileData+     -- ^ Data on individual labels.+  }++emptyProfile :: Profile+emptyProfile = Profile HashMap.empty++data ProfileData = ProfileData+  { profileAllocs :: {-# UNPACK #-} !AllocCount+     -- ^ allocations made by this label+  , profileDeps :: HashSet ProfileLabel+     -- ^ labels that this label depends on+  , profileFetches :: HashMap Text Int+     -- ^ map from 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 HashMap.empty 0+++-- -----------------------------------------------------------------------------+-- Allocation accounting++#if __GLASGOW_HASKELL__ < 710+getAllocationCounter :: IO Int64+getAllocationCounter = return 0++setAllocationCounter :: Int64 -> IO ()+setAllocationCounter _ = return ()+#endif

@@ -1,636 +0,0 @@--- Copyright (c) 2014-present, Facebook, Inc.--- All rights reserved.------ This source code is distributed under the terms of a BSD license,--- found in the LICENSE file. An additional grant of patent rights can--- be found in the PATENTS file.--{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-#if __GLASGOW_HASKELL >= 800-{-# OPTIONS_GHC -Wno-name-shadowing #-}-#else-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}-#endif---- | Base types used by all of Haxl. Most users should import--- "Haxl.Core" instead of importing this module directly.-module Haxl.Core.Types (--  -- * Tracing flags-  Flags(..),-  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(..),-  DataSourceName(..),-  Request,-  BlockedFetch(..),-  PerformFetch(..),--  -- * DataCache-  DataCache(..),-  SubCache(..),-  emptyDataCache,--  -- * Result variables-  ResultVar(..),-  newEmptyResult,-  newResult,-  putFailure,-  putResult,-  putSuccess,-  takeResult,-  tryReadResult,-  tryTakeResult,--  -- * Default fetch implementations-  asyncFetch, asyncFetchWithDispatch,-  asyncFetchAcquireRelease,-  stubFetch,-  syncFetch,--  -- * Utilities-  except,-  setError,--  ) where--#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif-import Control.Concurrent.MVar-import Control.Exception-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--import Haxl.Core.Exception-#if __GLASGOW_HASKELL__ < 708-import Haxl.Core.Util (tryReadMVar)-#endif-import Haxl.Core.ShowP-import Haxl.Core.StateStore---- ------------------------------------------------------------------------------ Flags---- | Flags that control the operation of the engine.-data Flags = Flags-  { trace :: {-# UNPACK #-} !Int-    -- ^ Tracing level (0 = quiet, 3 = very verbose).-  , report :: {-# UNPACK #-} !Int-    -- ^ Report level (0 = quiet, 1 = # 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-  }--#if __GLASGOW_HASKELL__ >= 710-#define FUNMONAD Monad m-#else-#define FUNMONAD (Functor m, Monad m)-#endif---- | Runs an action if the tracing level is above the given threshold.-ifTrace :: FUNMONAD => Flags -> Int -> m a -> m ()-ifTrace flags i = when (trace flags >= i) . void---- | Runs an action if the report level is above the given threshold.-ifReport :: FUNMONAD => Flags -> Int -> m a -> m ()-ifReport flags i = when (report flags >= i) . void--ifProfiling :: FUNMONAD => Flags -> m a -> m ()-ifProfiling flags = when (report flags >= 4) . void--#undef FUNMONAD---- ------------------------------------------------------------------------------ Stats--type Microseconds = Int--- | Rounds are 1-indexed-type Round = Int---- | Stats that we collect along the way.-newtype Stats = Stats [RoundStats]-  deriving (Show, ToJSON)---- | Pretty-print Stats.-ppStats :: Stats -> String-ppStats (Stats 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-    -- | 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 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 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) =-  sum $ map dataSourceFetches $ HashMap.elems hm-fetchesInRound _ = 0--emptyStats :: Stats-emptyStats = Stats []--numRounds :: Stats -> Int-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.------ A data source keeps track of its state by creating an instance of--- 'StateKey' to map the request type to its state. In this case, the--- type of the state should probably be a reference type of some kind,--- such as 'IORef'.------ For a complete example data source, see--- <https://github.com/facebook/Haxl/tree/master/example Examples>.----class (DataSourceName req, StateKey req, ShowP req) => DataSource u req where--  -- | Issues a list of fetches to this 'DataSource'. The 'BlockedFetch'-  -- objects contain both the request and the 'ResultVar's into which to put-  -- the results.-  fetch-    :: State req-      -- ^ Current state.-    -> Flags-      -- ^ Tracing flags.-    -> u-      -- ^ User environment.-    -> [BlockedFetch req]-      -- ^ Requests to fetch.-    -> PerformFetch-      -- ^ Fetch the data; see 'PerformFetch'.--class DataSourceName req where-  -- | The name of this 'DataSource', used in tracing and stats. Must-  -- take a dummy request.-  dataSourceName :: req a -> Text---- The 'ShowP' class is a workaround for the fact that we can't write--- @'Show' (req a)@ as a superclass of 'DataSource', without also--- parameterizing 'DataSource' over @a@, which is a pain (I tried--- it). 'ShowP' seems fairly benign, though.---- | A convenience only: package up 'Eq', 'Hashable', 'Typeable', and 'Show'--- for requests into a single constraint.-type Request req a =-  ( Eq (req a)-  , Hashable (req a)-  , Typeable (req a)-  , Show (req a)-  , Show a-  )---- | A data source can fetch data in one of two ways.------   * Synchronously ('SyncFetch'): the fetching operation is an---     @'IO' ()@ that fetches all the data and then returns.------   * Asynchronously ('AsyncFetch'): we can do something else while the---     data is being fetched. The fetching operation takes an @'IO' ()@ as---     an argument, which is the operation to perform while the data is---     being fetched.------ See 'syncFetch' and 'asyncFetch' for example usage.----data PerformFetch-  = SyncFetch  (IO ())-  | AsyncFetch (IO () -> IO ())---- Why does AsyncFetch contain a `IO () -> IO ()` rather than the--- alternative approach of returning the `IO` action to retrieve the--- results, which might seem better: `IO (IO ())`?  The point is that--- this allows the data source to acquire resources for the purpose of--- this fetching round using the standard `bracket` pattern, so it can--- ensure that the resources acquired are properly released even if--- other data sources fail.---- | A 'BlockedFetch' is a pair of------   * The request to fetch (with result type @a@)------   * 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--- together in a list because all the elements of the list must have the--- 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 'ResultVar'--- out, the type system knows that the result type of the request--- 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)---- | Function for easily setting a fetch to a particular exception-setError :: (Exception e) => (forall a. r a -> e) -> BlockedFetch r -> IO ()-setError e (BlockedFetch req m) = putFailure m (e req)--except :: (Exception e) => e -> Either SomeException a-except = Left . toException---- | 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.------  2. To remember requests that have been encountered in the current round but---     are not yet submitted, so that if we see the request again we can make---     sure that we only submit it once.------ Storing the result as an 'MVar' gives two benefits:------   * We can tell the difference between (1) and (2) by testing whether the---     'MVar' is empty. See 'Haxl.Fetch.cached'.------   * In the case of (2), we don't have to update the cache again after the---     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.--newResult :: a -> IO (ResultVar a)-newResult x = ResultVar <$> newMVar (Right x)--newEmptyResult :: IO (ResultVar a)-newEmptyResult = ResultVar <$> newEmptyMVar--putFailure :: (Exception e) => ResultVar a -> e -> IO ()-putFailure r = putResult r . except--putSuccess :: ResultVar a -> a -> IO ()-putSuccess r = putResult r . Right--putResult :: ResultVar a -> Either SomeException a -> IO ()-putResult (ResultVar var) = putMVar var--takeResult :: ResultVar a -> IO (Either SomeException a)-takeResult (ResultVar var) = takeMVar var--tryReadResult :: ResultVar a -> IO (Maybe (Either SomeException a))-tryReadResult (ResultVar var) = tryReadMVar var--tryTakeResult :: ResultVar a -> IO (Maybe (Either SomeException a))-tryTakeResult (ResultVar var) = tryTakeMVar var---- Fetch templates--stubFetch-  :: (Exception e) => (forall a. r a -> e)-  -> State r -> Flags -> u -> [BlockedFetch r] -> PerformFetch-stubFetch e _state _flags _si bfs = SyncFetch $ mapM_ (setError e) bfs---- | Common implementation templates for 'fetch' of 'DataSource'.------ Example usage:------ > fetch = syncFetch MyDS.withService MyDS.retrieve--- >   $ \service request -> case request of--- >     This x -> MyDS.fetchThis service x--- >     That y -> MyDS.fetchThat service y----asyncFetchWithDispatch-  :: ((service -> IO ()) -> IO ())-  -- ^ Wrapper to perform an action in the context of a service.--  -> (service -> IO ())-  -- ^ Dispatch all the pending requests--  -> (service -> IO ())-  -- ^ Wait for the results--  -> (forall a. service -> request a -> IO (IO (Either SomeException a)))-  -- ^ Enqueue an individual request to the service.--  -> State request-  -- ^ Currently unused.--  -> Flags-  -- ^ Currently unused.--  -> u-  -- ^ Currently unused.--  -> [BlockedFetch request]-  -- ^ Requests to submit.--  -> PerformFetch--asyncFetch, syncFetch-  :: ((service -> IO ()) -> IO ())-  -- ^ Wrapper to perform an action in the context of a service.--  -> (service -> IO ())-  -- ^ Dispatch all the pending requests and wait for the results--  -> (forall a. service -> request a -> IO (IO (Either SomeException a)))-  -- ^ Submits an individual request to the service.--  -> State request-  -- ^ Currently unused.--  -> Flags-  -- ^ Currently unused.--  -> u-  -- ^ Currently unused.--  -> [BlockedFetch request]-  -- ^ Requests to submit.--  -> PerformFetch--asyncFetchWithDispatch-  withService dispatch wait enqueue _state _flags _si requests =-  AsyncFetch $ \inner -> withService $ \service -> do-    getResults <- mapM (submitFetch service enqueue) requests-    dispatch service-    inner-    wait service-    sequence_ getResults--asyncFetch withService wait enqueue _state _flags _si requests =-  AsyncFetch $ \inner -> withService $ \service -> do-    getResults <- mapM (submitFetch service enqueue) requests-    inner-    wait service-    sequence_ getResults--syncFetch withService dispatch enqueue _state _flags _si requests =-  SyncFetch . withService $ \service -> do-  getResults <- mapM (submitFetch service enqueue) requests-  dispatch service-  sequence_ getResults---{- |-A version of 'asyncFetch' (actually 'asyncFetchWithDispatch') that-handles exceptions correctly.  You should use this instead of-'asyncFetch' or 'asyncFetchWithDispatch'.  The danger with-'asyncFetch' is that if an exception is thrown by @withService@, the-@inner@ action won't be executed, and we'll drop some data-fetches in-the same round.--'asyncFetchAcquireRelease' behaves like the following:--> asyncFetchAcquireRelease acquire release dispatch wait enqueue =->   AsyncFetch $ \inner ->->     bracket acquire release $ \service -> do->       getResults <- mapM (submitFetch service enqueue) requests->       dispatch service->       inner->       wait service->       sequence_ getResults--except that @inner@ is run even if @acquire@, @enqueue@, or @dispatch@ throws,-/unless/ an async exception is received.--}--asyncFetchAcquireRelease-  :: IO service-  -- ^ Resource acquisition for this datasource--  -> (service -> IO ())-  -- ^ Resource release--  -> (service -> IO ())-  -- ^ Dispatch all the pending requests and wait for the results--  -> (service -> IO ())-  -- ^ Wait for the results--  -> (forall a. service -> request a -> IO (IO (Either SomeException a)))-  -- ^ Submits an individual request to the service.--  -> State request-  -- ^ Currently unused.--  -> Flags-  -- ^ Currently unused.--  -> u-  -- ^ Currently unused.--  -> [BlockedFetch request]-  -- ^ Requests to submit.--  -> PerformFetch--asyncFetchAcquireRelease-  acquire release dispatch wait enqueue _state _flags _si requests =-  AsyncFetch $ \inner -> mask $ \restore -> do-    r1 <- tryWithRethrow acquire-    case r1 of-      Left err -> do restore inner; throwIO (err :: SomeException)-      Right service -> do-        flip finally (release service) $ restore $ do-          r2 <- tryWithRethrow $ do-            getResults <- mapM (submitFetch service enqueue) requests-            dispatch service-            return getResults-          inner  --  we assume this cannot throw, ensured by performFetches-          case r2 of-            Left err -> throwIO (err :: SomeException)-            Right getResults -> do wait service; sequence_ getResults---- | Used by 'asyncFetch' and 'syncFetch' to retrieve the results of--- requests to a service.-submitFetch-  :: service-  -> (forall a. service -> request a -> IO (IO (Either SomeException a)))-  -> BlockedFetch request-  -> IO (IO ())-submitFetch service fetch (BlockedFetch request result)-  = (putResult result =<<) <$> fetch service request

@@ -2,23 +2,15 @@ -- All rights reserved. -- -- This source code is distributed under the terms of a BSD license,--- found in the LICENSE file. An additional grant of patent rights can--- be found in the PATENTS file.--{-# LANGUAGE CPP #-}+-- found in the LICENSE file. +-- | Internal utilities only.+-- module Haxl.Core.Util   ( compose   , textShow-  , tryReadMVar   ) where -#if __GLASGOW_HASKELL__ >= 708-import Control.Concurrent (tryReadMVar)-#else-import Control.Concurrent-#endif- import Data.Text (Text)  import qualified Data.Text as Text@@ -26,15 +18,6 @@ -- | Composes a list of endofunctions. compose :: [a -> a] -> a -> a compose = foldr (.) id--#if __GLASGOW_HASKELL__ < 708-tryReadMVar :: MVar a -> IO (Maybe a)-tryReadMVar m = do-  mb <- tryTakeMVar m-  case mb of-    Nothing -> return Nothing-    Just a -> putMVar m a >> return (Just a)-#endif  textShow :: (Show a) => a -> Text textShow = Text.pack . show

@@ -0,0 +1,83 @@+-- Copyright (c) 2014-present, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file.++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- A generic Haxl datasource for performing arbitrary IO concurrently.+-- Every IO operation will be performed in a separate thread.+-- You can use this with any kind of IO, but each different operation+-- requires an instance of the 'ConcurrentIO' class.+--+-- For example, to make a concurrent sleep operation:+--+-- > sleep :: Int -> GenHaxl u Int+-- > sleep n = dataFetch (Sleep n)+-- >+-- > data Sleep+-- > instance ConcurrentIO Sleep where+-- >   data ConcurrentIOReq Sleep a where+-- >     Sleep :: Int -> ConcurrentIOReq Sleep Int+-- >+-- >   performIO (Sleep n) = threadDelay (n*1000) >> return n+-- >+-- > deriving instance Eq (ConcurrentIOReq Sleep a)+-- > deriving instance Show (ConcurrentIOReq Sleep a)+-- >+-- > instance ShowP (ConcurrentIOReq Sleep) where showp = show+-- >+-- > instance Hashable (ConcurrentIOReq Sleep a) where+-- >   hashWithSalt s (Sleep n) = hashWithSalt s n+--+-- Note that you can have any number of constructors in your+-- ConcurrentIOReq GADT, so most of the boilerplate only needs to be+-- written once.++module Haxl.DataSource.ConcurrentIO+  ( mkConcurrentIOState+  , ConcurrentIO(..)+  ) where++import Control.Concurrent+import Control.Exception as Exception+import Control.Monad+import qualified Data.Text as Text+import Data.Typeable++import Haxl.Core++class ConcurrentIO tag where+  data ConcurrentIOReq tag a+  performIO :: ConcurrentIOReq tag a -> IO a++deriving instance Typeable ConcurrentIOReq -- not needed by GHC 7.10 and later++instance (Typeable tag) => StateKey (ConcurrentIOReq tag) where+  data State (ConcurrentIOReq tag) = ConcurrentIOState+  getStateType _ = typeRep (Proxy :: Proxy ConcurrentIOReq)++mkConcurrentIOState :: IO (State (ConcurrentIOReq ()))+mkConcurrentIOState = return ConcurrentIOState++instance Typeable tag => DataSourceName (ConcurrentIOReq tag) where+  dataSourceName _ =+    Text.pack (show (typeRepTyCon (typeRep (Proxy :: Proxy tag))))++instance+  (Typeable tag, ShowP (ConcurrentIOReq tag), ConcurrentIO tag)+  => DataSource u (ConcurrentIOReq tag)+ where+  fetch _state _flags _u = BackgroundFetch $ \bfs -> do+    forM_ bfs $ \(BlockedFetch req rv) ->+      mask $ \unmask ->+        forkFinally (unmask (performIO req)) (putResultFromChildThread rv)

@@ -2,8 +2,7 @@ -- 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.+-- found in the LICENSE file.  {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-}@@ -66,10 +65,12 @@    ) where -import Haxl.Core.Types+import Haxl.Core.DataSource import Haxl.Core.Exception import Haxl.Core.Memo import Haxl.Core.Monad+import Haxl.Core.Fetch+import Haxl.Core.Parallel  import Control.Applicative import Control.Monad (foldM, join, void)

@@ -1,33 +0,0 @@-Additional Grant of Patent Rights Version 2--"Software" means the Haxl software distributed by Facebook, Inc.--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,-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.

@@ -1,3 +1,26 @@+# Changes in version 2.0.0.0++  * Completely rewritten internals to support arbitrarily overlapping+    I/O and computation.  Haxl no longer runs batches of I/O in+    "rounds", waiting for all the I/O to complete before resuming the+    computation. In Haxl 2, we can spawn I/O that returns results in+    the background and computation fragments are resumed when the+    values they depend on are available.  See+    `tests/FullyAsyncTest.hs` for an example.++  * A new `PerformFetch` constructor supports the new concurrency+    features: `BackgroundFetch`. The data source is expected to call+    `putResult` in the background on each `BlockedFetch` when its+    result is ready.++  * There is a generic `DataSource` implementation in+    `Haxl.DataSource.ConcurrentIO` for performing each I/O operation+    in a separate thread.++  * Lots of cleanup and refactoring of the APIs.++  * License changed from BSD+PATENTS to plain BSD3.+ # Changes in version 0.5.1.0    * 'pAnd' and 'pOr' were added

@@ -1,11 +1,11 @@ name:                haxl-version:             0.5.1.0+version:             2.0.0.0 synopsis:            A Haskell library for efficient, concurrent,                      and concise data access. homepage:            https://github.com/facebook/Haxl bug-reports:         https://github.com/facebook/Haxl/issues-license:             OtherLicense-license-files:       LICENSE,PATENTS+license:             BSD3+license-files:       LICENSE author:              Facebook, Inc. maintainer:          The Haxl Team <haxl-team@fb.com> copyright:           Copyright (c) 2014-present, Facebook, Inc.@@ -17,7 +17,8 @@   GHC==7.8.4,   GHC==7.10.3,   GHC==8.0.2,-  GHC==8.2.1+  GHC==8.2.2,+  GHC==8.4.1  description:   Haxl is a library and EDSL for efficient scheduling of concurrent data@@ -36,21 +37,19 @@  extra-source-files:   readme.md-  PATENTS   tests/LoadCache.txt   changelog.md  library    build-depends:-    HUnit >= 1.2 && < 1.7,-    aeson >= 0.6 && < 1.3,+    aeson >= 0.6 && < 1.4,     base == 4.*,     binary >= 0.7 && < 0.10,     bytestring >= 0.9 && < 0.11,     containers == 0.5.*,     deepseq,-    exceptions >=0.8 && <0.9,+    exceptions >=0.8 && <0.11,     filepath >= 1.3 && < 1.5,     ghc-prim,     hashable == 1.2.*,@@ -58,21 +57,33 @@     -- text 1.2.1.0 required for instance Binary Text     text >= 1.2.1.0 && < 1.3,     time >= 1.4 && < 1.9,+    stm == 2.4.*,     transformers,     unordered-containers == 0.2.*,     vector >= 0.10 && <0.13 +  if !impl(ghc >= 8.0)+    build-depends:+      semigroups >= 0.18.3 && <0.19+   exposed-modules:     Haxl.Core,     Haxl.Core.DataCache,+    Haxl.Core.DataSource,     Haxl.Core.Exception,+    Haxl.Core.Flags,     Haxl.Core.Memo,     Haxl.Core.Monad,+    Haxl.Core.Fetch,+    Haxl.Core.Parallel,+    Haxl.Core.Profile,+    Haxl.Core.Run,     Haxl.Core.RequestStore,-    Haxl.Core.StateStore,     Haxl.Core.ShowP,-    Haxl.Core.Types,+    Haxl.Core.StateStore,+    Haxl.Core.Stats,     Haxl.Prelude+    Haxl.DataSource.ConcurrentIO    other-modules:     Haxl.Core.Util@@ -80,14 +91,19 @@   default-language: Haskell2010    ghc-options:+    -O2 -fprof-auto     -Wall +  if impl(ghc >= 8.0)+     ghc-options: -Wno-name-shadowing+  else+     ghc-options: -fno-warn-name-shadowing  test-suite test    build-depends:-    HUnit,-    aeson,+    aeson >= 0.6 && < 1.3,+    HUnit >= 1.2 && < 1.7,     base == 4.*,     binary,     bytestring,@@ -113,30 +129,40 @@   main-is:     TestMain.hs +  if impl(ghc >= 8.0)+    other-modules:+      AdoTests+   other-modules:-    AdoTests     AllTests     BadDataSource     BatchTests-    Bench     CoreTests     DataCacheTest     ExampleDataSource+    FullyAsyncTest     LoadCache     MemoizationTests     MockTAO     ProfileTests+    SleepDataSource     TestBadDataSource     TestExampleDataSource     TestTypes     TestUtils+    WorkDataSource    type:     exitcode-stdio-1.0    default-language: Haskell2010 +flag bench+  default: False+ executable monadbench+  if !flag(bench)+    buildable: False   default-language:     Haskell2010   hs-source-dirs:@@ -152,3 +178,20 @@     ExampleDataSource   ghc-options:     -O2 -main-is MonadBench -rtsopts++executable cachebench+  if !flag(bench)+    buildable: False+  default-language:+    Haskell2010+  hs-source-dirs:+    tests+  build-depends:+    base,+    haxl,+    hashable,+    time+  main-is:+    Bench.hs+  ghc-options:+    -O2 -main-is Bench -rtsopts

@@ -22,6 +22,11 @@ To use Haxl in your own application, you will likely need to build one or more *data sources*: the thin layer between Haxl and the data that you want to fetch, be it a database, a web API, a cloud service, or whatever.++There is a generic datasource in "Haxl.DataSource.ConcurrentIO" that+can be used for performing arbitrary IO operations concurrently, given+a bit of boilerplate to define the IO operations you want to perform.+ The `haxl-facebook` package shows how we might build a Haxl data source based on the existing `fb` package for talking to the Facebook Graph API.@@ -35,6 +40,10 @@  * [An example Facebook data source](example/facebook/readme.md) walks    through building an example data source that queries the Facebook    Graph API concurrently.++ * [Fun with Haxl (part 1)](https://simonmar.github.io/posts/2015-10-20-Fun-With-Haxl-1.html)+   Walks through using Haxl from scratch for a simple SQLite-backed+   blog engine.   * [The N+1 Selects Problem](example/sql/readme.md) explains how Haxl    can address a common performance problem with SQL queries by

@@ -1,3 +1,9 @@+-- Copyright (c) 2014-present, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file.+ {-# LANGUAGE RebindableSyntax, OverloadedStrings, ApplicativeDo #-} module AdoTests (tests) where @@ -42,8 +48,8 @@   b' <- friendsOf  =<< if null b then id4 else id3   return (length (a' ++ b')) -tests = TestList-  [ TestLabel "ado1" $ TestCase ado1-  , TestLabel "ado2" $ TestCase ado2-  , TestLabel "ado3" $ TestCase ado3+tests future = TestList+  [ TestLabel "ado1" $ TestCase (ado1 future)+  , TestLabel "ado2" $ TestCase (ado2 future)+  , TestLabel "ado3" $ TestCase (ado3 future)   ]

@@ -1,3 +1,9 @@+-- Copyright (c) 2014-present, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file.+ {-# LANGUAGE CPP, OverloadedStrings #-} module AllTests (allTests) where @@ -13,21 +19,24 @@ #endif import MemoizationTests import TestBadDataSource+import FullyAsyncTest  import Test.HUnit  allTests :: Test allTests = TestList   [ TestLabel "ExampleDataSource" TestExampleDataSource.tests-  , TestLabel "BatchTests" BatchTests.tests+  , TestLabel "BatchTests-future" $ BatchTests.tests True+  , TestLabel "BatchTests-sync" $ BatchTests.tests False   , TestLabel "CoreTests" CoreTests.tests   , TestLabel "DataCacheTests" DataCacheTest.tests #if __GLASGOW_HASKELL__ >= 801-  , TestLabel "AdoTests" AdoTests.tests+  , TestLabel "AdoTests" $ AdoTests.tests False #endif #if __GLASGOW_HASKELL__ >= 710   , TestLabel "ProfileTests" ProfileTests.tests #endif   , TestLabel "MemoizationTests" MemoizationTests.tests   , TestLabel "BadDataSourceTests" TestBadDataSource.tests+  , TestLabel "FullyAsyncTest" FullyAsyncTest.tests   ]

@@ -1,3 +1,9 @@+-- Copyright (c) 2014-present, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file.+ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-}

@@ -1,3 +1,9 @@+-- Copyright (c) 2014-present, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file.+ {-# LANGUAGE RebindableSyntax, OverloadedStrings #-} module BatchTests (tests) where @@ -127,20 +133,20 @@ -- -- Basic sanity check on data-cache re-use ---cacheReuse = do-  env <- makeTestEnv+cacheReuse future = do+  env <- makeTestEnv future   expectRoundsWithEnv 2 12 batching7_ env    -- make a new env-  tao <- MockTAO.initGlobalState+  tao <- MockTAO.initGlobalState future   let st = stateSet tao stateEmpty   env2 <- initEnvWithData st testinput (caches env)    -- ensure no more data fetching rounds needed   expectRoundsWithEnv 0 12 batching7_ env2 -noCaching = do-  env <- makeTestEnv+noCaching future = do+  env <- makeTestEnv future   let env' = env{ flags = (flags env){caching = 0} }   result <- runHaxl env' caching3_   assertEqual "result" result 18@@ -155,8 +161,8 @@   (withDefault [] (friendsOf 101))   (withDefault [] (friendsOf 2)) -deterministicExceptions = do-  env <- makeTestEnv+deterministicExceptions future = do+  env <- makeTestEnv future   let haxl =         sequence [ do _ <- friendsOf =<< id1; throw (NotFound "xxx")                  , throw (NotFound "yyy")@@ -176,8 +182,8 @@      Left (NotFound "xxx") -> True      _ -> False -pOrTests = do-  env <- makeTestEnv+pOrTests future = do+  env <- makeTestEnv future    -- Test semantics   r <- runHaxl env $ do@@ -188,7 +194,7 @@         return (not a && b && c && d)   assertBool "pOr0" r -  -- pOr is left-biased with respsect to exceptions:+  -- pOr is left-biased with respect to exceptions:   r <- runHaxl env $ try $ return True `pOr` throw (NotFound "foo")   assertBool "pOr1" $     case (r :: Either NotFound Bool) of@@ -224,8 +230,8 @@       Left (NotFound _) -> True       _ -> False -pAndTests = do-  env <- makeTestEnv+pAndTests future = do+  env <- makeTestEnv future    -- Test semantics   r <- runHaxl env $ do@@ -236,7 +242,7 @@         return (not a && not b && not c && d)   assertBool "pAnd0" r -  -- pAnd is left-biased with respsect to exceptions:+  -- pAnd is left-biased with respect to exceptions:   r <- runHaxl env $ try $ return False `pAnd` throw (NotFound "foo")   assertBool "pAnd1" $     case (r :: Either NotFound Bool) of@@ -273,24 +279,26 @@       Left (NotFound _) -> 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 "NoCaching" $ TestCase noCaching-  , TestLabel "exceptionTest1" $ TestCase exceptionTest1-  , TestLabel "exceptionTest2" $ TestCase exceptionTest2-  , TestLabel "deterministicExceptions" $ TestCase deterministicExceptions-  , TestLabel "pOrTest" $ TestCase pOrTests-  , TestLabel "pAndTest" $ TestCase pAndTests+tests :: Bool -> Test+tests future = TestList+  [ TestLabel "batching1" $ TestCase (batching1 future)+  , TestLabel "batching2" $ TestCase (batching2 future)+  , TestLabel "batching3" $ TestCase (batching3 future)+  , TestLabel "batching4" $ TestCase (batching4 future)+  , TestLabel "batching5" $ TestCase (batching5 future)+  , TestLabel "batching6" $ TestCase (batching6 future)+  , TestLabel "batching7" $ TestCase (batching7 future)+  , TestLabel "batching8" $ TestCase (batching8 future)+  , TestLabel "batching9" $ TestCase (batching9 future)+  , TestLabel "caching1" $ TestCase (caching1 future)+  , TestLabel "caching2" $ TestCase (caching2 future)+  , TestLabel "caching3" $ TestCase (caching3 future)+  , TestLabel "CacheReuse" $ TestCase (cacheReuse future)+  , TestLabel "NoCaching" $ TestCase (noCaching future)+  , TestLabel "exceptionTest1" $ TestCase (exceptionTest1 future)+  , TestLabel "exceptionTest2" $ TestCase (exceptionTest2 future)+  , TestLabel "deterministicExceptions" $+      TestCase (deterministicExceptions future)+  , TestLabel "pOrTest" $ TestCase (pOrTests future)+  , TestLabel "pAndTest" $ TestCase (pAndTests future)   ]

@@ -1,3 +1,9 @@+-- Copyright (c) 2014-present, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file.+ {-# LANGUAGE RankNTypes, GADTs, BangPatterns, DeriveDataTypeable,     StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-unused-do-bind -fno-warn-type-defaults #-}@@ -5,11 +11,11 @@ module Bench where  import Haxl.Core.DataCache as DataCache-import Haxl.Core.Types  import Prelude hiding (mapM)  import Data.Hashable+import Data.IORef import Data.Time.Clock import Data.Traversable import Data.Typeable@@ -36,12 +42,12 @@   let      f 0  !cache = return cache      f !n !cache = do-       m <- newResult 0+       m <- newIORef 0        f (n-1) (DataCache.insert (ReqInt n) m cache)   --   cache <- f n emptyDataCache   let m = DataCache.lookup (ReqInt (n `div` 2)) cache-  print =<< mapM takeResult m+  print =<< mapM readIORef m   t1 <- getCurrentTime   printf "insert: %.2fs\n" (realToFrac (t1 `diffUTCTime` t0) :: Double) 

@@ -1,6 +1,13 @@+-- Copyright (c) 2014-present, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file.+ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RebindableSyntax #-}+ module CoreTests where  import Haxl.Prelude@@ -12,17 +19,29 @@  import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as BS+import Data.List  import Control.Exception (Exception(..)) +import ExampleDataSource++testEnv = do+  -- To use a data source, we need to initialize its state:+  exstate <- ExampleDataSource.initGlobalState++  -- And create a StateStore object containing the states we need:+  let st = stateSet exstate stateEmpty++  -- Create the Env:+  initEnv st ()+ useless :: String -> GenHaxl u Bool useless _ = throw (NotFound "ha ha") -en = error "no env"- exceptions :: Assertion exceptions =   do+    en <- emptyEnv ()     a <- runHaxl en $ try (useless "input")     assertBool "NotFound -> HaxlException" $       isLeft (a :: Either HaxlException Bool)@@ -72,6 +91,38 @@               return True)             `catch` \InternalError{} -> return False     assertBool "catchIf2" (not e)++    -- test tryToHaxlException+    e <- runHaxl en $ tryToHaxlException $ head []+    assertBool "tryToHaxlException1" $+      case e of+        Left ex | Just NonHaxlException{} <- fromException (toException ex)+          -> True+        _ -> False++    env <- testEnv+    e <- runHaxl env $ tryToHaxlException $ do+      xs <- listWombats 3+      return $! length xs `quot` 0+    print e+    assertBool "tryToHaxlException1" $+      case e of+        Left ex | Just NonHaxlException{} <- fromException (toException ex)+          -> True+        _ -> False++    env <- testEnv+    e <- runHaxl env $ mapM tryToHaxlException+      [ do xs <- listWombats 3; return $! length xs `quot` 0+      , head []+      ]+    print e+    assertBool "tryToHaxlException2" $+      case e of+        [Left ex1, Left ex2]+           | "divide" `isInfixOf` show ex1+           , "head" `isInfixOf` show ex2 -> True+        _ -> False   where   isLeft Left{} = True   isLeft _ = False@@ -80,7 +131,9 @@ -- This is mostly a compile test, to make sure all the plumbing -- makes the compiler happy. base :: (Exception a) => a -> IO HaxlException-base e = runHaxl en $ throw e `catch` \x -> return x+base e = do+  en <- emptyEnv ()+  runHaxl en $ throw e `catch` \x -> return x  printing :: Assertion printing = do@@ -98,7 +151,35 @@   BS.putStrLn $ encode c  +withEnvTest :: Test+withEnvTest = TestLabel "withEnvTest" $ TestCase $ do+  exstate <- ExampleDataSource.initGlobalState+  e <- initEnv (stateSet exstate stateEmpty) False+  b <- runHaxl e $ withEnv e { userEnv = True } $ env userEnv+  assertBool "withEnv1" b+  e <- initEnv (stateSet exstate stateEmpty) False+  b <- runHaxl e $ withEnv e { userEnv = True } $ do+    _ <- countAardvarks "aaa"+    env userEnv+  assertBool "withEnv2" b+  e <- initEnv (stateSet exstate stateEmpty) False+  b <- runHaxl e $ withEnv e { userEnv = True } $ do+    memo ("xxx" :: Text) $ do+      _ <- countAardvarks "aaa"+      env userEnv+  assertBool "withEnv3" b+  e <- initEnv (stateSet exstate stateEmpty) False+  b <- runHaxl e $+    withEnv e { userEnv = True } $ do+      memo ("yyy" :: Text) $ do+        _ <- countAardvarks "aaa"+        _ <- countAardvarks "bbb"+        env userEnv+  assertBool "withEnv4" b++ tests = TestList   [ TestLabel "exceptions" $ TestCase exceptions,-    TestLabel "print_stuff" $ TestCase printing+    TestLabel "print_stuff" $ TestCase printing,+    TestLabel "withEnv" $ withEnvTest   ]

@@ -1,15 +1,26 @@-{-# LANGUAGE StandaloneDeriving, GADTs, DeriveDataTypeable #-}-module DataCacheTest (tests) where+-- Copyright (c) 2014-present, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file. +{-# LANGUAGE CPP, StandaloneDeriving, GADTs, DeriveDataTypeable #-}+module DataCacheTest (tests, newResult, takeResult) where+ import Haxl.Core.DataCache as DataCache+import Haxl.Core.Monad import Haxl.Core +#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+#endif import Control.Exception import Data.Hashable import Data.Traversable import Data.Typeable import Prelude hiding (mapM) import Test.HUnit+import Data.IORef  data TestReq a where    Req :: Int -> TestReq a -- polymorphic result@@ -21,7 +32,17 @@ instance Hashable (TestReq a) where   hashWithSalt salt (Req i) = hashWithSalt salt i +newResult :: a -> IO (IVar u a)+newResult a = IVar <$> newIORef (IVarFull (Ok a)) +takeResult :: IVar u a -> IO (ResultVal a)+takeResult (IVar ref) = do+  e <- readIORef ref+  case e of+    IVarFull a -> return a+    _ -> error "takeResult"++ dcSoundnessTest :: Test dcSoundnessTest = TestLabel "DataCache soundness" $ TestCase $ do   m1 <- newResult 1@@ -35,25 +56,25 @@   -- with a result of type String, we should get Nothing, not a crash.   r <- mapM takeResult $ DataCache.lookup (Req 1) cache   assertBool "dcSoundness1" $-    case r :: Maybe (Either SomeException String) of+    case r :: Maybe (ResultVal String) of      Nothing -> True      _something_else -> False    r <- mapM takeResult $ DataCache.lookup (Req 1) cache   assertBool "dcSoundness2" $-    case r :: Maybe (Either SomeException Int) of-     Just (Right 1) -> True+    case r :: Maybe (ResultVal Int) of+     Just (Ok 1) -> True      _something_else -> False    r <- mapM takeResult $ DataCache.lookup (Req 2) cache   assertBool "dcSoundness3" $-    case r :: Maybe (Either SomeException String) of-      Just (Right "hello") -> True+    case r :: Maybe (ResultVal String) of+      Just (Ok "hello") -> True       _something_else -> False    r <- mapM takeResult $ DataCache.lookup (Req 2) cache   assertBool "dcSoundness4" $-    case r :: Maybe (Either SomeException Int) of+    case r :: Maybe (ResultVal Int) of       Nothing -> True       _something_else -> False 

@@ -1,3 +1,9 @@+-- Copyright (c) 2014-present, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file.+ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -117,10 +123,9 @@ exampleFetch :: State ExampleReq             -- current state              -> Flags                        -- tracing verbosity, etc.              -> u                            -- user environment-             -> [BlockedFetch ExampleReq]    -- requests to fetch-             -> PerformFetch                 -- tells the framework how to fetch+             -> PerformFetch ExampleReq      -- tells the framework how to fetch -exampleFetch _state _flags _user bfs = SyncFetch $ mapM_ fetch1 bfs+exampleFetch _state _flags _user = SyncFetch $ mapM_ fetch1    -- There are two ways a data source can fetch data: synchronously or   -- asynchronously.  See the type 'PerformFetch' in "Haxl.Core.Types" for@@ -150,8 +155,8 @@ -- Normally a data source will provide some convenient wrappers for -- its requests: -countAardvarks :: String -> GenHaxl () Int+countAardvarks :: String -> GenHaxl u Int countAardvarks str = dataFetch (CountAardvarks str) -listWombats :: Id -> GenHaxl () [Id]+listWombats :: Id -> GenHaxl u [Id] listWombats i = dataFetch (ListWombats i)

@@ -0,0 +1,66 @@+-- 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.++module FullyAsyncTest where++import Haxl.Prelude as Haxl+import Prelude()++import SleepDataSource+import Haxl.DataSource.ConcurrentIO++import Haxl.Core+import Test.HUnit+import Data.IORef+import Haxl.Core.Monad (unsafeLiftIO)++tests :: Test+tests = sleepTest++testEnv = do+  st <- mkConcurrentIOState+  env <- initEnv (stateSet st stateEmpty) ()+  return env { flags = (flags env) { report = 2 } }++sleepTest :: Test+sleepTest = TestCase $ do+  env <- testEnv++  ref <- newIORef ([] :: [Int])+  let tick n = unsafeLiftIO (modifyIORef ref (n:))++  -- simulate running a selection of data fetches that complete at+  -- different times, overlapping them as much as possible.+  runHaxl env $+    sequence_+       [ sequence_ [sleep 100, sleep 400] `andThen` tick 5     -- A+       , sleep 100 `andThen` tick 2 `andThen` sleep 200 `andThen` tick 4    -- B+       , sleep 50 `andThen` tick 1 `andThen` sleep 150 `andThen` tick 3     -- C+       ]++  ys <- readIORef ref+  assertEqual "FullyAsyncTest: ordering" [1,2,3,4,5] (reverse ys)++  stats <- readIORef (statsRef env)+  print stats+  assertEqual "FullyAsyncTest: stats" 5 (numFetches stats)++andThen :: GenHaxl u a -> GenHaxl u b -> GenHaxl u b+andThen a b = a >>= \_ -> b++{-+           A         B         C+50          |        |       tick 1+100         |     tick 2       |+150         |        |         |+200         |        |       tick 3+250         |        |+300         |     tick 4+350         |+400         |+450         |+500      tick 5+-}

@@ -1,3 +1,9 @@+-- Copyright (c) 2014-present, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file.+ {-# LANGUAGE CPP, OverloadedStrings #-} module LoadCache where 

@@ -1,3 +1,9 @@+-- Copyright (c) 2014-present, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file.+ {-# LANGUAGE CPP #-} module MemoizationTests (tests) where @@ -9,7 +15,7 @@ import Test.HUnit  import Haxl.Core-import Haxl.Core.Monad+import Haxl.Core.Monad (unsafeLiftIO)  import ExampleDataSource 

@@ -1,3 +1,9 @@+-- Copyright (c) 2014-present, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file.+ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -6,6 +12,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-}  module MockTAO (     Id(..),@@ -43,16 +50,18 @@   hashWithSalt s (AssocRangeId2s a b) = hashWithSalt s (a,b)  instance StateKey TAOReq where-  data State TAOReq = TAOState {}+  data State TAOReq = TAOState { future :: Bool }  instance DataSourceName TAOReq where   dataSourceName _ = "MockTAO"  instance DataSource UserEnv TAOReq where-  fetch _state _flags _user bfs = SyncFetch $ mapM_ doFetch bfs+  fetch TAOState{..} _flags _user+    | future = FutureFetch $ return . mapM_ doFetch+    | otherwise = SyncFetch $ mapM_ doFetch -initGlobalState :: IO (State TAOReq)-initGlobalState = return TAOState {}+initGlobalState :: Bool -> IO (State TAOReq)+initGlobalState future = return TAOState { future=future }  doFetch :: BlockedFetch TAOReq -> IO () doFetch (BlockedFetch req@(AssocRangeId2s a b) r) =

@@ -2,16 +2,10 @@ -- 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.+-- found in the LICENSE file.  -- | Benchmarking tool for core performance characteristics of the Haxl monad. {-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL >= 800-{-# OPTIONS_GHC -Wno-name-shadowing #-}-#else-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}-#endif module MonadBench (main) where  import Control.Monad@@ -25,7 +19,7 @@ import Haxl.Prelude as Haxl import Prelude() -import Haxl.Core.Monad (newMemoWith, runMemo)+import Haxl.Core.Memo (newMemoWith, runMemo)  import Haxl.Core @@ -118,7 +112,8 @@         ]       exitWith (ExitFailure 1)   t1 <- getCurrentTime-  printf "%d reqs: %.2fs\n" n (realToFrac (t1 `diffUTCTime` t0) :: Double)+  printf "%10s: %10d reqs: %.2fs\n"+    test 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

@@ -1,25 +1,35 @@+-- Copyright (c) 2014-present, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file.+ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-}+ module ProfileTests where  import Haxl.Prelude-import Data.List  import Haxl.Core import Haxl.Core.Monad+import Haxl.Core.Stats+import Haxl.DataSource.ConcurrentIO  import Test.HUnit  import Control.DeepSeq (force) import Control.Exception (evaluate)+import Data.Aeson import Data.IORef import qualified Data.HashMap.Strict as HashMap import qualified Data.HashSet as HashSet  import TestUtils+import WorkDataSource  mkProfilingEnv = do-  env <- makeTestEnv+  env <- makeTestEnv False   return env { flags = (flags env) { report = 4 } }  collectsdata :: Assertion@@ -29,17 +39,20 @@           withLabel "bar" $             withLabel "foo" $ do               u <- env userEnv-              if length (intersect (HashMap.keys u) ["c"]) > 1-              then return 5-              else return (4::Int)+              -- do some non-trivial work that can't be lifted out+              case fromJSON <$> HashMap.lookup "A" u of+                Just (Success n) | sum [n .. 1000::Integer] > 0 -> return 5+                _otherwise -> return (4::Int)   profData <- profile <$> readIORef (profRef e)   assertEqual "has data" 3 $ HashMap.size profData   assertBool "foo allocates" $     case profileAllocs <$> HashMap.lookup "foo" profData of-      Just x -> x > 0+      Just x -> x > 10000       Nothing -> False-  assertEqual "bar does not allocate" (Just 0) $-    profileAllocs <$> HashMap.lookup "bar" profData+  assertBool "bar does not allocate (much)" $+    case profileAllocs <$> HashMap.lookup "bar" profData of+      Just n -> n < 5000  -- getAllocationCounter can be off by +/- 4K+      _otherwise -> False   assertEqual "foo's parent" (Just ["bar"]) $     HashSet.toList . profileDeps <$> HashMap.lookup "foo" profData @@ -63,7 +76,24 @@   assertBool "inner label added" $     HashMap.member "inner" profData ++-- Test that we correctly attribute work done in child threads when+-- using BackgroundFetch to the caller of runHaxl. This is important+-- for correct accounting when relying on allocation limits.+threadAlloc :: Assertion+threadAlloc = do+  st <- mkConcurrentIOState+  env <- initEnv (stateSet st stateEmpty) ()+  a0 <- getAllocationCounter+  _x <- runHaxl env $ work 100000+  a1 <- getAllocationCounter+  assertBool "threadAlloc" $ (a0 - a1) > 1000000+    -- the result was 16MB on 64-bit, or around 25KB if we miss the allocs+    -- in the child thread.++ tests = TestList   [ TestLabel "collectsdata" $ TestCase collectsdata   , TestLabel "exceptions" $ TestCase exceptions+  , TestLabel "threads" $ TestCase threadAlloc   ]

@@ -0,0 +1,46 @@+-- Copyright (c) 2014-present, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file.++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}++module SleepDataSource (+    sleep,+  ) where++import Haxl.Prelude+import Prelude ()++import Haxl.Core+import Haxl.DataSource.ConcurrentIO++import Control.Concurrent+import Data.Hashable+import Data.Typeable++sleep :: Int -> GenHaxl u Int+sleep n = dataFetch (Sleep n)++data Sleep deriving Typeable+instance ConcurrentIO Sleep where+  data ConcurrentIOReq Sleep a where+    Sleep :: Int -> ConcurrentIOReq Sleep Int++  performIO (Sleep n) = threadDelay (n*1000) >> return n++deriving instance Eq (ConcurrentIOReq Sleep a)+deriving instance Show (ConcurrentIOReq Sleep a)++instance ShowP (ConcurrentIOReq Sleep) where showp = show++instance Hashable (ConcurrentIOReq Sleep a) where+  hashWithSalt s (Sleep n) = hashWithSalt s n

@@ -1,3 +1,9 @@+-- Copyright (c) 2014-present, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file.+ {-# LANGUAGE OverloadedStrings #-} module TestBadDataSource (tests) where 

@@ -1,4 +1,11 @@+-- Copyright (c) 2014-present, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file.+ {-# LANGUAGE CPP, OverloadedStrings, RebindableSyntax, MultiWayIf #-}+{-# LANGUAGE RecordWildCards #-} module TestExampleDataSource (tests) where  import Haxl.Prelude as Haxl@@ -7,7 +14,6 @@ import Haxl.Core.Monad (unsafeLiftIO) import Haxl.Core -import qualified Data.HashMap.Strict as HashMap import Test.HUnit import Data.IORef import Data.Maybe@@ -26,7 +32,8 @@   let st = stateSet exstate stateEmpty    -- Create the Env:-  initEnv st ()+  env <- initEnv st ()+  return env{ flags = (flags env){ report = 2 } }   tests = TestList [@@ -34,9 +41,12 @@   TestLabel "orderTest" orderTest,   TestLabel "preCacheTest" preCacheTest,   TestLabel "cachedComputationTest" cachedComputationTest,+  TestLabel "cacheResultTest" cacheResultTest,   TestLabel "memoTest" memoTest,   TestLabel "dataSourceExceptionTest" dataSourceExceptionTest,-  TestLabel "dumpCacheAsHaskell" dumpCacheTest]+  TestLabel "dumpCacheAsHaskell" dumpCacheTest,+  TestLabel "fetchError" fetchError+  ]  -- Let's test ExampleDataSource. @@ -52,14 +62,15 @@    -- Should be just one fetching round:   Stats stats <- readIORef (statsRef env)+  putStrLn (ppStats (Stats stats))   assertEqual "rounds" 1 (length stats)    -- With two fetches:   assertBool "reqs" $-      if | RoundStats { roundDataSources = m } : _  <- stats,-           Just (DataSourceRoundStats { dataSourceFetches = 2 })-              <- HashMap.lookup "ExampleDataSource" m  -> True-         | otherwise -> False+    case stats of+       [FetchStats{..}] ->+         fetchDataSource == "ExampleDataSource" && fetchBatchSize == 2+       _otherwise -> False  -- Test side-effect ordering @@ -97,8 +108,8 @@    x <- runHaxl env $ do     cacheRequest (CountAardvarks "xxx") (Right 3)-    cacheRequest (ListWombats 100) (Right [1,2,3])-    countAardvarks "xxx" + (length <$> listWombats 100)+    cacheRequest (ListWombats 1000000) (Right [1,2,3])+    countAardvarks "xxx" + (length <$> listWombats 1000000)   assertEqual "preCacheTest1" x (3 + 3)    y <- Control.Exception.try $ runHaxl env $ do@@ -126,6 +137,16 @@   stats <- readIORef (statsRef env)   assertEqual "fetches" 3 (numFetches stats) +cacheResultTest = TestCase $ do+  env <- testEnv+  ref <- newIORef 0+  let request = cacheResult (CountAardvarks "ababa") $ do+         modifyIORef ref (+1)+         readIORef ref+  r <- runHaxl env $ (+) <$> request <*> request+  assertEqual "cacheResult" 2 r++ -- Pretend CountAardvarks is a request computed by some Haxl code memoTest = TestCase $ do   env <- testEnv@@ -142,6 +163,18 @@    stats <- readIORef (statsRef env)   assertEqual "fetches" 3 (numFetches stats)++-- Test that the FetchError gets returned properly, and that we have+-- a failure logged in the stats.+fetchError = TestCase $ do+  env <- testEnv+  r <- runHaxl env $ Haxl.try $+    (++) <$> listWombats 1000000 <*> listWombats 1000001+  assertBool "fetchError1" $ case r of+    Left FetchError{} -> True+    Right _ -> False+  Stats stats <- readIORef (statsRef env)+  assertEqual "fetchError2" 2 (sum [ fetchFailures | FetchStats{..} <- stats ])  dataSourceExceptionTest = TestCase $ do   env <- testEnv

@@ -1,3 +1,9 @@+-- Copyright (c) 2014-present, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file.+ {-# LANGUAGE CPP, OverloadedStrings #-} module Main where 

@@ -1,3 +1,9 @@+-- Copyright (c) 2014-present, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file.+ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveDataTypeable #-}

@@ -1,3 +1,9 @@+-- Copyright (c) 2014-present, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file.+ {-# LANGUAGE OverloadedStrings #-} module TestUtils   ( makeTestEnv@@ -40,11 +46,12 @@ id4 :: Haxl Id id4 = lookupInput "D" -makeTestEnv :: IO (Env UserEnv)-makeTestEnv = do-  tao <- MockTAO.initGlobalState+makeTestEnv :: Bool -> IO (Env UserEnv)+makeTestEnv future = do+  tao <- MockTAO.initGlobalState future   let st = stateSet tao stateEmpty-  initEnv st testinput+  env <- initEnv st testinput+  return env { flags = (flags env) { report = 2 } }  expectRoundsWithEnv   :: (Eq a, Show a) => Int -> a -> Haxl a -> Env UserEnv -> Assertion@@ -54,14 +61,14 @@   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+expectRounds :: (Eq a, Show a) => Int -> a -> Haxl a -> Bool -> Assertion+expectRounds n result haxl future = do+  env <- makeTestEnv future   expectRoundsWithEnv n result haxl env -expectFetches :: (Eq a, Show a) => Int -> Haxl a -> Assertion-expectFetches n haxl = do-  env <- makeTestEnv+expectFetches :: (Eq a, Show a) => Int -> Haxl a -> Bool -> Assertion+expectFetches n haxl future = do+  env <- makeTestEnv future   _ <- runHaxl env haxl   stats <- readIORef (statsRef env)   assertEqual "fetches" n (numFetches stats)

@@ -0,0 +1,44 @@+-- Copyright (c) 2014-present, Facebook, Inc.+-- All rights reserved.+--+-- This source code is distributed under the terms of a BSD license,+-- found in the LICENSE file.++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}++module WorkDataSource (+    work,+  ) where++import Haxl.Prelude+import Prelude ()++import Haxl.Core+import Haxl.DataSource.ConcurrentIO++import Control.Exception+import Data.Hashable+import Data.Typeable++work :: Integer -> GenHaxl u Integer+work n = dataFetch (Work n)++data Work deriving Typeable+instance ConcurrentIO Work where+  data ConcurrentIOReq Work a where+    Work :: Integer -> ConcurrentIOReq Work Integer++  performIO (Work n) = evaluate (sum [1..n]) >> return n++deriving instance Eq (ConcurrentIOReq Work a)+deriving instance Show (ConcurrentIOReq Work a)++instance ShowP (ConcurrentIOReq Work) where showp = show++instance Hashable (ConcurrentIOReq Work a) where+  hashWithSalt s (Work n) = hashWithSalt s n