packages feed

haxl-effectful (empty) → 1.0.0

raw patch · 9 files changed

+1498/−0 lines, 9 filesdep +basedep +effectfuldep +filepathsetup-changed

Dependencies added: base, effectful, filepath, hashable, haxl, haxl-effectful, hspec-effectful, text

Files

+ CHANGELOG.md view
@@ -0,0 +1,12 @@+# Changelog++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/),+and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/).++## [1.0.0] - 2026-07-15++### Added++- Initial release.
+ LICENCE view
@@ -0,0 +1,287 @@+                      EUROPEAN UNION PUBLIC LICENCE v. 1.2+                      EUPL © the European Union 2007, 2016++This European Union Public Licence (the ‘EUPL’) applies to the Work (as defined+below) which is provided under the terms of this Licence. Any use of the Work,+other than as authorised under this Licence is prohibited (to the extent such+use is covered by a right of the copyright holder of the Work).++The Work is provided under the terms of this Licence when the Licensor (as+defined below) has placed the following notice immediately following the+copyright notice for the Work:++        Licensed under the EUPL++or has expressed by any other means his willingness to license under the EUPL.++1. Definitions++In this Licence, the following terms have the following meaning:++- ‘The Licence’: this Licence.++- ‘The Original Work’: the work or software distributed or communicated by the+  Licensor under this Licence, available as Source Code and also as Executable+  Code as the case may be.++- ‘Derivative Works’: the works or software that could be created by the+  Licensee, based upon the Original Work or modifications thereof. This Licence+  does not define the extent of modification or dependence on the Original Work+  required in order to classify a work as a Derivative Work; this extent is+  determined by copyright law applicable in the country mentioned in Article 15.++- ‘The Work’: the Original Work or its Derivative Works.++- ‘The Source Code’: the human-readable form of the Work which is the most+  convenient for people to study and modify.++- ‘The Executable Code’: any code which has generally been compiled and which is+  meant to be interpreted by a computer as a program.++- ‘The Licensor’: the natural or legal person that distributes or communicates+  the Work under the Licence.++- ‘Contributor(s)’: any natural or legal person who modifies the Work under the+  Licence, or otherwise contributes to the creation of a Derivative Work.++- ‘The Licensee’ or ‘You’: any natural or legal person who makes any usage of+  the Work under the terms of the Licence.++- ‘Distribution’ or ‘Communication’: any act of selling, giving, lending,+  renting, distributing, communicating, transmitting, or otherwise making+  available, online or offline, copies of the Work or providing access to its+  essential functionalities at the disposal of any other natural or legal+  person.++2. Scope of the rights granted by the Licence++The Licensor hereby grants You a worldwide, royalty-free, non-exclusive,+sublicensable licence to do the following, for the duration of copyright vested+in the Original Work:++- use the Work in any circumstance and for all usage,+- reproduce the Work,+- modify the Work, and make Derivative Works based upon the Work,+- communicate to the public, including the right to make available or display+  the Work or copies thereof to the public and perform publicly, as the case may+  be, the Work,+- distribute the Work or copies thereof,+- lend and rent the Work or copies thereof,+- sublicense rights in the Work or copies thereof.++Those rights can be exercised on any media, supports and formats, whether now+known or later invented, as far as the applicable law permits so.++In the countries where moral rights apply, the Licensor waives his right to+exercise his moral right to the extent allowed by law in order to make effective+the licence of the economic rights here above listed.++The Licensor grants to the Licensee royalty-free, non-exclusive usage rights to+any patents held by the Licensor, to the extent necessary to make use of the+rights granted on the Work under this Licence.++3. Communication of the Source Code++The Licensor may provide the Work either in its Source Code form, or as+Executable Code. If the Work is provided as Executable Code, the Licensor+provides in addition a machine-readable copy of the Source Code of the Work+along with each copy of the Work that the Licensor distributes or indicates, in+a notice following the copyright notice attached to the Work, a repository where+the Source Code is easily and freely accessible for as long as the Licensor+continues to distribute or communicate the Work.++4. Limitations on copyright++Nothing in this Licence is intended to deprive the Licensee of the benefits from+any exception or limitation to the exclusive rights of the rights owners in the+Work, of the exhaustion of those rights or of other applicable limitations+thereto.++5. Obligations of the Licensee++The grant of the rights mentioned above is subject to some restrictions and+obligations imposed on the Licensee. Those obligations are the following:++Attribution right: The Licensee shall keep intact all copyright, patent or+trademarks notices and all notices that refer to the Licence and to the+disclaimer of warranties. The Licensee must include a copy of such notices and a+copy of the Licence with every copy of the Work he/she distributes or+communicates. The Licensee must cause any Derivative Work to carry prominent+notices stating that the Work has been modified and the date of modification.++Copyleft clause: If the Licensee distributes or communicates copies of the+Original Works or Derivative Works, this Distribution or Communication will be+done under the terms of this Licence or of a later version of this Licence+unless the Original Work is expressly distributed only under this version of the+Licence — for example by communicating ‘EUPL v. 1.2 only’. The Licensee+(becoming Licensor) cannot offer or impose any additional terms or conditions on+the Work or Derivative Work that alter or restrict the terms of the Licence.++Compatibility clause: If the Licensee Distributes or Communicates Derivative+Works or copies thereof based upon both the Work and another work licensed under+a Compatible Licence, this Distribution or Communication can be done under the+terms of this Compatible Licence. For the sake of this clause, ‘Compatible+Licence’ refers to the licences listed in the appendix attached to this Licence.+Should the Licensee's obligations under the Compatible Licence conflict with+his/her obligations under this Licence, the obligations of the Compatible+Licence shall prevail.++Provision of Source Code: When distributing or communicating copies of the Work,+the Licensee will provide a machine-readable copy of the Source Code or indicate+a repository where this Source will be easily and freely available for as long+as the Licensee continues to distribute or communicate the Work.++Legal Protection: This Licence does not grant permission to use the trade names,+trademarks, service marks, or names of the Licensor, except as required for+reasonable and customary use in describing the origin of the Work and+reproducing the content of the copyright notice.++6. Chain of Authorship++The original Licensor warrants that the copyright in the Original Work granted+hereunder is owned by him/her or licensed to him/her and that he/she has the+power and authority to grant the Licence.++Each Contributor warrants that the copyright in the modifications he/she brings+to the Work are owned by him/her or licensed to him/her and that he/she has the+power and authority to grant the Licence.++Each time You accept the Licence, the original Licensor and subsequent+Contributors grant You a licence to their contributions to the Work, under the+terms of this Licence.++7. Disclaimer of Warranty++The Work is a work in progress, which is continuously improved by numerous+Contributors. It is not a finished work and may therefore contain defects or+‘bugs’ inherent to this type of development.++For the above reason, the Work is provided under the Licence on an ‘as is’ basis+and without warranties of any kind concerning the Work, including without+limitation merchantability, fitness for a particular purpose, absence of defects+or errors, accuracy, non-infringement of intellectual property rights other than+copyright as stated in Article 6 of this Licence.++This disclaimer of warranty is an essential part of the Licence and a condition+for the grant of any rights to the Work.++8. Disclaimer of Liability++Except in the cases of wilful misconduct or damages directly caused to natural+persons, the Licensor will in no event be liable for any direct or indirect,+material or moral, damages of any kind, arising out of the Licence or of the use+of the Work, including without limitation, damages for loss of goodwill, work+stoppage, computer failure or malfunction, loss of data or any commercial+damage, even if the Licensor has been advised of the possibility of such damage.+However, the Licensor will be liable under statutory product liability laws as+far such laws apply to the Work.++9. Additional agreements++While distributing the Work, You may choose to conclude an additional agreement,+defining obligations or services consistent with this Licence. However, if+accepting obligations, You may act only on your own behalf and on your sole+responsibility, not on behalf of the original Licensor or any other Contributor,+and only if You agree to indemnify, defend, and hold each Contributor harmless+for any liability incurred by, or claims asserted against such Contributor by+the fact You have accepted any warranty or additional liability.++10. Acceptance of the Licence++The provisions of this Licence can be accepted by clicking on an icon ‘I agree’+placed under the bottom of a window displaying the text of this Licence or by+affirming consent in any other similar way, in accordance with the rules of+applicable law. Clicking on that icon indicates your clear and irrevocable+acceptance of this Licence and all of its terms and conditions.++Similarly, you irrevocably accept this Licence and all of its terms and+conditions by exercising any rights granted to You by Article 2 of this Licence,+such as the use of the Work, the creation by You of a Derivative Work or the+Distribution or Communication by You of the Work or copies thereof.++11. Information to the public++In case of any Distribution or Communication of the Work by means of electronic+communication by You (for example, by offering to download the Work from a+remote location) the distribution channel or media (for example, a website) must+at least provide to the public the information requested by the applicable law+regarding the Licensor, the Licence and the way it may be accessible, concluded,+stored and reproduced by the Licensee.++12. Termination of the Licence++The Licence and the rights granted hereunder will terminate automatically upon+any breach by the Licensee of the terms of the Licence.++Such a termination will not terminate the licences of any person who has+received the Work from the Licensee under the Licence, provided such persons+remain in full compliance with the Licence.++13. Miscellaneous++Without prejudice of Article 9 above, the Licence represents the complete+agreement between the Parties as to the Work.++If any provision of the Licence is invalid or unenforceable under applicable+law, this will not affect the validity or enforceability of the Licence as a+whole. Such provision will be construed or reformed so as necessary to make it+valid and enforceable.++The European Commission may publish other linguistic versions or new versions of+this Licence or updated versions of the Appendix, so far this is required and+reasonable, without reducing the scope of the rights granted by the Licence. New+versions of the Licence will be published with a unique version number.++All linguistic versions of this Licence, approved by the European Commission,+have identical value. Parties can take advantage of the linguistic version of+their choice.++14. Jurisdiction++Without prejudice to specific agreement between parties,++- any litigation resulting from the interpretation of this License, arising+  between the European Union institutions, bodies, offices or agencies, as a+  Licensor, and any Licensee, will be subject to the jurisdiction of the Court+  of Justice of the European Union, as laid down in article 272 of the Treaty on+  the Functioning of the European Union,++- any litigation arising between other parties and resulting from the+  interpretation of this License, will be subject to the exclusive jurisdiction+  of the competent court where the Licensor resides or conducts its primary+  business.++15. Applicable Law++Without prejudice to specific agreement between parties,++- this Licence shall be governed by the law of the European Union Member State+  where the Licensor has his seat, resides or has his registered office,++- this licence shall be governed by Belgian law if the Licensor has no seat,+  residence or registered office inside a European Union Member State.++Appendix++‘Compatible Licences’ according to Article 5 EUPL are:++- GNU General Public License (GPL) v. 2, v. 3+- GNU Affero General Public License (AGPL) v. 3+- Open Software License (OSL) v. 2.1, v. 3.0+- Eclipse Public License (EPL) v. 1.0+- CeCILL v. 2.0, v. 2.1+- Mozilla Public Licence (MPL) v. 2+- GNU Lesser General Public Licence (LGPL) v. 2.1, v. 3+- Creative Commons Attribution-ShareAlike v. 3.0 Unported (CC BY-SA 3.0) for+  works other than software+- European Union Public Licence (EUPL) v. 1.1, v. 1.2+- Québec Free and Open-Source Licence — Reciprocity (LiLiQ-R) or Strong+  Reciprocity (LiLiQ-R+).++The European Commission may update this Appendix to later versions of the above+licences without producing a new version of the EUPL, as long as they provide+the rights granted in Article 2 of this Licence and protect the covered Source+Code from exclusive appropriation.++All other changes or additions to this Appendix require the production of a new+EUPL version.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ haxl-effectful.cabal view
@@ -0,0 +1,95 @@+cabal-version: 3.0+name: haxl-effectful+version: 1.0.0+category: Concurrency+synopsis: Effectful bindings for Haxl+description:+  Adaptation of the @<https://hackage.haskell.org/package/haxl Haxl>@ library for the @<https://hackage.haskell.org/package/effectful effectful>@ ecosystem.++license: EUPL-1.2+license-file: LICENCE+author: IDA+maintainer: IDA+homepage: https://digital-autonomy.institute+bug-reports: https://issues.digital-autonomy.institute+build-type: Simple+extra-doc-files:+  CHANGELOG.md++extra-source-files:+  test/LoadCache.txt++common common+  default-language: Haskell2010+  ghc-options:+    -Weverything+    -Wno-unsafe+    -Wno-all-missed-specialisations+    -Wno-missing-export-lists+    -Wno-missing-import-lists+    -Wno-missing-kind-signatures+    -Wno-missing-poly-kind-signatures+    -Wno-missing-role-annotations+    -Wno-missing-safe-haskell-mode+    -Wno-name-shadowing++  default-extensions:+    ApplicativeDo+    BlockArguments+    DataKinds+    DefaultSignatures+    DeriveAnyClass+    DeriveGeneric+    DerivingStrategies+    DerivingVia+    ExplicitNamespaces+    FlexibleContexts+    FlexibleInstances+    GADTs+    ImportQualifiedPost+    LambdaCase+    MultiParamTypeClasses+    NamedFieldPuns+    NoImplicitPrelude+    OverloadedLabels+    OverloadedRecordDot+    OverloadedStrings+    RankNTypes+    RecordWildCards+    RecursiveDo+    ScopedTypeVariables+    TemplateHaskell+    TypeApplications+    TypeFamilies+    TypeOperators+    ViewPatterns++  build-depends:+    base >=4.10 && <5,+    effectful >=2.6 && <2.7,+    hashable >=1.5 && <1.6,++library+  import: common+  hs-source-dirs: src+  build-depends:+    haxl >=2.5 && <2.6++  exposed-modules:+    Effectful.Haxl++test-suite test+  import: common+  type: exitcode-stdio-1.0+  ghc-options: -threaded+  hs-source-dirs: test+  main-is: Main.hs+  other-modules:+    ExampleDataSource+    LoadCache++  build-depends:+    filepath >=1.5 && <1.6,+    haxl-effectful,+    hspec-effectful >=1.0 && <1.1,+    text >=2.1 && <2.2,
+ src/Effectful/Haxl.hs view
@@ -0,0 +1,538 @@+{-# LANGUAGE Trustworthy #-}++-- |+-- Module      : Effectful.Haxl+-- Copyright   : (c) 2026 Institute for Digital Autonomy+-- License     : EUPL-1.2+-- Maintainer  : IDA+--+-- <https://hackage.haskell.org/package/haxl Haxl> is a library for+-- concurrent, batched, and cached data fetching.+--+-- This library provides the 'Haxl' effect can initialise an 'Env', as well+-- as a lifted 'GenHaxl' monad that runs computation with a single @Env@.+--+-- Haxl can parallelise independent requests using the 'Applicative' instance,+-- but not the 'Monad' instance.+-- To benefit from parallelisation in @do@ blocks, enable the @ApplicativeDo@+-- language extension.+--+-- = Example usage+--+-- == Defining a data source+--+-- A data source describes one kind of request and how to fetch it. At+-- minimum this means a request type indexed by its result, and instances of+-- 'DataSourceName' and 'DataSource':+--+-- > data ExampleReq a where+-- >   CountAardvarks :: String -> ExampleReq Int+-- >+-- > deriving stock instance Eq (ExampleReq a)+-- > deriving stock instance Show (ExampleReq a)+-- > instance ShowP ExampleReq where showp = show+-- > instance Hashable (ExampleReq a) where+-- >   hashWithSalt s (CountAardvarks a) = hashWithSalt s a+-- >+-- > instance StateKey ExampleReq where+-- >   data State ExampleReq = ExampleState+-- >+-- > instance DataSourceName ExampleReq where+-- >   dataSourceName _ = "ExampleDataSource"+-- >+-- > instance DataSource u ExampleReq where+-- >   fetch _state _flags _user = SyncFetch $ mapM_ \(BlockedFetch (CountAardvarks str) result) ->+-- >     putSuccess result (length (filter (== 'a') str))+-- >+-- > countAardvarks :: String -> GenHaxl u w es Int+-- > countAardvarks = dataFetch . CountAardvarks+--+-- See the <https://hackage.haskell.org/package/haxl Haxl> package documentation+-- for the full 'DataSource' contract, including asynchronous fetching and batching+-- multiple requests per round.+--+-- == Running a computation+--+-- Build the 'StateStore' from every data source's 'State', then use+-- 'runHaxlWith' to discharge the 'Haxl' effect and 'haxl' to run a 'GenHaxl'+-- computation inside it:+--+-- > import Effectful+-- > import Effectful.Haxl+-- >+-- > main :: IO ()+-- > main = runEff . runHaxlWith initialState () defaultFlags $ do+-- >   n <- inject . haxl @() @() $ countAardvarks "abcabc"+-- >   liftIO $ print n+-- >   where+-- >     initialState = pure $ stateSet ExampleState stateEmpty+--+-- If you only have one data source and no user environment or writes, 'runHaxl'+-- is a shorter alternative to 'runHaxlWith'.+--+-- == Batching independent fetches+--+-- Requests combined applicatively (with @('<*>')@, @('+')@ via the 'Num'+-- instance, 'traverse', etc.) run in parallel in a single round trip:+--+-- > -- One round: both fetches are independent.+-- > total :: GenHaxl u w es Int+-- > total = countAardvarks "abc" + countAardvarks "def"+--+-- Requests sequenced with @('>>=')@ each wait for the previous result and so+-- take a separate round:+--+-- > -- Two rounds: the second fetch depends on the first result.+-- > chained :: GenHaxl u w es Int+-- > chained = countAardvarks "abc" >>= \n -> countAardvarks (replicate n 'a')+--+-- These functions can also be expressed with @ApplicativeDo@:+--+-- > -- One round with ApplicativeDo, two rounds otherwise+-- > total :: GenHaxl u w es Int+-- > total = do+-- >     a <- countAardvarks "abc"+-- >     b <- countAardvarks "def"+-- >     pure (a + b)+-- >+-- > -- Two rounds even with ApplicativeDo+-- > chained :: GenHaxl u w es Int+-- > chained = do+-- >     n <- countAardvarks "abc"+-- >     countAardvarks (replicate n 'a')+--+-- Use 'haxlWithStats' to inspect 'Stats' and confirm how many rounds and+-- fetches a computation actually used:+--+-- > (_, totalStats) <- inject $ haxlWithStats @() @() total+-- > numFetches totalStats `shouldBe` 1 -- one round: 1 fetch batch of size 2+-- >+-- > (_, chainedStats) <- inject $ haxlWithStats @() @() chained+-- > numFetches chainedStats `shouldBe` 2 -- two rounds: 1 fetch each+--+-- == Caching and memoization+--+-- Haxl automatically caches each unique request within a run, so fetching+-- the same request twice only issues one fetch. 'cacheRequest' seeds the+-- cache with a known result to skip a fetch entirely, and 'cachedComputation'+-- \/ 'memo' deduplicate an entire sub-computation (not just a single request)+-- across multiple uses:+--+-- > deduped :: GenHaxl u w es Int+-- > deduped = memo (CountAardvarks "ababa") $ do+-- >   -- runs only once even if `deduped` itself is used more than once+-- >   countAardvarks "ababa"+--+-- == Handling exceptions+--+-- 'GenHaxl' has its own 'catch' and 'try', distinct from the ones in+-- @Effectful.Exception@ or @Control.Exception@.+-- An exception thrown inside a 'GenHaxl' computation will not stop execution+-- at the point of the call, but only when its round of concurrent, batched+-- fetches is dispatched and completed.+-- Demanding the corresponding result will re-raise the exception.+--+-- > safeCount :: GenHaxl u w es (Either SomeException Int)+-- > safeCount = try (countAardvarks "BANG")+module Effectful.Haxl+    ( -- * Effect+      Haxl+    , runHaxlWith+    , runHaxl+    , haxl+    , haxlWithStats+    , haxlWithWrites++      -- * Env+    , initEnv+    , env+    , withEnv+    , GenHaxl (..)+    , liftGenHaxl+    , dataFetch+    , uncachedRequest+    , cacheRequest+    , dupableCacheRequest+    , cacheResult+    , cacheResultWithShow+    , cachedComputation+    , preCacheComputation+    , memoize+    , memoize1+    , memoize2+    , memo+    , memoFingerprint++      -- * Exceptions+    , throw+    , catch+    , catchIf+    , try+    , rethrowAsyncExceptions+    , tryWithRethrow++      -- * Dumping the cache+    , dumpCacheAsHaskell+    , dumpCacheAsHaskellFn++      -- * Re-exports+    , module Haxl.Core+    , module Haxl.Core.DataSource+    , module Haxl.Core.Exception+    , module Haxl.Core.Flags+    , module Haxl.Core.Monad+    , module Haxl.Core.ShowP+    , module Haxl.Core.StateStore+    , module Haxl.Core.Stats+    )+where++import Data.Functor ((<&>))+import Data.Hashable (Hashable)+import Data.IORef (readIORef)+import Data.Kind (Type)+import Data.Typeable (Typeable)+import Effectful+import Effectful.Dispatch.Static+import Effectful.Exception (Exception, SomeException)+import Effectful.Exception qualified as Effectful+import Haxl.Core (Env (..), Request)+import Haxl.Core qualified as Haxl+import Haxl.Core.DataSource+import Haxl.Core.Exception hiding (MonadFail (..), rethrowAsyncExceptions, tryWithRethrow)+import Haxl.Core.Fetch (ShowReq)+import Haxl.Core.Flags+import Haxl.Core.Memo (MemoFingerprintKey)+import Haxl.Core.Monad (Result (..))+import Haxl.Core.Monad qualified as Env+import Haxl.Core.Monad qualified as Haxl+import Haxl.Core.ShowP+import Haxl.Core.StateStore+import Haxl.Core.Stats+import Haxl.Prelude (IfThenElse (..))+import Prelude++data Haxl (u :: Type) (w :: Type) :: Effect++type instance DispatchOf (Haxl _ _) = 'Static 'WithSideEffects++data instance StaticRep (Haxl u _) = Haxl+    { stateStore :: !StateStore+    , userEnv :: !u+    , flags :: !Flags+    }++-- | Discharge the 'Haxl' effect for the duration of an action.+--+-- Use this when you need a user environment (@u@), collected writes (@w@),+-- non-default 'Flags', or non-trivial state store initialisation.+-- If none of that applies, 'runHaxl' is a shorter alternative.+runHaxlWith+    :: forall u w es a+     . (IOE :> es)+    => Eff es StateStore+    -> u+    -> Flags+    -> Eff (Haxl u w ': es) a+    -> Eff es a+runHaxlWith initialiseStore userEnv flags eff = do+    stateStore <- initialiseStore+    evalStaticRep Haxl{..} eff++-- | Discharge the 'Haxl' effect for a single data source, with no user+-- environment, no writes, and default 'Flags'.+--+-- This covers the common case of one data source and no need to tune+-- fetch reporting or batching behaviour.+runHaxl+    :: (StateKey k, IOE :> es)+    => State k+    -> Eff (Haxl () () ': es) a+    -> Eff es a+runHaxl s = runHaxlWith (pure $ stateSet s stateEmpty) () defaultFlags++-- | Run a 'GenHaxl' computation to completion inside the 'Haxl' effect with a fresh 'Env'.+haxl :: forall u w es a. (Monoid w) => GenHaxl u w es a -> Eff (Haxl u w ': es) a+haxl g = do+    env <- initEnv+    inject $ unsafeConcUnliftIO Persistent Unlimited \unlift ->+        Haxl.runHaxl env $ Haxl.GenHaxl (unlift . unHaxl g)++-- | Like 'haxl', but also return everything written via the 'w' monoid during the run.+haxlWithWrites :: forall u w es a. (Monoid w) => GenHaxl u w es a -> Eff (Haxl u w ': es) (a, w)+haxlWithWrites g = do+    env <- initEnv+    inject $ unsafeConcUnliftIO Persistent Unlimited \unlift ->+        Haxl.runHaxlWithWrites env $ Haxl.GenHaxl (unlift . unHaxl g)++-- | Like 'haxl', but also return the 'Stats' collected during the run.+--+-- Use this when you want to inspect batching behaviour,+-- e.g. asserting that a computation fetches in one round rather than many.+haxlWithStats :: forall u w es a. (Monoid w) => GenHaxl u w es a -> Eff (Haxl u w ': es) (a, Stats)+haxlWithStats g = do+    env <- initEnv+    a <- inject $ unsafeConcUnliftIO Persistent Unlimited \unlift ->+        Haxl.runHaxl env $ Haxl.GenHaxl (unlift . unHaxl g)+    stats <- unsafeEff_ . readIORef $ statsRef env+    pure (a, stats)++-- | Build a fresh 'Env' from the current 'Haxl' effect's state store, user+-- environment, and 'Flags'.+--+-- Each 'Env' has its own request cache, so an 'Env' obtained here starts+-- with an empty cache even if other 'Env's have already been used within+-- the same 'Haxl' effect scope.+-- You normally don't need this directly, as 'haxl' and @haxlWith*@ call it for you.+initEnv :: forall u w es. (Monoid w, Haxl u w :> es) => Eff es (Env u w)+initEnv = do+    Haxl{..} <- getStaticRep @(Haxl u w)+    unsafeEff_ $ Haxl.initEnv stateStore userEnv <&> \env -> env{Env.flags}++-- | The monad in which data-fetching computations are written.+--+-- Note that 'GenHaxl' is not expressed in terms of 'Eff'.+-- Its 'Applicative' instance batches independent fetches combined with @('<*>')@ into a single round trip.+newtype GenHaxl u w es a = GenHaxl {unHaxl :: Env u w -> Eff es (Haxl.Result u w a)}++instance Functor (GenHaxl u w es) where+    fmap f (GenHaxl m) = GenHaxl $ (fmap . fmap . fmap) f m++instance Applicative (GenHaxl u w es) where+    pure = GenHaxl . const . pure . Done+    f <*> a = GenHaxl $ \env -> do+        unsafeConcUnliftIO Ephemeral Unlimited $ \unlift ->+            Haxl.unHaxl+                ( Haxl.GenHaxl (unlift . unHaxl f)+                    <*> Haxl.GenHaxl (unlift . unHaxl a)+                )+                env++instance Monad (GenHaxl u w es) where+    return = pure+    m >>= k = GenHaxl $ \env -> do+        unsafeConcUnliftIO Ephemeral Unlimited $ \unlift ->+            Haxl.unHaxl+                ( Haxl.GenHaxl (unlift . unHaxl m)+                    >>= \a -> Haxl.GenHaxl (unlift . unHaxl (k a))+                )+                env++instance MonadFail (GenHaxl u w es) where+    fail = liftGenHaxl . fail++instance (Semigroup a) => Semigroup (GenHaxl u w es a) where+    (<>) = liftA2 (<>)++instance (Monoid a) => Monoid (GenHaxl u w es a) where+    mempty = pure mempty++instance IfThenElse (GenHaxl u w es Bool) (GenHaxl u w es a) where+    ifThenElse fb t e = do+        b <- fb+        if b then t else e++instance (Num a) => Num (GenHaxl u w es a) where+    (+) = liftA2 (+)+    (-) = liftA2 (-)+    (*) = liftA2 (*)+    fromInteger = pure . fromInteger+    abs = fmap abs+    signum = fmap signum+    negate = fmap negate++instance (Fractional a) => Fractional (GenHaxl u w es a) where+    (/) = liftA2 (/)+    recip = fmap recip+    fromRational = return . fromRational++-- | Lift a plain 'Haxl.GenHaxl' computation into 'GenHaxl'.+--+-- This is an escape hatch for the rare cases where you need to work directly+-- with 'Haxl.GenHaxl'; for example when you need precise control over+-- Haxl's fetch scheduling that the 'Eff' wrapper does not preserve, or when+-- integrating with third-party code that returns 'Haxl.GenHaxl' values+-- directly.+--+-- Warning: 'Haxl.GenHaxl' exposes functions such as 'Haxl.unsafeLiftIO'+-- that allow arbitrary 'IO' to be injected without it being reflected in @es@.+liftGenHaxl :: Haxl.GenHaxl u w a -> GenHaxl u w es a+liftGenHaxl = GenHaxl . (unsafeEff_ .) . Haxl.unHaxl++unliftGenHaxl :: GenHaxl u w es a -> Eff es (Haxl.GenHaxl u w a)+unliftGenHaxl g =+    unsafeConcUnliftIO Ephemeral Unlimited $ pure . Haxl.GenHaxl . (. unHaxl g)++unliftGenHaxl1 :: (a -> GenHaxl u w es b) -> Eff es (a -> Haxl.GenHaxl u w b)+unliftGenHaxl1 f =+    unsafeConcUnliftIO Ephemeral Unlimited \unlift -> pure \a ->+        Haxl.GenHaxl $ unlift . unHaxl (f a)++unliftGenHaxl2 :: (a -> b -> GenHaxl u w es c) -> Eff es (a -> b -> Haxl.GenHaxl u w c)+unliftGenHaxl2 f =+    unsafeConcUnliftIO Ephemeral Unlimited \unlift -> pure \a b ->+        Haxl.GenHaxl $ unlift . unHaxl (f a b)++mapGenHaxl :: (Haxl.GenHaxl u w a -> Haxl.GenHaxl u w b) -> GenHaxl u w es a -> GenHaxl u w es b+mapGenHaxl f g = GenHaxl \env -> do+    g <- unliftGenHaxl g+    unsafeEff_ $ Haxl.unHaxl (f g) env++mapGenHaxl1+    :: ((a -> Haxl.GenHaxl u w b) -> Haxl.GenHaxl u w c)+    -> (a -> GenHaxl u w es b)+    -> GenHaxl u w es c+mapGenHaxl1 f g = GenHaxl \env -> do+    g <- unliftGenHaxl1 g+    unsafeEff_ $ Haxl.unHaxl (f g) env++mapGenHaxl2+    :: ((a -> b -> Haxl.GenHaxl u w c) -> Haxl.GenHaxl u w d)+    -> (a -> b -> GenHaxl u w es c)+    -> GenHaxl u w es d+mapGenHaxl2 f g = GenHaxl \env -> do+    g <- unliftGenHaxl2 g+    unsafeEff_ $ Haxl.unHaxl (f g) env++mapGenHaxlCatch+    :: (Haxl.GenHaxl u w a -> (e -> Haxl.GenHaxl u w a) -> Haxl.GenHaxl u w a)+    -> GenHaxl u w es a+    -> (e -> GenHaxl u w es a)+    -> GenHaxl u w es a+mapGenHaxlCatch f g h = GenHaxl \env -> do+    g <- unliftGenHaxl g+    h <- unliftGenHaxl1 h+    unsafeEff_ $ Haxl.unHaxl (f g h) env++-- | Lifted 'Haxl.env'+env :: (Env u w -> a) -> GenHaxl u w es a+env = liftGenHaxl . Haxl.env++-- | Lifted 'Haxl.withEnv'+withEnv :: Env u w -> GenHaxl u w es a -> GenHaxl u w es a+withEnv = mapGenHaxl . Haxl.withEnv++-- | Lifted 'Haxl.dataFetch'+dataFetch :: (DataSource u r, Request r a) => r a -> GenHaxl u w es a+dataFetch = liftGenHaxl . Haxl.dataFetch++-- | Lifted 'Haxl.uncachedRequest'+uncachedRequest :: (DataSource u r, Request r a) => r a -> GenHaxl u w es a+uncachedRequest = liftGenHaxl . Haxl.uncachedRequest++-- | Lifted 'Haxl.cacheRequest'+cacheRequest :: (Request req a) => req a -> Either SomeException a -> GenHaxl u w es ()+cacheRequest = (liftGenHaxl .) . Haxl.cacheRequest++-- | Lifted 'Haxl.dupableCacheRequest'+dupableCacheRequest :: (Request req a) => req a -> Either SomeException a -> GenHaxl u w es ()+dupableCacheRequest = (liftGenHaxl .) . Haxl.dupableCacheRequest++-- | Lifted 'Haxl.cacheResult'+cacheResult :: (Request r a) => r a -> Eff es a -> GenHaxl u w es a+cacheResult r eff =+    GenHaxl \env ->+        unsafeConcUnliftIO Ephemeral Unlimited \unlift ->+            Haxl.unHaxl (Haxl.cacheResult r (unlift eff)) env++-- | Lifted 'Haxl.cacheResultWithShow'+cacheResultWithShow+    :: (Hashable (r a), Typeable (r a))+    => ShowReq r a+    -> r a+    -> Eff es a+    -> GenHaxl u w es a+cacheResultWithShow showReq req eff =+    GenHaxl \env ->+        unsafeConcUnliftIO Ephemeral Unlimited \unlift ->+            Haxl.unHaxl (Haxl.cacheResultWithShow showReq req (unlift eff)) env++-- | Lifted 'Haxl.cachedComputation'+cachedComputation+    :: (Hashable (req a), Typeable (req a), Monoid w)+    => req a+    -> GenHaxl u w es a+    -> GenHaxl u w es a+cachedComputation = mapGenHaxl . Haxl.cachedComputation++-- | Lifted 'Haxl.preCacheComputation'+preCacheComputation+    :: (Hashable (req a), Typeable (req a), Monoid w)+    => req a+    -> GenHaxl u w es a+    -> GenHaxl u w es a+preCacheComputation = mapGenHaxl . Haxl.preCacheComputation++-- | Lifted 'Haxl.memoize'+memoize :: (Monoid w) => GenHaxl u w es a -> GenHaxl u w es (GenHaxl u w es a)+memoize = fmap liftGenHaxl . mapGenHaxl Haxl.memoize++-- | Lifted 'Haxl.memoize1'+memoize1+    :: (Hashable a, Monoid w)+    => (a -> GenHaxl u w es b)+    -> GenHaxl u w es (a -> GenHaxl u w es b)+memoize1 = fmap (liftGenHaxl .) . mapGenHaxl1 Haxl.memoize1++-- | Lifted 'Haxl.memoize2'+memoize2+    :: (Hashable a, Hashable b, Monoid w)+    => (a -> b -> GenHaxl u w es c)+    -> GenHaxl u w es (a -> b -> GenHaxl u w es c)+memoize2 = fmap ((liftGenHaxl .) .) . mapGenHaxl2 Haxl.memoize2++-- | Lifted 'Haxl.memo'+memo+    :: ( Typeable a+       , Typeable k+       , Hashable k+       , Monoid w+       )+    => k+    -> GenHaxl u w es a+    -> GenHaxl u w es a+memo = mapGenHaxl . Haxl.memo++-- | Lifted 'Haxl.memoFingerprint'+memoFingerprint+    :: (Typeable a, Monoid w)+    => MemoFingerprintKey a+    -> GenHaxl u w es a+    -> GenHaxl u w es a+memoFingerprint = mapGenHaxl . Haxl.memoFingerprint++-- | Lifted 'Haxl.rethrowAsyncExceptions'+rethrowAsyncExceptions :: SomeException -> Eff es ()+rethrowAsyncExceptions = unsafeEff_ . Haxl.rethrowAsyncExceptions++tryWithRethrow :: Eff es a -> Eff es (Either SomeException a)+tryWithRethrow eff = (Right <$> eff) `Effectful.catch` \e -> rethrowAsyncExceptions e >> pure (Left e)++-- | Lifted 'Haxl.throw'+throw :: (Exception e) => e -> GenHaxl u w es a+throw = liftGenHaxl . Haxl.throw++-- | Lifted 'Haxl.catch'+catch :: (Exception e) => GenHaxl u w es a -> (e -> GenHaxl u w es a) -> GenHaxl u w es a+catch = mapGenHaxlCatch Haxl.catch++-- | Lifted 'Haxl.catchIf'+catchIf+    :: (Exception e)+    => (e -> Bool)+    -> GenHaxl u w es a+    -> (e -> GenHaxl u w es a)+    -> GenHaxl u w es a+catchIf = mapGenHaxlCatch . Haxl.catchIf++-- | Lifted 'Haxl.try'+try :: (Exception e) => GenHaxl u w es a -> GenHaxl u w es (Either e a)+try = mapGenHaxl Haxl.try++-- | Lifted 'Haxl.dumpCacheAsHaskell'+dumpCacheAsHaskell :: GenHaxl u w es String+dumpCacheAsHaskell = dumpCacheAsHaskellFn "loadCache" "GenHaxl u w es ()" "cacheRequest"++-- | Lifted 'Haxl.dumpCacheAsHaskellFn'+dumpCacheAsHaskellFn :: String -> String -> String -> GenHaxl u w es String+dumpCacheAsHaskellFn = ((liftGenHaxl .) .) . Haxl.dumpCacheAsHaskellFn
+ test/ExampleDataSource.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}++module ExampleDataSource+    ( -- * initialise the state+      initGlobalState++      -- * requests for this data source+    , Id (..)+    , ExampleReq (..)+    , countAardvarks+    , listWombats+    )+where++import Control.Concurrent+import Control.Exception qualified as E+import Data.Hashable+import Effectful+import Effectful.Haxl+import System.IO (hPutStr, stderr)+import Prelude++-- Here is an example minimal data source.  Our data source will have+-- two requests:+--+--   countAardvarks :: String -> Haxl Int+--   listWombats    :: Id     -> Haxl [Id]+--+-- First, the data source defines a request type, with one constructor+-- for each request:++newtype Id = Id Int+    deriving newtype (Eq, Ord, Enum, Num, Integral, Real, Hashable)++instance Show Id where+    show (Id i) = show i++data ExampleReq a where+    CountAardvarks :: String -> ExampleReq Int+    ListWombats :: Id -> ExampleReq [Id]++-- The request type (ExampleReq) is parameterized by the result type of+-- each request.  Each request might have a different result, so we use a+-- GADT - a data type in which each constructor may have different type+-- parameters. Here CountAardvarks is a request that takes a String+-- argument and its result is Int, whereas ListWombats takes an Id+-- argument and returns a [Id].++-- The request type needs instances for 'Eq1' and 'Hashable1'.  These+-- are like 'Eq' and 'Hashable', but for types with one parameter+-- where the parameter is irrelevant for hashing and equality.+-- These two instances are used to support caching of requests.++-- We need Eq, but we have to derive it with a standalone declaration+-- like this, because plain deriving doesn't work with GADTs.+deriving stock instance Eq (ExampleReq a)++deriving stock instance Show (ExampleReq a)++instance ShowP ExampleReq where showp = show++instance Hashable (ExampleReq a) where+    hashWithSalt s (CountAardvarks a) = hashWithSalt s (0 :: Int, a)+    hashWithSalt s (ListWombats a) = hashWithSalt s (1 :: Int, a)++instance StateKey ExampleReq where+    data State ExampleReq = ExampleState+        {+        }++-- in here you can put any state that the+-- data source needs to maintain throughout the+-- run.++-- Next we need to define an instance of DataSourceName:++instance DataSourceName ExampleReq where+    dataSourceName _ = "ExampleDataSource"++-- Next we need to define an instance of DataSource:++instance DataSource u ExampleReq where+    -- I'll define exampleFetch below+    fetch = exampleFetch++    -- we don't want to treat NotFound as an exception for stats purposes+    classifyFailure _ _ e+        | Just NotFound{} <- E.fromException e = IgnoredForStatsFailure+        | otherwise = StandardFailure++-- Every data source should define a function 'initGlobalState' that+-- initialises the state for that data source.  The arguments to this+-- function might vary depending on the data source - we might need to+-- pass in resources from the environment, or parameters to set up the+-- data source.+initGlobalState :: Eff es (State ExampleReq)+initGlobalState = pure ExampleState{}++-- The most important bit: fetching the data.  The fetching function+-- takes a list of BlockedFetch, which is defined as+--+-- data BlockedFetch r+--   = forall a . BlockedFetch (r a) (ResultVar a)+--+-- That is, each BlockedFetch is a pair of+--+--   - the request to fetch (with result type a)+--   - a ResultVar to store either the result or an error+--+-- The job of fetch is to fetch the data and fill in all the ResultVars.+--+exampleFetch+    :: State ExampleReq -- current state+    -> Flags -- tracing verbosity, etc.+    -> u -- user environment+    -> PerformFetch ExampleReq -- tells the framework how to fetch+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+-- details.++fetch1 :: BlockedFetch ExampleReq -> IO ()+fetch1 (BlockedFetch (CountAardvarks "BANG") _) =+    error "BANG" -- data sources should not throw exceptions, but in+    -- the event that one does, the framework will+    -- propagate the exception to the call site of+    -- dataFetch.+fetch1 (BlockedFetch (CountAardvarks "BANG2") m) = do+    putSuccess m 1+    error "BANG2" -- the exception is propagated even if we have already+    -- put the result with putSuccess+fetch1 (BlockedFetch (CountAardvarks "BANG3") _) = do+    hPutStr stderr "BANG3"+    killThread =<< myThreadId -- an asynchronous exception+fetch1 (BlockedFetch (CountAardvarks "BANG4") r) = do+    putFailure r $ NotFound "BANG4"+fetch1 (BlockedFetch (CountAardvarks str) m) =+    putSuccess m (length (filter (== 'a') str))+fetch1 (BlockedFetch (ListWombats a) r) =+    if a > 999999+        then putFailure r $ FetchError "too large"+        else putSuccess r $ take (fromIntegral a) [1 ..]++-- Normally a data source will provide some convenient wrappers for+-- its requests:++countAardvarks :: String -> GenHaxl u w es Int+countAardvarks str = dataFetch (CountAardvarks str)++listWombats :: Id -> GenHaxl u w es [Id]+listWombats i = dataFetch (ListWombats i)
+ test/LoadCache.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE CPP #-}++{- HLINT ignore "Redundant bracket" -}++module LoadCache where++import Effectful.Haxl+import ExampleDataSource+import Prelude++#include "./LoadCache.txt"
+ test/LoadCache.txt view
@@ -0,0 +1,5 @@+loadCache :: GenHaxl u w es ()+loadCache = do+  cacheRequest (CountAardvarks "yyy") (except (LogicError (NotFound "yyy")))+  cacheRequest (CountAardvarks "xxx") (Right (3))+  cacheRequest (ListWombats 100) (Right ([1,2,3]))
+ test/Main.hs view
@@ -0,0 +1,388 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Main where++import Data.Functor ((<&>))+import Data.List qualified as List+import Data.Maybe (mapMaybe)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import Effectful+import Effectful.Exception (AsyncException (..), ErrorCall (..), SomeException)+import Effectful.Exception qualified as Effectful+import Effectful.FileSystem (FileSystem, runFileSystem)+import Effectful.FileSystem.IO.ByteString (readFile)+import Effectful.Haxl as Haxl+import Effectful.Hspec+import Effectful.Prim (Prim, runPrim)+import Effectful.Prim.IORef (modifyIORef', newIORef, readIORef)+import ExampleDataSource (Id (..))+import ExampleDataSource qualified+import LoadCache (loadCache)+import System.FilePath (dropFileName, (</>))+import Prelude hiding (readFile)++initialState :: Eff es StateStore+initialState = flip stateSet stateEmpty <$> ExampleDataSource.initGlobalState++withFetchStats :: Flags+withFetchStats =+    defaultFlags+        { report = setReportFlag ReportFetchStats defaultReportFlags+        }++main :: IO ()+main =+    runEff+        . runPrim+        . runFileSystem+        . runHspec+        . runHaxlWith @() @() initialState () withFetchStats+        $ do+            describe "env" do+                envTest+                withEnvTest+            describe "batching" do+                describe "single round" do+                    applicativeBatchingTest+                    numBatchingTest+                    largeBatchTest+                describe "multi-round" do+                    sequentialRoundsTest+                    dependentFanOutTest+                    deepChainTest+            describe "caching" do+                preCacheTest+                preCacheExceptionTest+                cachedComputationTest+                cacheResultTest+                memoTest+            describe "exceptions" do+                syncExceptionTest+                asyncExceptionTest+            describe "cache dump" do+                dumpCacheTest++-- * Helpers++-- Run a 'GenHaxl' action and return the result alongside the per-round+-- 'FetchStats'.+withStats+    :: forall es a+     . (Haxl () () :> es)+    => GenHaxl () () es a+    -> Eff es (a, [FetchStats])+withStats g = do+    (a, Stats stats) <- inject $ haxlWithStats @() @() g+    pure (a, stats)++rounds :: [FetchStats] -> Int+rounds = length++fetchBatchSizes :: [FetchStats] -> [Int]+fetchBatchSizes =+    reverse . mapMaybe \case+        FetchStats{..} -> Just fetchBatchSize+        _ -> Nothing++totalFetches :: [FetchStats] -> Int+totalFetches = sum . fetchBatchSizes++-- Assert that a computation completes in exactly @n@ fetch rounds.+shouldUseRounds+    :: (HasCallStack, Haxl () () :> es, Hspec :> es)+    => GenHaxl () () es a -> Int -> Eff es ()+g `shouldUseRounds` n = do+    (_, stats) <- withStats g+    rounds stats `shouldBe` n++-- Assert that a computation issues exactly @n@ fetches in total across all+-- rounds.+shouldUseFetches+    :: (HasCallStack, Haxl () () :> es, Hspec :> es)+    => GenHaxl () () es a -> Int -> Eff es ()+g `shouldUseFetches` n = do+    (_, stats) <- withStats g+    totalFetches stats `shouldBe` n++-- Assert that a computation completes in exactly @r@ rounds issuing exactly+-- @f@ fetches in total.+shouldUseRoundsAndFetches+    :: (HasCallStack, Haxl () () :> es, Hspec :> es)+    => GenHaxl () () es a -> (Int, Int) -> Eff es ()+g `shouldUseRoundsAndFetches` (r, f) = do+    (_, stats) <- withStats g+    rounds stats `shouldBe` r+    totalFetches stats `shouldBe` f++deriving stock instance Eq Flags++instance Eq ReportFlags where+    r1 == r2 = show r1 == show r2++deriving stock instance Show Flags++-- * Env++-- 'env' should extract data from the current 'Env'.+envTest :: forall es. (Haxl () () :> es, Hspec :> es) => Expectation es+envTest = it "extracts data from the Env" do+    flags <- inject . haxl @() @() $ env Haxl.flags+    flags `shouldBe` withFetchStats++-- 'withEnv' should override the 'Env' for the duration of a computation,+-- then restore it afterwards.+withEnvTest :: forall es. (Haxl () () :> es, Hspec :> es) => Expectation es+withEnvTest = it "overrides the Env for the duration of a computation" do+    newEnv <- initEnv <&> \env -> env{Haxl.flags = defaultFlags}+    (inner, outer) <- inject . haxl @() @() $ do+        let newEnv' = newEnv{Haxl.flags = defaultFlags}+        inner <- withEnv newEnv' $ env Haxl.flags+        outer <- env Haxl.flags+        pure (inner, outer)+    inner `shouldBe` defaultFlags+    outer `shouldBe` withFetchStats++-- * Single-round batching++-- Two independent applicative fetches should be batched into one round.+applicativeBatchingTest :: forall es. (Haxl () () :> es, Hspec :> es) => Expectation es+applicativeBatchingTest = it "batches two independent applicative fetches" do+    let g :: GenHaxl () () es Int+        g =+            ExampleDataSource.countAardvarks "abcabc"+                + (length <$> ExampleDataSource.listWombats 3)+    (result, stats) <- withStats g+    result `shouldBe` 2 + 3+    rounds stats `shouldBe` 1+    totalFetches stats `shouldBe` 2++-- The 'Num' instance uses 'liftA2', so arithmetic over fetched values should+-- also batch into one round.+numBatchingTest :: forall es. (Haxl () () :> es, Hspec :> es) => Expectation es+numBatchingTest = it "batches fetches combined with Num arithmetic" do+    let g :: GenHaxl () () es Int+        g =+            ExampleDataSource.countAardvarks "abcabc"+                + (length <$> ExampleDataSource.listWombats 3)+    g `shouldUseRoundsAndFetches` (1, 2)++-- Many independent fetches should all land in a single round regardless of+-- how many there are.+largeBatchTest :: forall es. (Haxl () () :> es, Hspec :> es) => Expectation es+largeBatchTest = it "batches many independent fetches into one round" do+    let queries = take 8 $ flip replicate 'a' <$> [1 ..]+    let g :: GenHaxl () () es Int+        g = sum <$> traverse ExampleDataSource.countAardvarks queries+    g `shouldUseRoundsAndFetches` (1, 8)++-- * Multi-round batching++-- A monadic bind forces a second round: the second fetch cannot be issued+-- until the first result is known.+sequentialRoundsTest :: forall es. (Haxl () () :> es, Hspec :> es) => Expectation es+sequentialRoundsTest = it "uses two rounds for a monadic sequence" do+    let g :: GenHaxl () () es Int+        g = do+            n <- ExampleDataSource.countAardvarks "abcabc"+            length <$> ExampleDataSource.listWombats (Id n)+    g `shouldUseRoundsAndFetches` (2, 2)++-- After one blocking fetch, multiple independent fetches in the next round+-- should still be batched together.+dependentFanOutTest :: forall es. (Haxl () () :> es, Hspec :> es) => Expectation es+dependentFanOutTest = it "batches a fan-out of fetches in round 2" do+    let g :: GenHaxl () () es Int+        g = do+            n <- ExampleDataSource.countAardvarks "abcabc" -- round 1+            -- Both listWombats calls are independent of each other, so they+            -- should be batched into a single round 2.+            (length <$> ExampleDataSource.listWombats (Id n))+                + (length <$> ExampleDataSource.listWombats (Id $ n + 1))+    (result, stats) <- withStats g+    result `shouldBe` 2 + 3+    rounds stats `shouldBe` 2+    fetchBatchSizes stats `shouldBe` [1, 2]++-- A large fan-out after an initial fetch: all N dependent fetches should+-- land in round 2, not spread across N rounds.+largeFanOutTest :: forall es. (Haxl () () :> es, Hspec :> es) => Expectation es+largeFanOutTest = it "batches a large fan-out into round 2" do+    let g :: GenHaxl () () es Int+        g = do+            n <- ExampleDataSource.countAardvarks "abcabc" -- round 1, n == 2+            -- Fan out to n+6 = 8 independent fetches in round 2+            let queries = take (n + 6) $ flip replicate 'a' <$> [1 ..]+            sum <$> traverse ExampleDataSource.countAardvarks queries+    (_, stats) <- withStats g+    rounds stats `shouldBe` 2+    fetchBatchSizes stats `shouldBe` [1, 8]++-- A chain of dependent fetches should take exactly one round per step, with+-- no spurious extra rounds.+deepChainTest :: forall es. (Haxl () () :> es, Hspec :> es) => Expectation es+deepChainTest = it "uses one round per step in a dependent chain" do+    let g :: GenHaxl () () es Int+        g = do+            n1 <- ExampleDataSource.countAardvarks "ab" -- round 1+            n2 <- ExampleDataSource.countAardvarks (replicate n1 'a') -- round 2+            length <$> ExampleDataSource.listWombats (Id n2) -- round 3+    g `shouldUseRounds` 3++-- Mixing applicative and monadic style: applicative branches within each+-- monadic step should still batch.+mixedStyleTest :: forall es. (Haxl () () :> es, Hspec :> es) => Expectation es+mixedStyleTest = it "batches applicative branches within each monadic step" do+    let g :: GenHaxl () () es Int+        g = do+            -- Round 1: two fetches batched+            (n1, n2) <-+                (,)+                    <$> ExampleDataSource.countAardvarks "ab"+                    <*> ExampleDataSource.countAardvarks "abc"+            -- Round 2: two fetches batched+            (w1, w2) <-+                (,)+                    <$> ExampleDataSource.listWombats (Id n1)+                    <*> ExampleDataSource.listWombats (Id n2)+            pure (length w1 + length w2)+    (_, stats) <- withStats g+    rounds stats `shouldBe` 2+    fetchBatchSizes stats `shouldBe` [2, 2]++-- * Caching++-- Results pre-seeded with 'cacheRequest' are returned without issuing any+-- fetches.+preCacheTest :: forall es. (Haxl () () :> es, Hspec :> es) => Expectation es+preCacheTest = it "returns pre-cached results without fetching" do+    let g :: GenHaxl () () es Int+        g = do+            cacheRequest (ExampleDataSource.CountAardvarks "xxx") (Right 3)+            cacheRequest (ExampleDataSource.ListWombats 1000000) (Right [1, 2, 3])+            ExampleDataSource.countAardvarks "xxx" + (length <$> ExampleDataSource.listWombats 1000000)+    (result, stats) <- withStats g+    result `shouldBe` 6+    rounds stats `shouldBe` 0++preCacheExceptionTest :: forall es. (Haxl () () :> es, Hspec :> es) => Expectation es+preCacheExceptionTest = it "re-throws pre-cached exceptions" do+    r <- Effectful.try . inject . haxl @() @() $ do+        cacheRequest (ExampleDataSource.CountAardvarks "yyy") $+            except (NotFound "yyy")+        ExampleDataSource.countAardvarks "yyy"+    r `shouldSatisfy` \case+        Left (NotFound "yyy") -> True+        _ -> False++-- 'cachedComputation' deduplicates a sub-computation across uses, reducing+-- the total number of fetches.+cachedComputationTest :: forall es. (Haxl () () :> es, Hspec :> es) => Expectation es+cachedComputationTest = it "deduplicates cachedComputation across uses" do+    let g :: GenHaxl () () es Int+        g =+            cachedComputation (ExampleDataSource.CountAardvarks "ababa") $+                (length <$> ExampleDataSource.listWombats 10)+                    + (length <$> ExampleDataSource.listWombats 20)+    -- x used twice: second use hits the cache, so only 2 + 1 = 3 fetches total+    -- rather than 2 + 2 + 1 = 5.+    (r, stats) <- withStats $ g + g + ExampleDataSource.countAardvarks "baba"+    r `shouldBe` 62+    totalFetches stats `shouldBe` 3++-- 'cacheResult' runs its 'Eff' action exactly once even when used+-- applicatively, which would otherwise execute it twice.+cacheResultTest+    :: forall es+     . (Haxl () () :> es, Hspec :> es, Prim :> es)+    => Expectation es+cacheResultTest = it "executes cacheResult action exactly once" do+    ref <- newIORef (0 :: Int)+    let request = cacheResult (ExampleDataSource.CountAardvarks "ababa") $ do+            modifyIORef' ref (+ 1)+            readIORef ref+    r <- inject . haxl @() @() $ request + request+    -- The action increments and reads ref; it should run once, giving 1.+    -- Both uses of `request` return 1, so the sum is 2.+    r `shouldBe` 2++-- 'memo' deduplicates across uses in the same run, same as+-- 'cachedComputation'.+memoTest :: forall es. (Haxl () () :> es, Hspec :> es) => Expectation es+memoTest = it "deduplicates memo'd computations" do+    let g :: GenHaxl () () es Int+        g =+            memo (ExampleDataSource.CountAardvarks "ababa") $+                (length <$> ExampleDataSource.listWombats 10)+                    + (length <$> ExampleDataSource.listWombats 20)+    (r, stats) <- withStats $ g + g + ExampleDataSource.countAardvarks "baba"+    r `shouldBe` 62+    totalFetches stats `shouldBe` 3++-- * Exceptions++syncExceptionTest :: forall es. (Haxl () () :> es, Hspec :> es) => Expectation es+syncExceptionTest = do+    it "catches synchronous data-source exceptions with Haxl.try" do+        r <-+            inject . haxl @() @() . Haxl.try $+                ExampleDataSource.countAardvarks "BANG"+        r `shouldSatisfy` \case+            Left (ErrorCall "BANG") -> True+            _ -> False++    it "catches a second independent sync exception" do+        r <-+            inject . haxl @() @() . Haxl.try $+                ExampleDataSource.countAardvarks "BANG2"+        r `shouldSatisfy` \case+            Left (ErrorCall "BANG2") -> True+            _ -> False++    it "still batches both fetches when one branch throws" do+        (r, Stats stats) <-+            inject . haxlWithStats @() @() $+                Haxl.try $+                    (<>)+                        <$> ExampleDataSource.listWombats 1000000+                        <*> ExampleDataSource.listWombats 1000001+        r `shouldSatisfy` \case+            Left FetchError{} -> True+            Right _ -> False+        sum [fetchBatchSize | FetchStats{..} <- stats] `shouldBe` 2+        sum [fetchFailures | FetchStats{..} <- stats] `shouldBe` 2++-- Asynchronous exceptions (e.g. 'ThreadKilled') escape 'Haxl.try' and must+-- be caught outside 'runHaxl'.+asyncExceptionTest :: forall es. (Haxl () () :> es, Hspec :> es) => Expectation es+asyncExceptionTest = it "propagates async exceptions past Haxl.try" do+    r :: Either AsyncException (Either SomeException Int) <-+        Effectful.try $+            inject . haxl @() @() . Haxl.try $+                (length <$> ExampleDataSource.listWombats 100)+                    + ExampleDataSource.countAardvarks "BANG3"+    r `shouldSatisfy` \case+        Left ThreadKilled -> True+        _ -> False++-- * Cache dump++-- Load a known cache then dump it; the output should match the fixture file.+-- Both operations run in the same 'haxl' call so they share the 'Env'.+dumpCacheTest+    :: forall es+     . (FileSystem :> es, Haxl () () :> es, Hspec :> es)+    => Expectation es+dumpCacheTest = it "round-trips the cache through dumpCacheAsHaskell" do+    str <- inject . haxl @() @() $ do+        loadCache+        dumpCacheAsHaskell+    fixture <-+        Text.unpack . Text.decodeUtf8+            <$> readFile (dropFileName __FILE__ </> "LoadCache.txt")+    -- Line order is non-deterministic across GHC versions, so sort before+    -- comparing.+    List.sort (lines str) `shouldBe` List.sort (lines fixture)