diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100644
--- /dev/null
+++ b/CHANGELOG.md
@@ -0,0 +1,11 @@
+# Changelog for `sofetch`
+
+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.0.0/),
+and this project adheres to the
+[Haskell Package Versioning Policy](https://pvp.haskell.org/).
+
+## Unreleased
+
+## 0.1.0.0 - YYYY-MM-DD
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,26 @@
+Copyright 2026 Author name here
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+1. Redistributions of source code must retain the above copyright notice, this
+ list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright notice,
+ this list of conditions and the following disclaimer in the documentation
+ and/or other materials provided with the distribution.
+
+3. Neither the name of the copyright holder nor the names of its contributors
+ may be used to endorse or promote products derived from this software
+ without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR
+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -0,0 +1,404 @@
+
+ 
+
+
+
+ 
+
+
+
+ 
+ 
+ 
+
+
+---
+
+## The problem
+
+Suppose you have a web page that shows a list of blog posts, each with its
+author's name. A naive implementation fetches each author one at a time:
+
+```haskell
+-- Fetch each author individually, one query per post!
+renderPosts :: [Post] -> AppM [Html]
+renderPosts posts = forM posts $ \post -> do
+ author <- getUser (postAuthorId post) -- DB round-trip
+ pure (renderPostCard post author)
+```
+
+Ten posts means ten separate database queries. A hundred posts means a
+hundred queries. This is the **N+1 problem**: you run 1 query to get the
+list, then N more queries to get each related item. It's one of the most
+common performance pitfalls in data-access code, and it's easy to
+introduce without noticing because each function in isolation looks
+perfectly reasonable.
+
+The typical fix is to restructure your code: collect all the
+IDs up front, run a single batched query, then stitch the results back
+together. That works, but it forces your code shape to match your
+optimisation strategy. Composition suffers: you can't freely combine small
+functions without worrying about the data-access pattern they produce.
+
+## The solution
+
+**sofetch** fixes this automatically. Write simple, sequential-looking
+code, and sofetch batches and deduplicates your data access behind the
+scenes:
+
+```haskell
+renderPosts :: (MonadFetch m n, DataSource m UserById) => [Post] -> n [Html]
+renderPosts posts =
+ -- All author fetches are batched into ONE query, automatically.
+ fetchThrough (UserById . postAuthorId) posts
+ <&> map (\(post, author) -> renderPostCard post author)
+```
+
+No matter how many posts you have, this issues a single `WHERE id IN (...)`
+query for all the authors. You didn't have to restructure anything. You
+wrote the obvious code and sofetch made it fast.
+
+
+ 
+
+
+This works across function boundaries too. If `renderPostCard` internally
+fetches comment counts, and `renderSidebar` fetches the same authors for a
+"top contributors" widget, sofetch merges all of those fetches together.
+Functions that were written independently, without any knowledge of each
+other, still get optimal batching when composed.
+
+## How it works (in brief)
+
+sofetch gives you a special `Fetch` monad. When you write:
+
+```haskell
+(,) <$> fetch (UserById 1) <*> fetch (UserById 2)
+```
+
+...the two fetches don't happen immediately. Instead, sofetch collects them
+into a **round**, groups them by data source, and dispatches one batched
+call per source. The `<*>` operator (or `ApplicativeDo` if you prefer
+do-notation) is the signal that two fetches are independent and can be
+batched together. The `>>=` operator (monadic bind) introduces a round
+boundary: the right side depends on the left side's result, so it has to
+wait.
+
+```mermaid
+flowchart LR
+ f1["fetch (UserById 1)"] --> b1["batchFetch
[UserById 1, 2]"]
+ f2["fetch (UserById 2)"] --> b1
+ f3["fetch (PostsByAuthor 1)"] --> b2["batchFetch
[PostsByAuthor 1]"]
+ b1 -. "concurrent" .- b2
+```
+
+Within each round:
+
+- Keys for the **same data source** are grouped into one `batchFetch` call.
+- Keys for **different data sources** run concurrently.
+- **Duplicate keys** are deduplicated. The same key appearing in multiple
+ places produces only one fetch, and all callers share the result.
+- Results are **cached** so the same key never hits the database twice (unless
+ you opt out).
+
+## Quick start
+
+### 1. Define key types
+
+Each kind of data you want to fetch gets a **key type**, a small type that
+says "I want to look up *this thing*" and declares what the result will be.
+This is the core modelling step: one key type per query shape.
+
+```haskell
+{-# LANGUAGE DeriveGeneric, DeriveAnyClass, DerivingStrategies, TypeFamilies #-}
+
+data User = User { userId :: Int, userName :: Text }
+data Post = Post { postId :: Int, postAuthorId :: Int, postTitle :: Text }
+
+-- "Give me a user by their ID"
+newtype UserById = UserById Int
+ deriving stock (Eq, Ord, Show, Generic)
+ deriving anyclass (Hashable)
+
+instance FetchKey UserById where
+ type Result UserById = User
+
+-- "Give me all posts by this author"
+newtype PostsByAuthor = PostsByAuthor Int
+ deriving stock (Eq, Ord, Show, Generic)
+ deriving anyclass (Hashable)
+
+instance FetchKey PostsByAuthor where
+ type Result PostsByAuthor = [Post]
+```
+
+The key type carries the query parameter (the user ID, the author ID) and
+the `FetchKey` instance tells sofetch what type the answer will be. All the
+required instances (`Eq`, `Hashable`, `Show`, etc.) are stock-derivable, no
+boilerplate.
+
+### 2. Teach sofetch how to fetch them
+
+A `DataSource` instance tells sofetch how to batch-fetch a group of keys.
+You receive a `NonEmpty` list of keys and return a `HashMap` of results,
+one entry per key:
+
+```haskell
+instance DataSource AppM UserById where
+ batchFetch keys = do
+ pool <- asks appPool
+ let ids = [uid | UserById uid <- toList keys]
+ rows <- liftIO $ withResource pool $ \conn ->
+ query conn "SELECT id, name FROM users WHERE id = ANY(?)" (Only ids)
+ pure $ HM.fromList [(UserById (userId u), u) | u <- rows]
+```
+
+The `AppM` parameter is *your* monad. If it has access to a connection
+pool, config, or anything else, your data source has access to it too.
+No special environment setup is needed.
+
+If your backend doesn't support batch lookups (e.g. a REST API that only
+fetches one item at a time), implement `fetchOne` instead. sofetch will
+call it for each key:
+
+```haskell
+instance DataSource AppM UserById where
+ fetchOne (UserById uid) = lookupUserById uid
+```
+
+You still get deduplication and caching; you just don't get the batched
+SQL.
+
+### 3. Write data-access code
+
+Now use `fetch` in your application code. Program against the `MonadFetch`
+typeclass so your functions work with any implementation (production, tests,
+tracing):
+
+```haskell
+getUserFeed :: (MonadFetch m n, DataSource m UserById, DataSource m PostsByAuthor)
+ => Int -> n (User, [Post])
+getUserFeed uid =
+ (,) <$> fetch (UserById uid) <*> fetch (PostsByAuthor uid)
+```
+
+These two fetches are independent (`<*>`), so sofetch batches them into a
+single round. If you prefer do-notation, enable `ApplicativeDo` and write
+the equivalent:
+
+```haskell
+{-# LANGUAGE ApplicativeDo #-}
+
+getUserFeed uid = do
+ user <- fetch (UserById uid) -- batched together
+ posts <- fetch (PostsByAuthor uid) -- in one round
+ pure (user, posts)
+```
+
+Both forms produce identical batching behaviour.
+
+### 4. Run it
+
+```haskell
+handleRequest :: AppEnv -> Int -> IO (User, [Post])
+handleRequest env uid = runAppM env $ do
+ cfg <- fetchConfigIO
+ runFetch cfg (getUserFeed uid)
+```
+
+`fetchConfigIO` works for any `MonadUnliftIO` monad (which includes any
+`ReaderT env IO` stack, the most common pattern). It wires everything up
+automatically.
+
+### 5. Test it
+
+Swap the real data sources for canned data. No IO, no database:
+
+```haskell
+testGetUserFeed :: IO ()
+testGetUserFeed = do
+ let mocks = mockData @UserById [(UserById 1, testUser)]
+ <> mockData @PostsByAuthor [(PostsByAuthor 1, [testPost])]
+ (user, posts) <- runMockFetch @AppM mocks (getUserFeed 1)
+ assertEqual user testUser
+ assertEqual posts [testPost]
+```
+
+Because `getUserFeed` is polymorphic over `MonadFetch`, it runs unchanged
+against `MockFetch`. No special test wiring needed.
+
+## A real example: collapsing N+1 cascades
+
+Here's a scenario from the included SQLite example. A blog page needs to
+render three authors, each with their posts, each post with its comments,
+each comment with its author name. The functions are written independently
+at four different levels:
+
+```
+renderBlogPage fetches 3 authors
+ └─ renderAuthorProfile fetches posts for an author
+ └─ renderPostWithComments fetches comments for a post
+ └─ renderComment fetches the comment's author
+```
+
+Without sofetch, this is 25+ database queries. With sofetch, `traverse`
+automatically merges fetches at the same depth:
+
+```mermaid
+flowchart LR
+ subgraph R1 ["Round 1"]
+ A1["UserById 1, 2, 3"]
+ end
+ subgraph R2 ["Round 2"]
+ A2["PostsByAuthor 1, 2, 3"]
+ end
+ subgraph R3 ["Round 3"]
+ A3["CommentsByPost 1 … 7"]
+ end
+ subgraph R4 ["Round 4"]
+ A4["UserById 4, 5 (deduped)"]
+ end
+ R1 --> R2 --> R3 --> R4
+```
+
+**4 rounds, 4 SQL queries**, regardless of the data size. The functions
+never coordinate with each other. They don't know they're being composed.
+sofetch handles it.
+
+## Key features
+
+- **No GADTs.** Data sources are ordinary typeclasses. Key types use stock
+ `deriving`. If you've defined a newtype, you're 90% of the way to a data
+ source.
+- **Your monad, your resources.** `DataSource` is parameterised by your
+ monad, not some framework environment. Connection pools, config, whatever
+ your monad carries, your data sources have access to it. Missing
+ instances are compile-time errors, not runtime crashes.
+- **Monad transformer.** `Fetch m a` layers over your existing monad stack.
+ Drop it in without restructuring your application.
+- **Swappable implementations.** `MonadFetch` is the interface your
+ application code uses. Production, test, and traced implementations all
+ satisfy it. Swap without code changes.
+- **Extensible instrumentation.** `runLoopWith` lets you wrap each batch
+ round (e.g. with tracing spans). OpenTelemetry support lives in the
+ separate [`sofetch-otel`](./sofetch-otel) package.
+
+```mermaid
+flowchart TD
+ A["Application code"] -->|"programs against"| B["MonadFetch (typeclass)"]
+ B --> C["Fetch m
production"]
+ B --> D["MockFetch
testing"]
+ B --> E["TracedFetch
instrumentation"]
+ C --> F["DataSource instances
UserById · PostsByAuthor · …"]
+```
+
+## Combinators
+
+sofetch includes a toolkit for common patterns:
+
+| Combinator | What it does |
+|---|---|
+| `fetchAll keys` | Fetch a list of keys in one round |
+| `fetchThrough toKey items` | Extract a key from each item, fetch, pair back |
+| `fetchMap toKey combine items` | Like `fetchThrough` but transform the pair |
+| `fetchMaybe maybeKey` | Fetch if the key is present |
+| `fetchMapWith keys` | Fetch a collection, return a `HashMap` of results |
+| `filterA predicate items` | Applicative filter; all predicates batched |
+| `withDefault val action` | Return a default on any exception |
+| `pAnd` / `pOr` | Parallel short-circuiting boolean combinators |
+
+## Advanced usage
+
+### Shared cache across phases
+
+To preserve the cache across sequential computations, use `runFetch'` which
+returns the cache alongside the result:
+
+```haskell
+handleTwoPhases :: AppEnv -> IO [Post]
+handleTwoPhases env = runAppM env $ do
+ cfg <- fetchConfigIO
+
+ -- Phase 1: populate cache
+ (_users, cache) <- runFetch' cfg $
+ fetchAll [UserById 1, UserById 2, UserById 3]
+
+ -- Phase 2: cached keys resolve without hitting the DB
+ runFetch cfg { configCache = Just cache } $
+ fetchAll [PostsByAuthor 1, PostsByAuthor 2]
+```
+
+### Restricted monads (no MonadIO)
+
+For monads that deliberately hide IO (e.g. a `Transaction` type that
+prevents arbitrary IO inside database transactions), use `fetchConfig` with
+explicit natural transformations and export a safe runner:
+
+```haskell
+fetchInTransaction :: Fetch Transaction a -> Transaction a
+fetchInTransaction = runFetch (fetchConfig unsafeRunTransaction unsafeLiftIO)
+```
+
+The unsafe escape hatches stay private to your DB module. Application code
+calls `fetchInTransaction` and never touches IO.
+
+See `examples/SqliteBlog.hs` (scenario 12) for a worked proof-of-concept.
+
+## Examples
+
+The `examples/` directory contains two runnable programs:
+
+```bash
+stack build --flag sofetch:examples
+stack exec sqlite-blog
+stack exec github-explorer
+```
+
+**SQLite blog** (`examples/SqliteBlog.hs`): A blog platform backed by
+in-memory SQLite. Every `batchFetch` prints its SQL so you can see exactly
+how fetches are batched. Covers applicative batching, N+1 avoidance,
+deduplication, deep N+1 across function boundaries, faceted queries, chunked
+batching, shared caches, mocks, and restricted monads.
+
+**GitHub explorer** (`examples/GitHubExplorer.hs`): Concurrent exploration
+of the GitHub REST API. Demonstrates sofetch with HTTP backends where the
+value is concurrency, deduplication, and caching rather than SQL batching.
+
+## Packages
+
+| Package | Description |
+|---|---|
+| **sofetch** | Core library: `Fetch`, `DataSource`, `MonadFetch`, cache, engine, mocks, tracing hooks |
+| **[sofetch-otel](./sofetch-otel)** | OpenTelemetry instrumentation via `runFetchWithOTel` |
+
+## Modules
+
+| Module | Contents |
+|---|---|
+| `Fetch` | Top-level re-exports |
+| `Fetch.Class` | `FetchKey`, `DataSource`, `MonadFetch`, `MonadFetchBatch`, `Status`, `Batches` |
+| `Fetch.Batched` | `Fetch` monad transformer, runners, `runLoopWith` |
+| `Fetch.Engine` | Batch dispatch with strategy-based scheduling |
+| `Fetch.Cache` | IVar-based cache with dedup, eviction, warming |
+| `Fetch.IVar` | Write-once variable with error support |
+| `Fetch.Combinators` | `fetchAll`, `fetchThrough`, `fetchMap`, etc. |
+| `Fetch.Mock` | `MockFetch` for testing |
+| `Fetch.Traced` | `TracedFetch` with per-round callbacks |
+| `Fetch.Mutate` | `Mutate` for interleaved read-write computations |
+| `Fetch.Memo` | `MemoStore`, `memo`, `memoOn` |
+| `Fetch.Deriving` | Helpers for writing instances (`optionalBatchFetch`, DerivingVia docs) |
+
+## Design
+
+See [docs/DESIGN.md](./docs/DESIGN.md) for the full set of design decisions
+and tradeoffs.
+
+---
+
+sofetch is inspired by Facebook's [Haxl](https://github.com/facebook/Haxl)
+(Marlow et al., *There is no fork: an abstraction for efficient, concurrent,
+and concise data access*, ICFP 2014). It keeps the core idea (write
+sequential-looking code, get batched data access) while replacing the
+GADT-based data source API with type families and ordinary typeclasses, and
+using a monad-transformer design instead of a bespoke environment. See
+[DESIGN.md](./docs/DESIGN.md) for a detailed comparison.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/examples/GitHubExplorer.hs b/examples/GitHubExplorer.hs
new file mode 100644
--- /dev/null
+++ b/examples/GitHubExplorer.hs
@@ -0,0 +1,340 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RankNTypes #-}
+
+-- | Concurrent exploration of the GitHub REST API.
+--
+-- This example demonstrates sofetch with an HTTP backend where the
+-- value is concurrency, deduplication, and caching, not SQL batching.
+--
+-- Run it with:
+--
+-- @
+-- stack run github-explorer
+-- @
+--
+-- __Rate limit note:__ GitHub allows 60 unauthenticated requests per
+-- hour. This example uses ~15 requests against a handful of stable
+-- accounts. To raise the limit to 5,000/hour, set:
+--
+-- @
+-- export GITHUB_TOKEN=ghp_your_token_here
+-- @
+module Main (main) where
+
+import Fetch
+
+import Control.Exception (SomeException)
+import Control.Monad (when)
+import Data.Aeson ((.:), (.:?), withObject, FromJSON(..), eitherDecode')
+import Data.ByteString.Lazy (ByteString)
+import Data.IORef
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import GHC.Generics (Generic)
+import Network.HTTP.Client
+ ( Manager
+ , newManager, parseRequest, httpLbs, responseBody, responseStatus
+ , requestHeaders
+ )
+import Network.HTTP.Client.TLS (tlsManagerSettings)
+import Network.HTTP.Types.Status (statusCode)
+import System.Environment (lookupEnv)
+
+-- ══════════════════════════════════════════════
+-- Domain types (parsed from GitHub JSON)
+-- ══════════════════════════════════════════════
+
+data GitHubUser = GitHubUser
+ { ghUserLogin :: !Text
+ , ghUserName :: !(Maybe Text)
+ , ghUserPublicRepos :: !Int
+ , ghUserFollowers :: !Int
+ } deriving (Show, Eq, Generic)
+
+instance FromJSON GitHubUser where
+ parseJSON = withObject "GitHubUser" $ \o -> GitHubUser
+ <$> o .: "login"
+ <*> o .:? "name"
+ <*> o .: "public_repos"
+ <*> o .: "followers"
+
+data GitHubRepo = GitHubRepo
+ { ghRepoName :: !Text
+ , ghRepoStars :: !Int
+ , ghRepoLanguage :: !(Maybe Text)
+ , ghRepoFork :: !Bool
+ } deriving (Show, Eq, Generic)
+
+instance FromJSON GitHubRepo where
+ parseJSON = withObject "GitHubRepo" $ \o -> GitHubRepo
+ <$> o .: "name"
+ <*> o .: "stargazers_count"
+ <*> o .:? "language"
+ <*> o .: "fork"
+
+-- ══════════════════════════════════════════════
+-- FetchKey types
+-- ══════════════════════════════════════════════
+
+-- | Fetch a GitHub user profile by login name.
+newtype UserLogin = UserLogin Text
+ deriving stock (Eq, Ord, Show, Generic)
+ deriving anyclass (Hashable)
+
+instance FetchKey UserLogin where
+ type Result UserLogin = GitHubUser
+
+-- | Fetch the public repos for a GitHub user.
+newtype UserRepos = UserRepos Text
+ deriving stock (Eq, Ord, Show, Generic)
+ deriving anyclass (Hashable)
+
+instance FetchKey UserRepos where
+ type Result UserRepos = [GitHubRepo]
+
+-- ══════════════════════════════════════════════
+-- Application monad
+-- ══════════════════════════════════════════════
+
+-- | Environment: HTTP manager + optional auth token.
+data AppEnv = AppEnv
+ { envManager :: !Manager
+ , envToken :: !(Maybe Text)
+ }
+
+newtype AppM a = AppM { unAppM :: AppEnv -> IO a }
+
+instance Functor AppM where
+ fmap f (AppM g) = AppM $ \e -> fmap f (g e)
+
+instance Applicative AppM where
+ pure a = AppM $ \_ -> pure a
+ AppM ff <*> AppM fx = AppM $ \e -> ff e <*> fx e
+
+instance Monad AppM where
+ AppM ma >>= f = AppM $ \e -> do
+ a <- ma e
+ unAppM (f a) e
+
+askEnv :: AppM AppEnv
+askEnv = AppM pure
+
+liftIO :: IO a -> AppM a
+liftIO io = AppM $ \_ -> io
+
+runAppM :: AppEnv -> AppM a -> IO a
+runAppM env (AppM f) = f env
+
+-- ══════════════════════════════════════════════
+-- HTTP helpers
+-- ══════════════════════════════════════════════
+
+-- | Make an authenticated GET request to the GitHub API.
+-- Returns Nothing on non-200 responses (so per-key errors don't
+-- take down the entire batch).
+githubGet :: String -> AppM (Maybe ByteString)
+githubGet url = do
+ env <- askEnv
+ req <- Main.liftIO $ parseRequest url
+ let authHeaders = case envToken env of
+ Just tok -> [("Authorization", "token " <> TE.encodeUtf8 tok)]
+ Nothing -> []
+ req' = req
+ { requestHeaders =
+ ("User-Agent", "sofetch-example/0.1")
+ : ("Accept", "application/vnd.github.v3+json")
+ : authHeaders ++ requestHeaders req
+ }
+ Main.liftIO $ putStrLn $ " [HTTP] GET " <> url
+ resp <- Main.liftIO $ httpLbs req' (envManager env)
+ let code = statusCode (responseStatus resp)
+ if code == 200
+ then pure (Just (responseBody resp))
+ else do
+ Main.liftIO $ putStrLn $ " [HTTP] " <> show code <> " " <> url
+ pure Nothing
+
+-- ══════════════════════════════════════════════
+-- DataSource instances
+-- ══════════════════════════════════════════════
+
+-- | Each UserLogin key fires a separate HTTP request, but sofetch
+-- runs them concurrently (default FetchStrategy = Concurrent) and
+-- deduplicates across the computation.
+--
+-- Uses 'optionalBatchFetch': keys whose HTTP request fails are
+-- omitted from the result map. The engine fills them with an error
+-- so that 'tryFetch' returns @Left@ and 'fetch' throws, but
+-- successful keys are unaffected.
+instance DataSource AppM UserLogin where
+ batchFetch = optionalBatchFetch $ \(UserLogin login) -> do
+ mbs <- githubGet $ "https://api.github.com/users/" <> T.unpack login
+ case mbs of
+ Nothing -> pure Nothing
+ Just bs -> case eitherDecode' bs of
+ Right a -> pure (Just a)
+ Left err -> do
+ Main.liftIO $ putStrLn $ " [JSON] decode error: " <> err
+ pure Nothing
+
+instance DataSource AppM UserRepos where
+ batchFetch = optionalBatchFetch $ \(UserRepos login) -> do
+ mbs <- githubGet $ "https://api.github.com/users/" <> T.unpack login <> "/repos?per_page=5&sort=stars"
+ case mbs of
+ Nothing -> pure Nothing
+ Just bs -> case eitherDecode' bs of
+ Right a -> pure (Just a)
+ Left err -> do
+ Main.liftIO $ putStrLn $ " [JSON] decode error: " <> err
+ pure Nothing
+
+-- ══════════════════════════════════════════════
+-- Instrumented runner
+-- ══════════════════════════════════════════════
+
+-- | Run a Fetch computation with detailed round-by-round logging.
+runFetchIO :: AppEnv -> Fetch AppM a -> IO a
+runFetchIO env action = do
+ cRef <- newCacheRef
+ totalRoundsRef <- newIORef (0 :: Int)
+ totalKeysRef <- newIORef (0 :: Int)
+ totalHitsRef <- newIORef (0 :: Int)
+
+ let e = FetchEnv
+ { fetchCache = cRef
+ , fetchLower = runAppM env
+ , fetchLift = Main.liftIO
+ }
+
+ withRound n batches exec = do
+ let pending = batchSize batches
+ sources = batchSourceCount batches
+ Main.liftIO $ putStrLn $ " ┌─ Round " <> show n
+ <> ": " <> show pending <> " key(s) across "
+ <> show sources <> " source(s)"
+
+ stats <- exec
+
+ let dispatched = roundKeys stats - roundCacheHits stats
+ Main.liftIO $ do
+ when (roundCacheHits stats > 0) $
+ putStrLn $ " │ Cache: " <> show (roundCacheHits stats) <> " hit(s)"
+ putStrLn $ " │ Dispatched: " <> show dispatched <> " key(s) to data sources"
+ putStrLn $ " └─ Round " <> show n <> " complete"
+ modifyIORef' totalRoundsRef (+ 1)
+ modifyIORef' totalKeysRef (+ roundKeys stats)
+ modifyIORef' totalHitsRef (+ roundCacheHits stats)
+
+ a <- runAppM env $ runLoopWith e withRound action
+
+ rounds <- readIORef totalRoundsRef
+ keys <- readIORef totalKeysRef
+ hits <- readIORef totalHitsRef
+ putStrLn $ " ── Summary: " <> show rounds <> " round(s), "
+ <> show keys <> " key(s), "
+ <> show hits <> " cache hit(s)"
+ pure a
+
+-- ══════════════════════════════════════════════
+-- Scenarios
+-- ══════════════════════════════════════════════
+
+header :: String -> String -> IO ()
+header num desc = do
+ putStrLn ""
+ putStrLn $ "━━━ Scenario " <> num <> ": " <> desc <> " ━━━"
+
+showUser :: GitHubUser -> String
+showUser u = T.unpack (ghUserLogin u)
+ <> " (" <> maybe "?" T.unpack (ghUserName u)
+ <> ", " <> show (ghUserPublicRepos u) <> " repos"
+ <> ", " <> show (ghUserFollowers u) <> " followers)"
+
+main :: IO ()
+main = do
+ mgr <- newManager tlsManagerSettings
+ mToken <- lookupEnv "GITHUB_TOKEN"
+ let env = AppEnv mgr (T.pack <$> mToken)
+
+ putStrLn "sofetch GitHub Explorer"
+ putStrLn $ "Auth: " <> maybe "none (60 req/hour limit)" (const "token (5000 req/hour)") mToken
+
+ -- ── Scenario 1: Concurrent fetches ────────────
+ header "1" "Concurrent fetches"
+ putStrLn "Fetching two users in parallel (one round, two concurrent HTTP requests)."
+ (u1, u2) <- runFetchIO env $
+ (,) <$> fetch (UserLogin "haskell") <*> fetch (UserLogin "rust-lang")
+ putStrLn $ " => " <> showUser u1
+ putStrLn $ " => " <> showUser u2
+
+ -- ── Scenario 2: Monadic chain ─────────────────
+ header "2" "Monadic chain (2 rounds)"
+ putStrLn "Fetching a user, then their repos (data dependency forces 2 rounds)."
+ (user, repos) <- runFetchIO env $ do
+ u <- fetch (UserLogin "haskell") -- round 1
+ rs <- fetch (UserRepos (ghUserLogin u)) -- round 2
+ pure (u, rs)
+ putStrLn $ " => " <> showUser user
+ putStrLn $ " => Top repos: " <> show (map ghRepoName (take 3 repos))
+
+ -- ── Scenario 3: Fan-out ───────────────────────
+ header "3" "Fan-out (fetch many, then fan out)"
+ putStrLn "Fetching 3 users in round 1, then all their repos in round 2."
+ let logins = [UserLogin "haskell", UserLogin "rust-lang", UserLogin "golang"]
+ allRepos <- runFetchIO env $ do
+ users <- fetchAll logins -- round 1: 3 concurrent HTTP
+ fetchAll (map (UserRepos . ghUserLogin) users) -- round 2: 3 concurrent HTTP
+ putStrLn $ " => Repo counts: " <> show (map length allRepos)
+
+ -- ── Scenario 4: Deduplication + caching ───────
+ header "4" "Deduplication + caching"
+ putStrLn "Fetching 'haskell' from TWO code paths. Only ONE HTTP request fires."
+ putStrLn "Then fetching 'haskell' again in a later round: cache hit, no HTTP."
+ result <- runFetchIO env $ do
+ -- Both of these want UserLogin "haskell"; deduplicated into one request
+ (a, b) <- (,) <$> fetch (UserLogin "haskell") <*> fetch (UserLogin "haskell")
+ -- This monadic bind forces a new round, but the cache has the value
+ _ <- fetch (UserLogin "haskell") -- cache hit
+ pure (a, b)
+ putStrLn $ " => Got same user twice: " <> show (fst result == snd result)
+
+ -- ── Scenario 5: Error handling ────────────────
+ header "5" "Error handling (tryFetch)"
+ putStrLn "Fetching a nonexistent user alongside a real one."
+ (good, bad) <- runFetchIO env $
+ (,) <$> tryFetch (UserLogin "haskell")
+ <*> tryFetch (UserLogin "this-user-definitely-does-not-exist-404-sofetch")
+ case good of
+ Right u -> putStrLn $ " => Good: " <> showUser u
+ Left e -> putStrLn $ " => Good failed: " <> show e
+ case bad of
+ Right u -> putStrLn $ " => Bad: " <> showUser u
+ Left e -> putStrLn $ " => Bad (expected): " <> show (e :: SomeException)
+
+ -- ── Scenario 6: Combinators ───────────────────
+ header "6" "Combinators (fetchThrough, fetchMap)"
+ putStrLn "Using fetchThrough to pair logins with user profiles:"
+ let loginTexts = ["haskell", "rust-lang", "golang"] :: [Text]
+ paired <- runFetchIO env $
+ fetchThrough UserLogin loginTexts
+ mapM_ (\(login, u) -> putStrLn $ " => " <> T.unpack login
+ <> " -> " <> maybe "?" T.unpack (ghUserName u)) paired
+
+ putStrLn ""
+ putStrLn "Using fetchMap to extract just follower counts:"
+ counts <- runFetchIO env $
+ fetchMap UserLogin (\login u -> (login, ghUserFollowers u)) loginTexts
+ mapM_ (\(login, n) -> putStrLn $ " => " <> T.unpack login
+ <> ": " <> show n <> " followers") counts
+
+ putStrLn ""
+ putStrLn "Done!"
diff --git a/examples/SqliteBlog.hs b/examples/SqliteBlog.hs
new file mode 100644
--- /dev/null
+++ b/examples/SqliteBlog.hs
@@ -0,0 +1,827 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RankNTypes #-}
+
+-- | A blog platform backed by an in-memory SQLite database.
+--
+-- This example demonstrates how sofetch turns N+1 query cascades into
+-- batched SQL. Run it with:
+--
+-- @
+-- stack run sqlite-blog
+-- @
+--
+-- Each scenario prints the SQL queries that are executed, so you can
+-- see exactly how fetches are batched.
+module Main (main) where
+
+import Fetch
+
+import Control.Monad (when)
+import Control.Monad.Catch (MonadThrow(..), MonadCatch(..))
+import Data.IORef
+import Data.List (intercalate)
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.HashMap.Strict as HM
+import qualified Data.List.NonEmpty as NE
+import Database.SQLite.Simple
+import GHC.Generics (Generic)
+
+-- ══════════════════════════════════════════════
+-- Domain types
+-- ══════════════════════════════════════════════
+
+data User = User
+ { userId :: !Int
+ , userName :: !Text
+ } deriving (Show, Eq, Generic)
+
+instance FromRow User where
+ fromRow = User <$> field <*> field
+
+data Post = Post
+ { postId :: !Int
+ , postAuthorId :: !Int
+ , postTitle :: !Text
+ , postBody :: !Text
+ } deriving (Show, Eq, Generic)
+
+instance FromRow Post where
+ fromRow = Post <$> field <*> field <*> field <*> field
+
+data Comment = Comment
+ { commentId :: !Int
+ , commentPostId :: !Int
+ , commentAuthorId :: !Int
+ , commentBody :: !Text
+ } deriving (Show, Eq, Generic)
+
+instance FromRow Comment where
+ fromRow = Comment <$> field <*> field <*> field <*> field
+
+-- ══════════════════════════════════════════════
+-- FetchKey types
+-- ══════════════════════════════════════════════
+
+newtype UserById = UserById Int
+ deriving stock (Eq, Ord, Show, Generic)
+ deriving anyclass (Hashable)
+
+instance FetchKey UserById where
+ type Result UserById = User
+
+newtype PostById = PostById Int
+ deriving stock (Eq, Ord, Show, Generic)
+ deriving anyclass (Hashable)
+
+instance FetchKey PostById where
+ type Result PostById = Post
+
+newtype PostsByAuthor = PostsByAuthor Int
+ deriving stock (Eq, Ord, Show, Generic)
+ deriving anyclass (Hashable)
+
+instance FetchKey PostsByAuthor where
+ type Result PostsByAuthor = [Post]
+
+newtype CommentsByPost = CommentsByPost Int
+ deriving stock (Eq, Ord, Show, Generic)
+ deriving anyclass (Hashable)
+
+instance FetchKey CommentsByPost where
+ type Result CommentsByPost = [Comment]
+
+-- | Count of comments on a post (facet: lightweight aggregate).
+newtype CommentCountByPost = CommentCountByPost Int
+ deriving stock (Eq, Ord, Show, Generic)
+ deriving anyclass (Hashable)
+
+instance FetchKey CommentCountByPost where
+ type Result CommentCountByPost = Int
+
+-- | Most recent comment on a post (facet: preview snippet).
+newtype LatestCommentByPost = LatestCommentByPost Int
+ deriving stock (Eq, Ord, Show, Generic)
+ deriving anyclass (Hashable)
+
+instance FetchKey LatestCommentByPost where
+ type Result LatestCommentByPost = Maybe Comment
+
+-- ══════════════════════════════════════════════
+-- Application monad
+-- ══════════════════════════════════════════════
+
+-- | A thin Reader-over-IO carrying a SQLite connection.
+-- No MTL — just manual instances, same style as in the test suite.
+newtype AppM a = AppM { unAppM :: Connection -> IO a }
+
+instance Functor AppM where
+ fmap f (AppM g) = AppM $ \c -> fmap f (g c)
+
+instance Applicative AppM where
+ pure a = AppM $ \_ -> pure a
+ AppM ff <*> AppM fx = AppM $ \c -> ff c <*> fx c
+
+instance Monad AppM where
+ AppM ma >>= f = AppM $ \c -> do
+ a <- ma c
+ unAppM (f a) c
+
+askConn :: AppM Connection
+askConn = AppM pure
+
+liftIO :: IO a -> AppM a
+liftIO io = AppM $ \_ -> io
+
+runAppM :: Connection -> AppM a -> IO a
+runAppM conn (AppM f) = f conn
+
+-- ══════════════════════════════════════════════
+-- DataSource instances (batched SQL)
+-- ══════════════════════════════════════════════
+
+-- | Helper: build a SQL IN clause with the right number of placeholders.
+inClause :: Int -> Query
+inClause n = Query $ "(" <> T.intercalate "," (replicate n "?") <> ")"
+
+instance DataSource AppM UserById where
+ batchFetch keysNE = do
+ conn <- askConn
+ let keys = NE.toList keysNE
+ ids = [i | UserById i <- keys]
+ n = length ids
+ sql = "SELECT id, name FROM users WHERE id IN " <> inClause n
+ liftIO $ putStrLn $ " [SQL] SELECT id, name FROM users WHERE id IN ("
+ <> intercalate ", " (map show ids) <> ")"
+ rows <- liftIO $ query conn sql ids
+ pure $ HM.fromList [(UserById (userId u), u) | u <- rows]
+
+instance DataSource AppM PostById where
+ batchFetch keysNE = do
+ conn <- askConn
+ let keys = NE.toList keysNE
+ ids = [i | PostById i <- keys]
+ n = length ids
+ sql = "SELECT id, author_id, title, body FROM posts WHERE id IN " <> inClause n
+ liftIO $ putStrLn $ " [SQL] SELECT ... FROM posts WHERE id IN ("
+ <> intercalate ", " (map show ids) <> ")"
+ rows <- liftIO $ query conn sql ids
+ pure $ HM.fromList [(PostById (postId p), p) | p <- rows]
+
+instance DataSource AppM PostsByAuthor where
+ batchFetch keysNE = do
+ conn <- askConn
+ let keys = NE.toList keysNE
+ ids = [i | PostsByAuthor i <- keys]
+ n = length ids
+ sql = "SELECT id, author_id, title, body FROM posts WHERE author_id IN " <> inClause n
+ liftIO $ putStrLn $ " [SQL] SELECT ... FROM posts WHERE author_id IN ("
+ <> intercalate ", " (map show ids) <> ")"
+ rows <- liftIO $ query conn sql ids
+ -- Group posts by author_id
+ let grouped = HM.fromListWith (++) [(PostsByAuthor (postAuthorId p), [p]) | p <- rows]
+ -- Ensure every requested key has an entry (empty list if no posts)
+ pure $ HM.union grouped (HM.fromList [(k, []) | k <- keys])
+
+instance DataSource AppM CommentsByPost where
+ batchFetch keysNE = do
+ conn <- askConn
+ let keys = NE.toList keysNE
+ ids = [i | CommentsByPost i <- keys]
+ n = length ids
+ sql = "SELECT id, post_id, author_id, body FROM comments WHERE post_id IN " <> inClause n
+ liftIO $ putStrLn $ " [SQL] SELECT ... FROM comments WHERE post_id IN ("
+ <> intercalate ", " (map show ids) <> ")"
+ rows <- liftIO $ query conn sql ids
+ let grouped = HM.fromListWith (++) [(CommentsByPost (commentPostId c), [c]) | c <- rows]
+ pure $ HM.union grouped (HM.fromList [(k, []) | k <- keys])
+
+instance DataSource AppM CommentCountByPost where
+ batchFetch keysNE = do
+ conn <- askConn
+ let keys = NE.toList keysNE
+ ids = [i | CommentCountByPost i <- keys]
+ n = length ids
+ sql = "SELECT post_id, COUNT(*) FROM comments WHERE post_id IN "
+ <> inClause n <> " GROUP BY post_id"
+ liftIO $ putStrLn $ " [SQL] SELECT post_id, COUNT(*) FROM comments WHERE post_id IN ("
+ <> intercalate ", " (map show ids) <> ") GROUP BY post_id"
+ rows <- liftIO $ query conn sql ids :: AppM [(Int, Int)]
+ let counts = HM.fromList [(CommentCountByPost pid, cnt) | (pid, cnt) <- rows]
+ -- Posts with no comments won't appear in GROUP BY — default to 0
+ pure $ HM.union counts (HM.fromList [(k, 0) | k <- keys])
+
+instance DataSource AppM LatestCommentByPost where
+ batchFetch keysNE = do
+ conn <- askConn
+ let keys = NE.toList keysNE
+ ids = [i | LatestCommentByPost i <- keys]
+ n = length ids
+ -- Grab all comments for the requested posts, we'll pick the latest per post in Haskell.
+ -- (SQLite doesn't have a clean single-query "latest per group" for batched IN.)
+ sql = "SELECT id, post_id, author_id, body FROM comments WHERE post_id IN "
+ <> inClause n <> " ORDER BY id DESC"
+ liftIO $ putStrLn $ " [SQL] SELECT ... FROM comments WHERE post_id IN ("
+ <> intercalate ", " (map show ids) <> ") ORDER BY id DESC"
+ rows <- liftIO $ query conn sql ids
+ -- Take the first (latest by id) comment per post
+ let byPost = HM.fromListWith (\_ older -> older)
+ [(LatestCommentByPost (commentPostId c), c) | c <- rows]
+ withMaybe = HM.map Just byPost
+ pure $ HM.union withMaybe (HM.fromList [(k, Nothing) | k <- keys])
+
+-- | A key type that chunks its SQL IN clauses to avoid oversized queries.
+-- Same result as UserById, but the DataSource splits large batches.
+newtype UserByIdChunked = UserByIdChunked Int
+ deriving stock (Eq, Ord, Show, Generic)
+ deriving anyclass (Hashable)
+
+instance FetchKey UserByIdChunked where
+ type Result UserByIdChunked = User
+
+instance DataSource AppM UserByIdChunked where
+ batchFetch keysNE = do
+ conn <- askConn
+ let keys = NE.toList keysNE
+ ids = [i | UserByIdChunked i <- keys]
+ -- Chunk into groups of 50 to keep IN clauses manageable
+ chunks = chunksOf 50 ids
+ liftIO $ putStrLn $ " [SQL] Chunking " <> show (length ids)
+ <> " keys into " <> show (length chunks) <> " chunk(s) of <= 50"
+ results <- mapM (\chunk -> do
+ let n = length chunk
+ sql = "SELECT id, name FROM users WHERE id IN " <> inClause n
+ liftIO $ putStrLn $ " [SQL] chunk: SELECT id, name FROM users WHERE id IN (<"
+ <> show n <> " ids>)"
+ liftIO $ query conn sql chunk
+ ) chunks
+ pure $ HM.fromList [(UserByIdChunked (userId u), u) | u <- concat results]
+
+-- ══════════════════════════════════════════════
+-- Restricted DB monad (no MonadIO)
+-- ══════════════════════════════════════════════
+
+-- | A restricted monad mimicking Mercury's DB type.
+--
+-- Structurally identical to AppM (ReaderT Connection IO), but
+-- deliberately has NO MonadIO instance. Arbitrary IO inside
+-- database transactions is forbidden at the type level.
+--
+-- sofetch works perfectly with this pattern: the unsafe nats
+-- needed by the engine are private to the module that defines
+-- the runner. Application code never sees them.
+newtype DB a = DB { unDB :: Connection -> IO a }
+
+instance Functor DB where
+ fmap f (DB g) = DB $ \c -> fmap f (g c)
+
+instance Applicative DB where
+ pure a = DB $ \_ -> pure a
+ DB ff <*> DB fx = DB $ \c -> ff c <*> fx c
+
+instance Monad DB where
+ DB ma >>= f = DB $ \c -> do
+ a <- ma c
+ unDB (f a) c
+
+instance MonadThrow DB where
+ throwM e = DB $ \_ -> throwM e
+
+instance MonadCatch DB where
+ catch (DB f) handler = DB $ \c ->
+ catch (f c) (\e -> unDB (handler e) c)
+
+-- Intentionally NO MonadIO instance. Any code that tries
+-- @liftIO@ in DB gets a compile error: "No instance for MonadIO DB".
+-- In production (Mercury), a TypeError instance provides a custom
+-- message. Here the missing instance suffices.
+
+-- ── Escape hatches (private to your DB module) ──
+
+-- | Lift IO into DB. Not exported from your DB module in production.
+-- sofetch's engine needs this internally for cache and IVar operations.
+unsafeLiftIODB :: IO a -> DB a
+unsafeLiftIODB io = DB $ \_ -> io
+
+-- | Lower DB to IO, given a connection. Also not exported.
+unsafeRunDB :: Connection -> DB a -> IO a
+unsafeRunDB conn (DB f) = f conn
+
+-- ── DB-internal helpers (like askConn / liftIO for AppM) ──
+
+askConnDB :: DB Connection
+askConnDB = DB pure
+
+liftIODB :: IO a -> DB a
+liftIODB = unsafeLiftIODB
+
+-- ── DataSource instances for DB ─────────────
+
+instance DataSource DB UserById where
+ batchFetch keysNE = do
+ conn <- askConnDB
+ let keys = NE.toList keysNE
+ ids = [i | UserById i <- keys]
+ n = length ids
+ sql = "SELECT id, name FROM users WHERE id IN " <> inClause n
+ liftIODB $ putStrLn $ " [SQL] SELECT id, name FROM users WHERE id IN ("
+ <> intercalate ", " (map show ids) <> ")"
+ rows <- liftIODB $ query conn sql ids
+ pure $ HM.fromList [(UserById (userId u), u) | u <- rows]
+
+instance DataSource DB PostsByAuthor where
+ batchFetch keysNE = do
+ conn <- askConnDB
+ let keys = NE.toList keysNE
+ ids = [i | PostsByAuthor i <- keys]
+ n = length ids
+ sql = "SELECT id, author_id, title, body FROM posts WHERE author_id IN " <> inClause n
+ liftIODB $ putStrLn $ " [SQL] SELECT ... FROM posts WHERE author_id IN ("
+ <> intercalate ", " (map show ids) <> ")"
+ rows <- liftIODB $ query conn sql ids
+ let grouped = HM.fromListWith (++) [(PostsByAuthor (postAuthorId p), [p]) | p <- rows]
+ pure $ HM.union grouped (HM.fromList [(k, []) | k <- keys])
+
+-- ── The SAFE public runner ──────────────────
+
+-- | Run a Fetch computation inside the restricted DB monad.
+--
+-- This is the ONLY function your module exports. The unsafe nats
+-- (unsafeRunDB, unsafeLiftIODB) stay private. Application code
+-- writes against @MonadFetch DB n@ and never touches IO.
+--
+-- This is the pattern from the sofetch docs:
+--
+-- @
+-- fetchInTransaction :: Fetch Transaction a -> Transaction a
+-- fetchInTransaction = runFetchIO unsafeRunTransaction unsafeLiftIO
+-- @
+fetchInDB :: Fetch DB a -> DB a
+fetchInDB action = DB $ \conn ->
+ unsafeRunDB conn $ runFetch (fetchConfig (unsafeRunDB conn) unsafeLiftIODB) action
+
+-- ══════════════════════════════════════════════
+-- Polymorphic data-access functions
+-- ══════════════════════════════════════════════
+
+-- ──────────────────────────────────────────────
+-- Faceted search result card
+-- ──────────────────────────────────────────────
+
+-- | A search result card assembled from multiple independent facets.
+-- Each facet is a different data source; sofetch batches them all.
+data SearchCard = SearchCard
+ { cardTitle :: !Text
+ , cardAuthor :: !Text
+ , cardCommentCount :: !Int
+ , cardPreview :: !(Maybe Text) -- latest comment body, if any
+ } deriving (Show)
+
+-- | Build a search card for a single post. Four independent facets:
+-- 1. Post title/body (PostById)
+-- 2. Author name (UserById — depends on post's author_id)
+-- 3. Comment count (CommentCountByPost)
+-- 4. Latest comment (LatestCommentByPost)
+--
+-- Facets 1, 3, 4 are independent of each other and batch in one round.
+-- Facet 2 depends on knowing the author_id from facet 1, adding a second round.
+-- When called via 'traverse' across many post IDs, ALL posts' facets
+-- merge — so N posts still need at most 2 rounds, not 4*N queries.
+buildSearchCard
+ :: ( MonadFetch m n
+ , DataSource m PostById
+ , DataSource m UserById
+ , DataSource m CommentCountByPost
+ , DataSource m LatestCommentByPost
+ )
+ => Int -> n SearchCard
+buildSearchCard pid = do
+ -- Round 1: three independent facets batch together
+ (post, count, latest) <-
+ (,,) <$> fetch (PostById pid)
+ <*> fetch (CommentCountByPost pid)
+ <*> fetch (LatestCommentByPost pid)
+ -- Round 2: author lookup depends on the post's author_id
+ author <- fetch (UserById (postAuthorId post))
+ pure SearchCard
+ { cardTitle = postTitle post
+ , cardAuthor = userName author
+ , cardCommentCount = count
+ , cardPreview = fmap commentBody latest
+ }
+
+-- | Build search cards for a list of post IDs.
+-- All cards' facets batch across the entire list.
+buildSearchResults
+ :: ( MonadFetch m n
+ , DataSource m PostById
+ , DataSource m UserById
+ , DataSource m CommentCountByPost
+ , DataSource m LatestCommentByPost
+ )
+ => [Int] -> n [SearchCard]
+buildSearchResults = traverse buildSearchCard
+
+-- ──────────────────────────────────────────────
+
+-- | Fetch a user and their posts. Polymorphic over the fetch monad,
+-- so it works with both Fetch (production) and MockFetch (tests).
+getUserFeed
+ :: ( MonadFetch m n
+ , DataSource m UserById
+ , DataSource m PostsByAuthor
+ )
+ => Int -> n (User, [Post])
+getUserFeed uid = (,) <$> fetch (UserById uid) <*> fetch (PostsByAuthor uid)
+
+-- ──────────────────────────────────────────────
+-- Deep N+1: functions that compose across levels
+-- ──────────────────────────────────────────────
+
+-- Each function below is written independently — it doesn't know
+-- whether it will be called once or a thousand times. In a normal
+-- monadic framework, calling these in a loop creates an N+1 cascade
+-- (one query per iteration). With sofetch, traverse uses Applicative
+-- so all iterations at the same depth batch into a single round.
+
+-- | Level 3 (leaf): render one comment -> (body, authorName).
+-- Fetches the comment's author.
+renderComment
+ :: (MonadFetch m n, DataSource m UserById)
+ => Comment -> n (Text, Text)
+renderComment c = do
+ author <- fetch (UserById (commentAuthorId c))
+ pure (commentBody c, userName author)
+
+-- | Level 2: render a post with all its comments.
+-- Fetches comments, then traverses into renderComment.
+renderPostWithComments
+ :: (MonadFetch m n, DataSource m UserById, DataSource m CommentsByPost)
+ => Post -> n (Text, [(Text, Text)])
+renderPostWithComments p = do
+ comments <- fetch (CommentsByPost (postId p))
+ rendered <- traverse renderComment comments
+ pure (postTitle p, rendered)
+
+-- | Level 1: render an author's full profile.
+-- Fetches user + posts, then traverses into renderPostWithComments.
+renderAuthorProfile
+ :: ( MonadFetch m n
+ , DataSource m UserById
+ , DataSource m PostsByAuthor
+ , DataSource m CommentsByPost
+ )
+ => Int -> n (Text, [(Text, [(Text, Text)])])
+renderAuthorProfile uid = do
+ user <- fetch (UserById uid)
+ posts <- fetch (PostsByAuthor uid)
+ renderedPosts <- traverse renderPostWithComments posts
+ pure (userName user, renderedPosts)
+
+-- | Top level: render the blog page for multiple authors.
+-- Calls renderAuthorProfile for each — traverse batches them.
+renderBlogPage
+ :: ( MonadFetch m n
+ , DataSource m UserById
+ , DataSource m PostsByAuthor
+ , DataSource m CommentsByPost
+ )
+ => [Int] -> n [(Text, [(Text, [(Text, Text)])])]
+renderBlogPage = traverse renderAuthorProfile
+
+-- ══════════════════════════════════════════════
+-- Helpers
+-- ══════════════════════════════════════════════
+
+-- | Split a list into chunks of at most n elements.
+chunksOf :: Int -> [a] -> [[a]]
+chunksOf _ [] = []
+chunksOf n xs = let (chunk, rest) = splitAt n xs in chunk : chunksOf n rest
+
+-- ══════════════════════════════════════════════
+-- Database setup
+-- ══════════════════════════════════════════════
+
+setupDatabase :: Connection -> IO ()
+setupDatabase conn = do
+ execute_ conn "CREATE TABLE users (id INTEGER PRIMARY KEY, name TEXT NOT NULL)"
+ execute_ conn "CREATE TABLE posts (id INTEGER PRIMARY KEY, author_id INTEGER NOT NULL, title TEXT NOT NULL, body TEXT NOT NULL)"
+ execute_ conn "CREATE TABLE comments (id INTEGER PRIMARY KEY, post_id INTEGER NOT NULL, author_id INTEGER NOT NULL, body TEXT NOT NULL)"
+
+ -- 5 named users + 200 generated users for the chunking demo
+ let namedUsers :: [(Int, Text)]
+ namedUsers =
+ [ (1, "Alice"), (2, "Bob"), (3, "Carol")
+ , (4, "Dave"), (5, "Eve")
+ ]
+ generatedUsers = [(i, "User_" <> T.pack (show i)) | i <- [6..205]]
+ mapM_ (\(i, n) -> execute conn "INSERT INTO users VALUES (?, ?)" (i :: Int, n :: Text))
+ (namedUsers ++ generatedUsers)
+
+ -- 8 posts across 3 authors
+ let posts :: [(Int, Int, Text, Text)]
+ posts =
+ [ (1, 1, "Getting Started with Haskell", "Haskell is a purely functional language...")
+ , (2, 1, "Type Families Explained", "Type families let you compute types...")
+ , (3, 2, "Why I Love Rust", "Memory safety without GC...")
+ , (4, 2, "Async Rust Patterns", "Tokio makes async Rust ergonomic...")
+ , (5, 3, "Intro to Category Theory", "A category consists of objects and morphisms...")
+ , (6, 1, "Monad Transformers in Practice","Stacking monads with transformers...")
+ , (7, 3, "Functors Are Everywhere", "From Maybe to IO, functors are...")
+ , (8, 4, "SQLite Tips and Tricks", "SQLite is surprisingly powerful...")
+ ]
+ mapM_ (\(i, a, t, b) -> execute conn "INSERT INTO posts VALUES (?, ?, ?, ?)" (i :: Int, a :: Int, t :: Text, b :: Text)) posts
+
+ -- 12 comments, deliberately with overlapping authors across posts
+ let comments :: [(Int, Int, Int, Text)]
+ comments =
+ [ (1, 1, 2, "Great intro!")
+ , (2, 1, 3, "I learned a lot from this.")
+ , (3, 2, 2, "Type families are tricky but powerful.")
+ , (4, 2, 5, "Can you cover associated types next?")
+ , (5, 3, 1, "Interesting perspective on Rust.")
+ , (6, 3, 4, "How does it compare to Haskell?")
+ , (7, 4, 3, "Tokio is amazing.")
+ , (8, 5, 2, "Category theory is fascinating!")
+ , (9, 5, 4, "The diagrams really help.")
+ , (10, 6, 3, "Monad transformers clicked for me here.")
+ , (11, 7, 1, "Functors everywhere indeed!")
+ , (12, 8, 5, "I use SQLite for everything.")
+ ]
+ mapM_ (\(i, p, a, b) -> execute conn "INSERT INTO comments VALUES (?, ?, ?, ?)" (i :: Int, p :: Int, a :: Int, b :: Text)) comments
+
+-- ══════════════════════════════════════════════
+-- Instrumented runner
+-- ══════════════════════════════════════════════
+
+-- | Run a Fetch computation with detailed round-by-round logging.
+-- Shows round boundaries, key counts, sources dispatched, and cache hits.
+runFetchIO :: Connection -> Fetch AppM a -> IO a
+runFetchIO conn action = do
+ cRef <- newCacheRef
+ totalRoundsRef <- newIORef (0 :: Int)
+ totalKeysRef <- newIORef (0 :: Int)
+ totalHitsRef <- newIORef (0 :: Int)
+
+ let e = FetchEnv
+ { fetchCache = cRef
+ , fetchLower = runAppM conn
+ , fetchLift = Main.liftIO
+ }
+
+ withRound n batches exec = do
+ let pending = batchSize batches
+ sources = batchSourceCount batches
+ Main.liftIO $ putStrLn $ " \x250c\x2500 Round " <> show n
+ <> ": " <> show pending <> " key(s) across "
+ <> show sources <> " source(s)"
+
+ stats <- exec
+
+ let dispatched = roundKeys stats - roundCacheHits stats
+ Main.liftIO $ do
+ when (roundCacheHits stats > 0) $
+ putStrLn $ " \x2502 Cache: " <> show (roundCacheHits stats) <> " hit(s)"
+ putStrLn $ " \x2502 Dispatched: " <> show dispatched <> " key(s) to data sources"
+ putStrLn $ " \x2514\x2500 Round " <> show n <> " complete"
+ modifyIORef' totalRoundsRef (+ 1)
+ modifyIORef' totalKeysRef (+ roundKeys stats)
+ modifyIORef' totalHitsRef (+ roundCacheHits stats)
+
+ a <- runAppM conn $ runLoopWith e withRound action
+
+ rounds <- readIORef totalRoundsRef
+ keys <- readIORef totalKeysRef
+ hits <- readIORef totalHitsRef
+ putStrLn $ " \x2500\x2500 Summary: " <> show rounds <> " round(s), "
+ <> show keys <> " key(s), "
+ <> show hits <> " cache hit(s)"
+ pure a
+
+-- | Like 'runFetchIO' but with an externally-provided cache.
+-- Useful for sharing cache across multiple computations.
+runFetchIOWithCache :: Connection -> CacheRef -> Fetch AppM a -> IO a
+runFetchIOWithCache conn cRef action = do
+ let e = FetchEnv
+ { fetchCache = cRef
+ , fetchLower = runAppM conn
+ , fetchLift = Main.liftIO
+ }
+
+ withRound n batches exec = do
+ let pending = batchSize batches
+ sources = batchSourceCount batches
+ Main.liftIO $ putStrLn $ " \x250c\x2500 Round " <> show n
+ <> ": " <> show pending <> " key(s) across "
+ <> show sources <> " source(s)"
+
+ stats <- exec
+
+ let dispatched = roundKeys stats - roundCacheHits stats
+ Main.liftIO $ do
+ when (roundCacheHits stats > 0) $
+ putStrLn $ " \x2502 Cache: " <> show (roundCacheHits stats) <> " hit(s), skipped"
+ when (dispatched > 0) $
+ putStrLn $ " \x2502 Dispatched: " <> show dispatched <> " key(s) to data sources"
+ putStrLn $ " \x2514\x2500 Round " <> show n <> " complete"
+
+ runAppM conn $ runLoopWith e withRound action
+
+-- ══════════════════════════════════════════════
+-- Scenarios
+-- ══════════════════════════════════════════════
+
+header :: String -> String -> IO ()
+header num desc = do
+ putStrLn ""
+ putStrLn $ "\x2501\x2501\x2501 Scenario " <> num <> ": " <> desc <> " \x2501\x2501\x2501"
+
+main :: IO ()
+main = do
+ conn <- open ":memory:"
+ setupDatabase conn
+ putStrLn "Database seeded with 205 users, 8 posts, 12 comments."
+
+ -- ── Scenario 1: Single fetch ──────────────────
+ header "1" "Single fetch"
+ putStrLn "Fetching a single user by ID."
+ user <- runFetchIO conn $ fetch (UserById 1)
+ putStrLn $ " => " <> show user
+
+ -- ── Scenario 2: Applicative batching ──────────
+ header "2" "Applicative batching (two sources, one round)"
+ putStrLn "Fetching a user AND their posts in one round (two different sources)."
+ (u, ps) <- runFetchIO conn $
+ (,) <$> fetch (UserById 1) <*> fetch (PostsByAuthor 1)
+ putStrLn $ " => User: " <> show (userName u)
+ putStrLn $ " => Posts: " <> show (map postTitle ps)
+
+ -- ── Scenario 3: Monadic dependency ────────────
+ header "3" "Monadic dependency (2 rounds)"
+ putStrLn "Fetching a post, THEN its author (data dependency forces 2 rounds)."
+ (post, author) <- runFetchIO conn $ do
+ p <- fetch (PostById 3) -- round 1
+ a <- fetch (UserById (postAuthorId p)) -- round 2 (depends on post)
+ pure (p, a)
+ putStrLn $ " => Post: \"" <> T.unpack (postTitle post)
+ <> "\" by " <> T.unpack (userName author)
+
+ -- ── Scenario 4: N+1 avoidance ────────────────
+ header "4" "N+1 avoidance"
+ putStrLn "Fetching Alice's posts, then ALL comments for those posts in ONE batch."
+ putStrLn "(Without sofetch, this would be N separate queries.)"
+ allComments <- runFetchIO conn $ do
+ posts <- fetch (PostsByAuthor 1) -- round 1
+ fetchAll (map (CommentsByPost . postId) posts) -- round 2: ONE batch
+ putStrLn $ " => Comment counts per post: " <> show (map length allComments)
+
+ -- ── Scenario 5: Deduplication ────────────────
+ header "5" "Deduplication"
+ putStrLn "Fetching comments on posts 1 and 2. Bob (id=2) commented on both."
+ putStrLn "His user record should only be fetched ONCE."
+ authors <- runFetchIO conn $ do
+ -- Round 1: both comment fetches batch into ONE SQL query
+ (c1, c2) <- (,) <$> fetch (CommentsByPost 1) <*> fetch (CommentsByPost 2)
+ -- Round 2: author IDs are deduplicated — Bob only fetched once
+ let authorIds = map commentAuthorId (c1 ++ c2)
+ liftSource $ Main.liftIO $ putStrLn $ " \x2502 Raw author IDs: " <> show authorIds
+ <> " (4 refs, but Bob=2 appears twice)"
+ fetchAll (map UserById authorIds)
+ putStrLn $ " => Authors: " <> show (map userName authors)
+
+ -- ── Scenario 6: Combinators ──────────────────
+ header "6" "Combinators (fetchThrough, fetchMap)"
+ putStrLn "Using fetchThrough to enrich comments with their authors:"
+ enriched <- runFetchIO conn $ do
+ comments <- fetch (CommentsByPost 1)
+ fetchThrough (UserById . commentAuthorId) comments
+ mapM_ (\(c, author') -> putStrLn $ " => " <> T.unpack (commentBody c)
+ <> " -- " <> T.unpack (userName author')) enriched
+
+ putStrLn ""
+ putStrLn "Using fetchMap to get (title, authorName) from post IDs:"
+ results <- runFetchIO conn $
+ fetchMap PostById (\_ p -> (postTitle p, postAuthorId p)) [1, 3, 5]
+ mapM_ (\(title, aid) -> putStrLn $ " => \"" <> T.unpack title
+ <> "\" (author_id=" <> show aid <> ")") results
+
+ -- ── Scenario 7: Cache hits in action ──────────
+ header "7" "Cache hits in action"
+ putStrLn "Sharing a cache across TWO separate computations."
+ putStrLn "The second computation benefits from the first's cache."
+ cRef <- newCacheRef
+ -- First computation: fills the cache
+ putStrLn ""
+ putStrLn " First computation (cold cache) -- requesting UserById 1, 2:"
+ _ <- runFetchIOWithCache conn cRef $
+ (,) <$> fetch (UserById 1) <*> fetch (UserById 2)
+ -- Second computation: same cache
+ putStrLn ""
+ putStrLn " Second computation (warm cache) -- requesting UserById 1, 2, 3:"
+ putStrLn " Users 1 and 2 resolve instantly from cache. Only user 3 hits SQL."
+ _ <- runFetchIOWithCache conn cRef $
+ (,,) <$> fetch (UserById 1) <*> fetch (UserById 2) <*> fetch (UserById 3)
+ pure ()
+
+ -- ── Scenario 8: MockFetch ────────────────────
+ header "8" "MockFetch (same code, no database)"
+ putStrLn "Running getUserFeed against REAL SQLite:"
+ realResult <- runFetchIO conn $ getUserFeed 1
+ putStrLn $ " => " <> show (userName (fst realResult))
+ <> ", " <> show (length (snd realResult)) <> " posts"
+
+ putStrLn ""
+ putStrLn "Running the EXACT SAME function against MockFetch (canned data):"
+ let mockUser = User 1 "Mock Alice"
+ mockPosts = [Post 99 1 "Mock Post" "This is fake data"]
+ mocks = mockData @UserById [(UserById 1, mockUser)]
+ <> mockData @PostsByAuthor [(PostsByAuthor 1, mockPosts)]
+ mockResult <- runMockFetch @AppM mocks (getUserFeed 1)
+ putStrLn $ " => " <> show (userName (fst mockResult))
+ <> ", " <> show (length (snd mockResult)) <> " posts"
+
+ -- ── Scenario 9: Deep N+1 across function boundaries ──
+ header "9" "Deep N+1 across function boundaries"
+ putStrLn "renderBlogPage calls renderAuthorProfile for 3 authors,"
+ putStrLn "which calls renderPostWithComments for each post,"
+ putStrLn "which calls renderComment for each comment."
+ putStrLn ""
+ putStrLn "In a for-loop world this would be dozens of queries."
+ putStrLn "With sofetch, each depth level batches into ONE round:"
+ putStrLn ""
+ profiles <- runFetchIO conn $ renderBlogPage [1, 2, 3]
+ putStrLn ""
+ putStrLn " Results:"
+ mapM_ (\(authorName', postSummaries) -> do
+ putStrLn $ " " <> T.unpack authorName' <> ":"
+ mapM_ (\(title, commentSummaries) -> do
+ putStrLn $ " \"" <> T.unpack title <> "\" ("
+ <> show (length commentSummaries) <> " comments)"
+ ) postSummaries
+ ) profiles
+
+ -- ── Scenario 10: Chunked batching for large key sets ──
+ header "10" "Chunked batching for large key sets"
+ putStrLn "Fetching 200 users at once. The UserByIdChunked data source"
+ putStrLn "splits the IN clause into chunks of 50 to avoid oversized SQL."
+ putStrLn ""
+ users200 <- runFetchIO conn $
+ fetchAll (map UserByIdChunked [1..200])
+ putStrLn $ " => Fetched " <> show (length users200) <> " users"
+ putStrLn $ " => First: " <> show (take 1 users200)
+ putStrLn $ " => Last: " <> show (take 1 (reverse users200))
+
+ -- ── Scenario 11: Faceted queries ────────────────
+ header "11" "Faceted queries (search result cards)"
+ putStrLn "Building search result cards for 5 posts. Each card needs 4 facets:"
+ putStrLn " - post title/body (PostById)"
+ putStrLn " - author name (UserById, depends on post)"
+ putStrLn " - comment count (CommentCountByPost)"
+ putStrLn " - latest comment (LatestCommentByPost)"
+ putStrLn ""
+ putStrLn "For 5 posts, that's 20 potential queries. With sofetch:"
+ putStrLn " Round 1: all PostById + CommentCountByPost + LatestCommentByPost"
+ putStrLn " Round 2: all UserById (depends on author_id from round 1)"
+ putStrLn ""
+ cards <- runFetchIO conn $ buildSearchResults [1, 2, 3, 5, 8]
+ putStrLn ""
+ putStrLn " Results:"
+ mapM_ (\c -> putStrLn $ " \"" <> T.unpack (cardTitle c) <> "\""
+ <> " by " <> T.unpack (cardAuthor c)
+ <> " (" <> show (cardCommentCount c) <> " comments)"
+ <> maybe "" (\p -> " -- latest: \"" <> T.unpack p <> "\"") (cardPreview c)
+ ) cards
+
+ -- ── Scenario 12: Restricted DB monad (no MonadIO) ──
+ header "12" "Restricted DB monad (no MonadIO)"
+ putStrLn "The DB monad has NO MonadIO instance — arbitrary IO inside"
+ putStrLn "database transactions is a compile-time error."
+ putStrLn ""
+ putStrLn "sofetch works via fetchInDB, which hides the unsafe nats."
+ putStrLn "The same polymorphic getUserFeed function works in DB:"
+ putStrLn ""
+
+ -- getUserFeed is polymorphic: (MonadFetch m n, DataSource m UserById, ...)
+ -- It works with both AppM (via runFetchIO) and DB (via fetchInDB).
+ let runDB :: DB a -> IO a
+ runDB act = unsafeRunDB conn act
+
+ dbResult <- runDB $ fetchInDB $ getUserFeed 1
+ putStrLn $ " => User: " <> T.unpack (userName (fst dbResult))
+ putStrLn $ " => Posts: " <> show (length (snd dbResult))
+
+ -- Prove the TypeError works by showing the error message.
+ -- (Uncomment the line below to see the compile-time error:)
+ -- _ <- runDB $ Control.Monad.IO.Class.liftIO (putStrLn "this won't compile")
+
+ close conn
+ putStrLn ""
+ putStrLn "Done!"
diff --git a/sofetch.cabal b/sofetch.cabal
new file mode 100644
--- /dev/null
+++ b/sofetch.cabal
@@ -0,0 +1,141 @@
+cabal-version: 2.2
+
+-- This file has been generated from package.yaml by hpack version 0.38.1.
+--
+-- see: https://github.com/sol/hpack
+
+name: sofetch
+version: 0.1.0.0
+description: Please see the README on GitHub at
+homepage: https://github.com/iand675/sofetch#readme
+bug-reports: https://github.com/iand675/sofetch/issues
+author: Author name here
+maintainer: example@example.com
+copyright: 2026 Author name here
+license: BSD-3-Clause
+license-file: LICENSE
+build-type: Simple
+extra-source-files:
+ README.md
+ CHANGELOG.md
+
+source-repository head
+ type: git
+ location: https://github.com/iand675/sofetch
+
+flag examples
+ description: Build example executables
+ manual: True
+ default: False
+
+library
+ exposed-modules:
+ Fetch
+ Fetch.Batched
+ Fetch.Cache
+ Fetch.Class
+ Fetch.Combinators
+ Fetch.Deriving
+ Fetch.Engine
+ Fetch.IVar
+ Fetch.Memo
+ Fetch.Mock
+ Fetch.Mutate
+ Fetch.Traced
+ other-modules:
+ Paths_sofetch
+ autogen-modules:
+ Paths_sofetch
+ hs-source-dirs:
+ src
+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints
+ build-depends:
+ async
+ , base >=4.7 && <5
+ , containers
+ , exceptions
+ , hashable
+ , semigroupoids
+ , text
+ , time
+ , transformers
+ , unliftio-core
+ , unordered-containers
+ default-language: Haskell2010
+
+executable github-explorer
+ main-is: GitHubExplorer.hs
+ hs-source-dirs:
+ examples
+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded
+ build-depends:
+ aeson
+ , async
+ , base >=4.7 && <5
+ , bytestring
+ , containers
+ , exceptions
+ , hashable
+ , http-client
+ , http-client-tls
+ , http-types
+ , semigroupoids
+ , sofetch
+ , text
+ , time
+ , transformers
+ , unliftio-core
+ , unordered-containers
+ default-language: Haskell2010
+ if !flag(examples)
+ buildable: False
+
+executable sqlite-blog
+ main-is: SqliteBlog.hs
+ hs-source-dirs:
+ examples
+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded
+ build-depends:
+ async
+ , base >=4.7 && <5
+ , bytestring
+ , containers
+ , exceptions
+ , hashable
+ , semigroupoids
+ , sofetch
+ , sqlite-simple
+ , text
+ , time
+ , transformers
+ , unliftio-core
+ , unordered-containers
+ default-language: Haskell2010
+ if !flag(examples)
+ buildable: False
+
+test-suite sofetch-test
+ type: exitcode-stdio-1.0
+ main-is: Spec.hs
+ other-modules:
+ Paths_sofetch
+ autogen-modules:
+ Paths_sofetch
+ hs-source-dirs:
+ test
+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N
+ build-depends:
+ async
+ , base >=4.7 && <5
+ , containers
+ , exceptions
+ , hashable
+ , hspec
+ , semigroupoids
+ , sofetch
+ , text
+ , time
+ , transformers
+ , unliftio-core
+ , unordered-containers
+ default-language: Haskell2010
diff --git a/src/Fetch.hs b/src/Fetch.hs
new file mode 100644
--- /dev/null
+++ b/src/Fetch.hs
@@ -0,0 +1,456 @@
+{-# LANGUAGE TypeFamilies #-}
+
+-- | Automatic batching and deduplication of concurrent data fetches.
+--
+-- = Background
+--
+-- Any service that assembles responses from multiple data sources runs into
+-- the same problem: you write sequential-looking code, but the access
+-- pattern it produces is terrible. Fetching a user, then their posts, then
+-- the author of each post, produces a cascade of round trips: the classic
+-- N+1 query problem, generalised across arbitrary backends.
+--
+-- Facebook's [Haxl](https://github.com/facebook/Haxl) library (Marlow et al.,
+-- /\"There is no Fork: an Abstraction for Efficient, Concurrent, and Concise
+-- Data Access\"/, ICFP 2014) solved this by exploiting @Applicative@ to
+-- detect independent data fetches and batch them into a single round.
+-- Code that /looks/ sequential gets automatically optimised into concurrent,
+-- batched requests, with request deduplication and caching for free.
+--
+-- This library keeps Haxl's core idea while simplifying the machinery
+-- required to use it:
+--
+-- * __No GADTs in user code.__ Haxl encodes the request\/response type
+-- pairing with a GADT indexed by the result type. Here, an associated
+-- type family ('Result') on an ordinary typeclass ('FetchKey') does the
+-- same job. Your key types derive 'Eq', 'Hashable', and 'Show' with
+-- stock @deriving@.
+--
+-- * __Data sources run in your monad.__ 'DataSource' is parameterised by
+-- a monad @m@, not a concrete environment type. If your data source
+-- needs a connection pool, @m@ should be a monad with access to one
+-- (e.g. via 'MonadReader'). If the instance doesn't exist, code that
+-- tries to @fetch@ a key won't compile. No runtime "missing config"
+-- errors.
+--
+-- * __Monad transformer, not a concrete monad.__ Haxl's @GenHaxl u w@ is
+-- a fixed monad. 'Fetch' is a transformer over your source monad @m@.
+-- Two natural transformations (@m x -> IO x@ and @IO x -> m x@) provided
+-- at the run site bridge the source monad with IO for internal
+-- concurrency and caching.
+--
+-- * __Swappable implementations via 'MonadFetch'.__ Production code,
+-- traced instrumentation, and pure mock testing all share the same
+-- interface. Application functions are polymorphic over the implementation.
+--
+-- = How batching works
+--
+-- 'Fetch' has an 'Applicative' instance that /merges/ the pending fetches
+-- from both sides of @\<*\>@ into one round, and a 'Monad' instance where
+-- @>>=@ is a round boundary (the right side can't run until the left side's
+-- results are available).
+--
+-- With @ApplicativeDo@ enabled, GHC desugars @do@-blocks into 'Applicative'
+-- combinators wherever the data dependencies allow it. Two @fetch@ calls
+-- whose results are independent of each other will be combined into a
+-- single batch, even though they appear on separate lines:
+--
+-- @
+-- {-# LANGUAGE ApplicativeDo #-}
+--
+-- getUserFeed :: (MonadFetch m n, DataSource m UserId, DataSource m PostsByAuthor)
+-- => UserId -> n Feed
+-- getUserFeed uid = do
+-- user <- fetch uid -- ─┐
+-- posts <- fetch (PostsByAuthor uid) -- ─┤ same round
+-- pure (Feed user posts)
+-- @
+--
+-- If a later fetch /depends/ on an earlier result, @>>=@ forces a round
+-- boundary and the fetches run in sequence:
+--
+-- @
+-- getUserThenManager :: (MonadFetch m n, DataSource m UserId)
+-- => UserId -> n (User, User)
+-- getUserThenManager uid = do
+-- user <- fetch uid -- round 1
+-- manager <- fetch (managerId user) -- round 2 (depends on user)
+-- pure (user, manager)
+-- @
+--
+-- Within each round, keys destined for the same data source are grouped and
+-- passed to 'batchFetch' together. Keys for /different/ sources run
+-- concurrently by default (see 'FetchStrategy'). Duplicate keys are
+-- deduplicated across the entire computation.
+--
+-- = Tutorial
+--
+-- == Step 1: Define your key types
+--
+-- Each type of data you want to fetch gets its own key type with a
+-- 'FetchKey' instance that declares the result type:
+--
+-- @
+-- newtype UserId = UserId Int
+-- deriving (Eq, Hashable, Show)
+--
+-- instance FetchKey UserId where
+-- type Result UserId = User
+--
+-- newtype PostsByAuthor = PostsByAuthor Int
+-- deriving (Eq, Hashable, Show)
+--
+-- instance FetchKey PostsByAuthor where
+-- type Result PostsByAuthor = [Post]
+-- @
+--
+-- Each key type maps to exactly one result type. Separate types per query
+-- give you stock @deriving@, first-class 'Data.HashMap.Strict.HashMap' keys, and
+-- precise constraints: a function's type signature advertises exactly
+-- which data sources it touches.
+--
+-- == Step 2: Define your data sources
+--
+-- A 'DataSource' instance tells the engine how to batch-fetch a list of
+-- keys. The monad @m@ provides any resources the source needs:
+--
+-- @
+-- data AppEnv = AppEnv
+-- { appPool :: ConnectionPool
+-- , appRedis :: RedisConn
+-- }
+--
+-- -- AppM is a ReaderT-like monad carrying the environment.
+-- newtype AppM a = AppM (ReaderT AppEnv IO a)
+--
+-- instance DataSource AppM UserId where
+-- batchFetch ids = do
+-- pool <- asks appPool
+-- liftIO $ withResource pool $ \\conn -> do
+-- rows <- query conn \"SELECT id, name FROM users WHERE id = ANY(?)\" (Only ids)
+-- pure (HM.fromList [(UserId i, User i n) | (i, n) <- rows])
+--
+-- instance DataSource AppM PostsByAuthor where
+-- batchFetch ks = do
+-- pool <- asks appPool
+-- liftIO $ withResource pool $ \\conn -> do
+-- let authorIds = [aid | PostsByAuthor aid <- ks]
+-- rows <- query conn \"SELECT author_id, id, body FROM posts WHERE author_id = ANY(?)\" (Only authorIds)
+-- let grouped = HM.fromListWith (<>) [(PostsByAuthor aid, [Post pid body]) | (aid, pid, body) <- rows]
+-- pure grouped
+-- @
+--
+-- The return type is @'Data.HashMap.Strict.HashMap' k ('Result' k)@: you must return
+-- a result for every key you were given. The engine handles concurrency,
+-- caching, and error wrapping around your function.
+--
+-- If the @DataSource AppM SomeKey@ instance doesn't exist, any code that
+-- tries to @fetch@ a @SomeKey@ will fail to compile. There are no runtime
+-- \"missing config\" errors.
+--
+-- == Step 3: Write data-access code
+--
+-- Program against the 'MonadFetch' constraint. Don't commit to a specific
+-- implementation. This is what makes the same code runnable in production
+-- and in tests:
+--
+-- @
+-- {-# LANGUAGE ApplicativeDo #-}
+--
+-- getUserFeed :: (MonadFetch m n, DataSource m UserId, DataSource m PostsByAuthor)
+-- => UserId -> n Feed
+-- getUserFeed uid = do
+-- user <- fetch uid
+-- posts <- fetch (PostsByAuthor uid)
+-- pure (Feed user posts)
+-- @
+--
+-- For fetching across collections, use the provided combinators to preserve
+-- the container shape without manual destructure\/reconstruct cycles:
+--
+-- @
+-- enrichComments :: (MonadFetch m n, DataSource m CommentAuthor)
+-- => [Comment] -> n [(Comment, User)]
+-- enrichComments = fetchThrough commentAuthor
+-- @
+--
+-- == Step 4: Run it
+--
+-- In production, use 'runFetch' with two natural transformations: one
+-- to lower @m@ to @IO@, and one to lift @IO@ into @m@:
+--
+-- @
+-- handleRequest :: AppEnv -> UserId -> IO Feed
+-- handleRequest env uid =
+-- runAppM env $ runFetch (runAppM env) liftIO (getUserFeed uid)
+-- @
+--
+-- For monads that deliberately avoid 'MonadIO' (e.g. a @Transaction@
+-- type), export a convenience runner that hides the unsafe nats:
+--
+-- @
+-- fetchInTransaction :: Fetch Transaction a -> Transaction a
+-- fetchInTransaction = runFetch unsafeRunTransaction unsafeLiftIO
+-- @
+--
+-- == Step 5: Test it
+--
+-- Use 'MockFetch' to run the same code against canned data, with no IO,
+-- no database, and no cache:
+--
+-- @
+-- testGetUserFeed :: IO ()
+-- testGetUserFeed = do
+-- let mocks = mockData \@UserId [(UserId 1, testUser)]
+-- <> mockData \@PostsByAuthor [(PostsByAuthor 1, [testPost])]
+-- feed <- runMockFetch \@AppM mocks (getUserFeed (UserId 1))
+-- assertEqual (feedUser feed) testUser
+-- @
+--
+-- Because @getUserFeed@ is polymorphic in @n@, no code changes are needed
+-- to swap between 'Fetch' (production) and 'MockFetch' (tests).
+--
+-- = Error handling
+--
+-- If 'batchFetch' throws for a subset of keys, the engine fills unfilled
+-- entries with the exception. Callers using 'fetch' see the exception
+-- re-thrown; callers using 'tryFetch' receive @Left SomeException@.
+-- Failures for one key do not affect other keys in the same batch.
+--
+-- All monad transformers ('Fetch', 'TracedFetch', 'Mutate',
+-- 'MockFetch', 'MockMutate') provide @MonadThrow@ and @MonadCatch@
+-- instances from the @exceptions@ package. The 'MonadCatch' instance
+-- on 'Fetch' propagates the handler through 'Blocked' continuations,
+-- so a @catch@ wrapping a multi-round computation catches exceptions
+-- thrown in any round, not just the initial probe.
+--
+-- @
+-- import "Control.Monad.Catch" ('Control.Monad.Catch.catch', 'Control.Monad.Catch.throwM')
+--
+-- safeFetch :: ('MonadFetch' m n, 'Control.Monad.Catch.MonadCatch' n, DataSource m k, Typeable (Result k))
+-- => k -> Result k -> n (Result k)
+-- safeFetch k fallback =
+-- 'Control.Monad.Catch.catch' (fetch k) (\\(_ :: SomeException) -> pure fallback)
+-- @
+--
+-- @MonadMask@ is intentionally not provided: async exception masking
+-- across batch round boundaries is not well-defined.
+--
+-- = Further reading
+--
+-- * 'FetchStrategy': control whether a source runs concurrently,
+-- sequentially, or with eager start.
+-- * 'CachePolicy': opt out of caching for mutation-like sources.
+-- * 'TracedFetch': round-by-round observability hooks.
+-- * 'runLoopWith': build custom instrumented runners (e.g. for
+-- OpenTelemetry) by wrapping around each batch round.
+-- * 'MemoStore': cache derived computations (not just raw fetches).
+-- * The @docs/DESIGN.md@ in the repository covers the full set of design
+-- decisions and tradeoffs relative to Haxl.
+module Fetch
+ ( -- * Defining data sources
+ -- | Start here. A 'FetchKey' pairs a key type with its result type;
+ -- a 'DataSource' teaches the engine how to batch-fetch those keys.
+ FetchKey(..)
+ , DataSource(..)
+ , FetchStrategy(..)
+ , CachePolicy(..)
+
+ -- * Fetching data
+ -- | The interface your application code programs against.
+ -- Use 'fetch' to request a single key, 'tryFetch' for explicit error
+ -- handling, and the combinators below for collections.
+ , MonadFetch(..)
+ , fetchAll
+ , fetchWith
+ , fetchThrough
+ , fetchMap
+ , fetchMaybe
+ , fetchMapWith
+
+ -- * Running
+ -- | Execute a 'MonadFetch' computation via 'FetchConfig'.
+ , Fetch
+ , FetchConfig(..)
+ , fetchConfig
+ , fetchConfigIO
+ , liftSource
+ , runFetch
+ , runFetch'
+
+ -- * Testing
+ -- | Swap 'Fetch' for 'MockFetch' to run the same polymorphic code
+ -- against canned data: no IO, no database, no cache.
+ , MockFetch
+ , runMockFetch
+ , ResultMap
+ , mockData
+ , emptyMockData
+
+ -- * Mutations
+ -- | Mutations model write operations: creating a row, publishing a
+ -- message, calling a side-effecting RPC. Unlike fetches, mutations are
+ -- never batched, deduplicated, or cached: each 'mutate' call executes
+ -- exactly once, in order.
+ --
+ -- 'Mutate' layers on top of 'Fetch'. A computation alternates between
+ -- __fetch phases__ (where reads batch normally via 'Applicative') and
+ -- __mutation steps__ (where writes run sequentially). After each
+ -- mutation, 'reconcileCache' lets you evict stale entries or warm
+ -- fresh data so that subsequent fetches see the updated state.
+ --
+ -- __Caveat:__ by mixing reads and writes in the same computation, you
+ -- take on the responsibility of keeping the fetch cache coherent.
+ -- The engine cannot know which cached entries a mutation invalidates;
+ -- that is domain knowledge only you have. If you forget to evict or
+ -- re-warm a stale entry in 'reconcileCache', subsequent fetches will
+ -- silently return the old value. For many applications the simpler
+ -- approach is to keep mutations in plain @IO@ and use 'Fetch' only
+ -- for the read path; 'Mutate' is there for cases where interleaved
+ -- read-after-write within a single computation is genuinely needed.
+
+ -- ** Defining mutations
+ , MutationKey(..)
+ , MutationSource(..)
+
+ -- ** Running mutations
+ , MonadMutate(..)
+ , Mutate
+ , runMutate
+ , liftFetch
+
+ -- ** Testing mutations
+ , MockMutate
+ , runMockMutate
+ , MutationHandlers
+ , mockMutation
+ , emptyMutationHandlers
+ , RecordedMutation(..)
+
+ -- * Cache management
+ -- | Most users never touch the cache directly; the engine manages it.
+ -- These are useful for pre-warming from an external store, selective
+ -- eviction after mutations, or sharing a cache across sequential phases.
+ , CacheRef
+ , newCacheRef
+ , CacheLookup(..)
+ , cacheLookup
+ , cacheInsert
+ , cacheInsertError
+ , cacheEvict
+ , cacheEvictSource
+ , cacheEvictWhere
+ , cacheWarm
+ , cacheContents
+
+ -- * Tracing and observability
+ -- | 'TracedFetch' is a turnkey wrapper with per-round callbacks.
+ -- For richer instrumentation (e.g. OpenTelemetry spans), build a
+ -- custom runner using the extension API below.
+ , TracedFetch
+ , TraceConfig(..)
+ , defaultTraceConfig
+ , FetchStats(..)
+ , runTracedFetch
+
+ -- * Memoization
+ -- | Cache derived computations (not just raw fetches) within a request.
+ , MemoKey(..)
+ , MemoStore
+ , newMemoStore
+ , memo
+ , memoOn
+
+ -- * Errors
+ , FetchError(..)
+
+ -- * Extension API
+ -- | Building blocks for custom runners and instrumentation.
+ -- Application code does not need anything from this section.
+ --
+ -- The simplest way to add instrumentation is 'runLoopWith', which
+ -- lets you wrap each batch round with before\/after logic (e.g.
+ -- opening and closing a tracing span):
+ --
+ -- @
+ -- import Fetch.Batched ('FetchEnv'(..), 'runLoopWith')
+ -- import Fetch.Engine ('RoundStats'(..))
+ --
+ -- myInstrumentedRunner :: Monad m
+ -- => (forall x. m x -> IO x)
+ -- -> (forall x. IO x -> m x)
+ -- -> Fetch m a -> m a
+ -- myInstrumentedRunner lower lift action = do
+ -- cRef <- lift 'newCacheRef'
+ -- let e = 'FetchEnv' cRef lower lift
+ -- 'runLoopWith' e (\\n batches exec -> do
+ -- -- before round
+ -- stats <- exec
+ -- -- after round, stats :: 'RoundStats'
+ -- pure ()
+ -- ) action
+ -- @
+ --
+ -- For full control (e.g. running entirely in @IO@ with a single
+ -- @lift@ at the boundary), use 'Fetch'\'s constructor, 'FetchEnv',
+ -- and 'executeBatches' directly.
+
+ -- ** Loop helpers
+ , FetchEnv(..)
+ , runLoop
+ , runLoopWith
+ , RoundStats(..)
+ , emptyRoundStats
+
+ -- ** Batch inspection
+ , MonadFetchBatch(..)
+ , Status(..)
+ , Batches(..)
+ , batchSize
+ , batchSourceCount
+
+ -- ** Engine
+ , executeBatches
+
+ -- * Instance helpers
+ -- | Combinators for implementing 'DataSource' from simpler primitives.
+ -- See also 'fetchOne' (a default method on 'DataSource') and the
+ -- "Fetch.Deriving" module for DerivingVia patterns.
+ , optionalBatchFetch
+ , traverseBatchFetch
+
+ -- * Re-exports
+ , Typeable
+ , Hashable
+ , NonEmpty(..)
+ , Proxy(..)
+ ) where
+
+import Fetch.Class
+import Fetch.Batched
+ ( Fetch, FetchConfig(..), fetchConfig, fetchConfigIO, FetchEnv(..), liftSource
+ , runFetch, runFetch'
+ , runLoop, runLoopWith
+ )
+import Fetch.Cache
+ ( CacheRef, newCacheRef
+ , CacheLookup(..), cacheLookup
+ , cacheInsert, cacheInsertError
+ , cacheEvict, cacheEvictSource, cacheEvictWhere
+ , cacheWarm, cacheContents
+ )
+import Fetch.Combinators
+import Fetch.Deriving (optionalBatchFetch, traverseBatchFetch)
+import Fetch.Engine (RoundStats(..), emptyRoundStats, executeBatches)
+import Fetch.Mutate
+ ( MutationSource(..), MonadMutate(..)
+ , Mutate, runMutate, liftFetch
+ )
+import Fetch.Mock
+ ( MockFetch, runMockFetch, ResultMap, mockData, emptyMockData
+ , MockMutate, runMockMutate, MutationHandlers, mockMutation
+ , emptyMutationHandlers, RecordedMutation(..)
+ )
+import Fetch.Traced (TracedFetch, TraceConfig(..), defaultTraceConfig, FetchStats(..), runTracedFetch)
+import Fetch.Memo (MemoKey(..), MemoStore, newMemoStore, memo, memoOn)
+import Fetch.IVar (FetchError(..))
diff --git a/src/Fetch/Batched.hs b/src/Fetch/Batched.hs
new file mode 100644
--- /dev/null
+++ b/src/Fetch/Batched.hs
@@ -0,0 +1,456 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE BangPatterns #-}
+
+module Fetch.Batched
+ ( Fetch(..)
+ , FetchConfig(..)
+ , fetchConfig
+ , fetchConfigIO
+ , FetchEnv(..)
+ , liftSource
+ , runFetch
+ , runFetch'
+ , runLoop
+ , runLoopWith
+ ) where
+
+import Fetch.Class
+import Fetch.Cache
+import Fetch.IVar
+import Fetch.Engine
+
+import Control.Exception (throwIO, toException)
+import Control.Monad.Catch (MonadThrow(..), MonadCatch(..))
+import Control.Monad.IO.Unlift (MonadUnliftIO(..), liftIO)
+import Data.Functor.Apply (Apply(..))
+import Data.Functor.Bind (Bind(..))
+import qualified Data.HashMap.Strict as HM
+
+-- | The environment threaded through Fetch.
+--
+-- Contains the cache and the two natural transformations that
+-- bridge the source monad @m@ with @IO@.
+data FetchEnv m = FetchEnv
+ { fetchCache :: !CacheRef
+ , fetchLower :: !(forall x. m x -> IO x)
+ -- ^ Run an @m@ action in @IO@. Used by the engine to
+ -- dispatch @batchFetch@ calls.
+ , fetchLift :: !(forall x. IO x -> m x)
+ -- ^ Lift an @IO@ action into @m@. Used for cache operations
+ -- and IVar interactions within @m@.
+ }
+
+-- | The core monad transformer. Supports Applicative batching:
+-- independent fetches in @\<*\>@ merge into a single round,
+-- while @>>=@ introduces a round boundary.
+--
+-- The @m@ parameter is the /source monad/: the monad that
+-- 'DataSource' implementations run in.
+--
+-- Enable @ApplicativeDo@ for ergonomic batching in do-blocks.
+newtype Fetch m a = Fetch
+ { unFetch :: FetchEnv m -> m (Status m (Fetch m) a) }
+
+-- | Lift a source-monad action into 'Fetch'.
+liftSource :: Monad m => m a -> Fetch m a
+liftSource ma = Fetch $ \_ -> Done <$> ma
+
+instance Functor m => Functor (Fetch m) where
+ fmap f (Fetch g) = Fetch $ \e -> fmap (fmap f) (g e)
+
+instance Monad m => Applicative (Fetch m) where
+ pure a = Fetch $ \_ -> pure (Done a)
+
+ Fetch ff <*> Fetch fx = Fetch $ \e -> do
+ sf <- ff e
+ sx <- fx e
+ pure $ case (sf, sx) of
+ (Done f, Done x) ->
+ Done (f x)
+ (Done f, Blocked bs kx) ->
+ Blocked bs (fmap f kx)
+ (Blocked bs kf, Done x) ->
+ Blocked bs (fmap ($ x) kf)
+ (Blocked bs1 kf, Blocked bs2 kx) ->
+ Blocked (bs1 <> bs2) (kf <*> kx)
+
+instance Monad m => Monad (Fetch m) where
+ Fetch ma >>= f = Fetch $ \e -> do
+ sa <- ma e
+ case sa of
+ Done a -> unFetch (f a) e
+ Blocked bs k -> pure $ Blocked bs (k >>= f)
+
+instance MonadFail m => MonadFail (Fetch m) where
+ fail = liftSource . fail
+
+-- ──────────────────────────────────────────────
+-- MonadThrow / MonadCatch
+-- ──────────────────────────────────────────────
+
+instance MonadThrow m => MonadThrow (Fetch m) where
+ throwM = liftSource . throwM
+
+-- | Propagates the handler through 'Blocked' continuations so that
+-- a @catch@ wrapping a multi-round computation catches exceptions
+-- thrown in any round, not just the initial probe.
+instance MonadCatch m => MonadCatch (Fetch m) where
+ catch (Fetch f) handler = Fetch $ \e -> do
+ status <- catch (f e) (\ex -> unFetch (handler ex) e)
+ case status of
+ Done a -> pure (Done a)
+ Blocked bs k -> pure (Blocked bs (catch k handler))
+
+-- ──────────────────────────────────────────────
+-- Semigroup / Monoid (lifted)
+-- ──────────────────────────────────────────────
+
+-- | Combines two fetches applicatively, batching their pending keys.
+--
+-- @a <> b = liftA2 (<>) a b@
+instance (Monad m, Semigroup a) => Semigroup (Fetch m a) where
+ (<>) = liftA2 (<>)
+
+-- | @mempty = pure mempty@.
+instance (Monad m, Monoid a) => Monoid (Fetch m a) where
+ mempty = pure mempty
+
+-- ──────────────────────────────────────────────
+-- Semigroupoids (Apply / Bind)
+-- ──────────────────────────────────────────────
+
+-- | 'Apply' is 'Applicative' without 'pure'. Same batching semantics.
+instance Monad m => Apply (Fetch m) where
+ (<.>) = (<*>)
+
+-- | 'Bind' is 'Monad' without 'return'. Same round-boundary semantics.
+instance Monad m => Bind (Fetch m) where
+ (>>-) = (>>=)
+
+-- ──────────────────────────────────────────────
+-- Instances that are NOT provided (and why)
+-- ──────────────────────────────────────────────
+
+-- MonadTrans / MonadIO:
+-- Intentionally omitted. @lift@ / @liftIO@ would be equivalent to
+-- 'liftSource', but having them available via the standard typeclasses
+-- makes it too easy to accidentally run source-monad actions during
+-- the probe phase — bypassing the batching system and potentially
+-- introducing writes outside of 'Mutate'\'s cache reconciliation.
+-- Use 'liftSource' when you explicitly need to lift an @m@ action.
+--
+-- MFunctor / hoist (mmorph):
+-- NOT possible. 'Batches m' carries existential @DataSource m k@
+-- constraints. Changing @m@ to @n@ requires re-proving those
+-- constraints for @n@, which cannot be done generically.
+--
+-- MonadReader r:
+-- 'ask' would work via @lift ask@, but 'local' cannot propagate
+-- through batch dispatch. The 'fetchLower' nat in 'FetchEnv'
+-- captures the reader environment at the run site; 'local' inside
+-- a 'Fetch' computation would only affect the probe phase, not
+-- the 'batchFetch' calls dispatched by the engine. Providing a
+-- 'MonadReader' instance with broken 'local' would violate the
+-- class laws, so we omit it entirely.
+--
+-- MonadBaseControl / MonadUnliftIO:
+-- NOT possible. 'Fetch' is continuation-based: a 'Blocked' status
+-- carries thunks that close over the 'FetchEnv' (which contains
+-- mutable 'CacheRef' state). There is no way to capture this as a
+-- pure @StM@ value and restore it.
+--
+-- MonadMask:
+-- Intentionally omitted. Async exception masking across batch
+-- round boundaries is not well-defined. A @mask@ would need to
+-- protect both the probe and all subsequent rounds, but rounds
+-- execute in IO via 'executeBatches' which uses 'async' internally.
+
+-- ──────────────────────────────────────────────
+-- Cache lookup helper
+-- ──────────────────────────────────────────────
+
+-- | Look up a key in the cache, awaiting any pending IVar.
+-- Returns @Right v@ on hit, @Left ex@ on error/miss.
+-- The @onMiss@ fallback is invoked (in @m@) when the key is absent.
+lookupOrAwait :: (FetchKey k, Typeable (Result k), Monad m)
+ => FetchEnv m -> k -> m (Either SomeException (Result k))
+ -> m (Either SomeException (Result k))
+lookupOrAwait e k onMiss = do
+ hit <- fetchLift e $ cacheLookup (fetchCache e) k
+ case hit of
+ CacheHitReady v -> pure (Right v)
+ CacheHitPending iv -> fetchLift e $ awaitIVar iv
+ CacheMiss -> onMiss
+
+-- ──────────────────────────────────────────────
+-- MonadFetch instance
+-- ──────────────────────────────────────────────
+
+instance Monad m => MonadFetch m (Fetch m) where
+ fetch (k :: k) = Fetch $ \e ->
+ -- NoCaching semantics: skip the cache check entirely and always
+ -- return Blocked. This guarantees that every >>= round dispatches
+ -- a fresh batch for this key. The engine's dispatchUncached uses
+ -- cacheAllocateForce to overwrite any stale IVar from a prior
+ -- round, so the continuation below always reads a fresh result.
+ --
+ -- Within a single applicative round, dedup still works: the
+ -- HashSet in SomeBatch merges duplicate keys, and all
+ -- continuations from the same round share the one fresh IVar
+ -- via lookupOrAwait.
+ case cachePolicy @m @k Proxy of
+ NoCaching ->
+ pure $ Blocked
+ (singletonBatch k)
+ (Fetch $ \e' -> do
+ result <- lookupOrAwait e' k
+ (fetchLift e' $ throwIO $ FetchError $
+ "Key not found in cache after round: " <> show k)
+ case result of
+ Right v -> pure (Done v)
+ Left ex -> fetchLift e' $ throwIO ex)
+ CacheResults -> do
+ -- Check cache first
+ hit <- fetchLift e $ cacheLookup (fetchCache e) k
+ case hit of
+ CacheHitReady v -> pure (Done v)
+ CacheHitPending iv -> do
+ result <- fetchLift e $ awaitIVar iv
+ case result of
+ Right v -> pure (Done v)
+ Left ex -> fetchLift e $ throwIO ex
+ CacheMiss ->
+ pure $ Blocked
+ (singletonBatch k)
+ (Fetch $ \e' -> do
+ result <- lookupOrAwait e' k
+ (fetchLift e' $ throwIO $ FetchError $
+ "Key not found in cache after round: " <> show k)
+ case result of
+ Right v -> pure (Done v)
+ Left ex -> fetchLift e' $ throwIO ex)
+
+ tryFetch (k :: k) = Fetch $ \e ->
+ -- See 'fetch' above for NoCaching semantics.
+ case cachePolicy @m @k Proxy of
+ NoCaching ->
+ pure $ Blocked
+ (singletonBatch k)
+ (Fetch $ \e' -> do
+ result <- lookupOrAwait e' k
+ (pure $ Left $ toException $
+ FetchError $ "Key not found in cache after round: " <> show k)
+ pure (Done result))
+ CacheResults -> do
+ hit <- fetchLift e $ cacheLookup (fetchCache e) k
+ case hit of
+ CacheHitReady v -> pure (Done (Right v))
+ CacheHitPending iv -> do
+ result <- fetchLift e $ awaitIVar iv
+ pure (Done result)
+ CacheMiss ->
+ pure $ Blocked
+ (singletonBatch k)
+ (Fetch $ \e' -> do
+ result <- lookupOrAwait e' k
+ (pure $ Left $ toException $
+ FetchError $ "Key not found in cache after round: " <> show k)
+ pure (Done result))
+
+ primeCache k v = Fetch $ \e -> do
+ let cRef = fetchCache e
+ hit <- fetchLift e $ cacheLookup cRef k
+ case hit of
+ CacheHitPending iv -> fetchLift e $ writeIVar iv v
+ _ -> fetchLift e $ cacheWarm cRef (HM.singleton k v)
+ pure (Done ())
+
+-- ──────────────────────────────────────────────
+-- MonadFetchBatch instance
+-- ──────────────────────────────────────────────
+
+instance Monad m => MonadFetchBatch m (Fetch m) where
+ probe m = Fetch $ \e -> do
+ s <- unFetch m e
+ pure (Done s)
+
+ embed (Done a) = pure a
+ embed (Blocked _ k) = k
+
+-- ──────────────────────────────────────────────
+-- Config
+-- ──────────────────────────────────────────────
+
+-- | Configuration for running a 'Fetch' computation.
+--
+-- Contains the two natural transformations that bridge the source
+-- monad @m@ with @IO@, plus optional settings. Use 'fetchConfig'
+-- to construct with sensible defaults, then override fields as needed:
+--
+-- @
+-- let cfg = fetchConfig (runAppM env) liftIO
+-- runFetch cfg action
+--
+-- -- with a shared cache:
+-- runFetch cfg { configCache = Just myCache } action
+-- @
+--
+-- For monads that deliberately avoid 'MonadIO' (e.g. a @Transaction@
+-- type), the nats are the private escape hatches:
+--
+-- @
+-- fetchInTransaction :: Fetch Transaction a -> Transaction a
+-- fetchInTransaction = runFetch (fetchConfig unsafeRunTransaction unsafeLiftIO)
+-- @
+data FetchConfig m = FetchConfig
+ { configLower :: !(forall x. m x -> IO x)
+ -- ^ Run an @m@ action in @IO@. Used by the engine to dispatch
+ -- @batchFetch@ calls.
+ , configLift :: !(forall x. IO x -> m x)
+ -- ^ Lift an @IO@ action into @m@. Used for cache and IVar
+ -- operations within @m@.
+ , configCache :: !(Maybe CacheRef)
+ -- ^ Pre-existing cache. 'Nothing' creates a fresh cache per run.
+ -- Set to @Just cRef@ to share or pre-warm a cache.
+ }
+
+-- | Construct a 'FetchConfig' with explicit natural transformations.
+--
+-- Use this for monads that don't have 'MonadUnliftIO' (e.g. a
+-- restricted @Transaction@ type). For 'MonadUnliftIO' monads,
+-- prefer 'fetchConfigIO' which fills in the nats automatically.
+fetchConfig :: (forall x. m x -> IO x)
+ -> (forall x. IO x -> m x)
+ -> FetchConfig m
+fetchConfig lower lift = FetchConfig
+ { configLower = lower
+ , configLift = lift
+ , configCache = Nothing
+ }
+
+-- | Construct a 'FetchConfig' for any 'MonadUnliftIO' monad.
+--
+-- The natural transformations are derived from the 'MonadUnliftIO'
+-- instance: 'withRunInIO' provides @m x -> IO x@, and 'liftIO'
+-- provides @IO x -> m x@.
+--
+-- @
+-- cfg <- fetchConfigIO
+-- runFetch cfg action
+-- @
+fetchConfigIO :: MonadUnliftIO m => m (FetchConfig m)
+fetchConfigIO = withRunInIO $ \runInIO ->
+ pure FetchConfig
+ { configLower = runInIO
+ , configLift = liftIO
+ , configCache = Nothing
+ }
+
+-- ──────────────────────────────────────────────
+-- Runners
+-- ──────────────────────────────────────────────
+
+-- | Run a 'Fetch' computation.
+--
+-- @
+-- let cfg = fetchConfig (runAppM env) liftIO
+-- result <- runFetch cfg action
+-- @
+--
+-- To share a cache across sequential phases:
+--
+-- @
+-- let cfg = (fetchConfig lower lift) { configCache = Just myCache }
+-- runFetch cfg action
+-- @
+runFetch :: Monad m => FetchConfig m -> Fetch m a -> m a
+runFetch cfg action = do
+ cacheRef <- case configCache cfg of
+ Just ref -> pure ref
+ Nothing -> configLift cfg newCacheRef
+ let e = FetchEnv
+ { fetchCache = cacheRef
+ , fetchLower = configLower cfg
+ , fetchLift = configLift cfg
+ }
+ runLoop e (\_ _ -> pure ()) action
+
+-- | Like 'runFetch', but also returns the 'CacheRef'.
+-- This is the @runStateT@-style variant for cache preservation:
+--
+-- @
+-- (result1, cache) <- runFetch' cfg phase1
+-- result2 <- runFetch cfg { configCache = Just cache } phase2
+-- @
+runFetch' :: Monad m => FetchConfig m -> Fetch m a -> m (a, CacheRef)
+runFetch' cfg action = do
+ cacheRef <- case configCache cfg of
+ Just ref -> pure ref
+ Nothing -> configLift cfg newCacheRef
+ let e = FetchEnv
+ { fetchCache = cacheRef
+ , fetchLower = configLower cfg
+ , fetchLift = configLift cfg
+ }
+ a <- runLoop e (\_ _ -> pure ()) action
+ pure (a, cacheRef)
+
+-- | Generalised execution loop with a per-round wrapper.
+--
+-- The callback receives:
+--
+-- * The 1-based round number.
+-- * The pending 'Batches'.
+-- * An action that executes the batches and returns 'RoundStats'.
+--
+-- The callback /must/ invoke the execution action for the computation
+-- to make progress. This design lets instrumentation wrap /around/
+-- batch execution (opening a tracing span before and closing it
+-- after, for example).
+--
+-- @
+-- runLoopWith env (\\n batches exec -> do
+-- openSpan n batches
+-- stats <- exec
+-- closeSpan stats) action
+-- @
+runLoopWith :: Monad m
+ => FetchEnv m
+ -> (Int -> Batches m -> m RoundStats -> m ())
+ -- ^ Round wrapper. Must invoke the @m RoundStats@ action.
+ -> Fetch m a
+ -> m a
+runLoopWith e withRound = go 1
+ where
+ go !n m = do
+ status <- unFetch m e
+ case status of
+ Done a -> pure a
+ Blocked batches k -> do
+ let exec = fetchLift e $
+ executeBatches (fetchLower e) (fetchLift e) (fetchCache e) batches
+ withRound n batches exec
+ go (n + 1) k
+
+-- | Simplified execution loop with a pre-round callback.
+--
+-- Equivalent to 'runLoopWith' where the callback fires before batch
+-- execution but does not wrap it.
+--
+-- Exposed for use by custom runners.
+runLoop :: Monad m
+ => FetchEnv m
+ -> (Int -> Batches m -> m ())
+ -- ^ Called before each round with round number and batches.
+ -> Fetch m a
+ -> m a
+runLoop e onRound = runLoopWith e $ \n batches exec -> do
+ onRound n batches
+ _ <- exec
+ pure ()
diff --git a/src/Fetch/Cache.hs b/src/Fetch/Cache.hs
new file mode 100644
--- /dev/null
+++ b/src/Fetch/Cache.hs
@@ -0,0 +1,247 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Fetch.Cache
+ ( CacheRef
+ , newCacheRef
+ -- * Lookup
+ , CacheLookup(..)
+ , cacheLookup
+ -- * Allocation & writing
+ , cacheAllocate
+ , cacheAllocateForce
+ , cacheInsert
+ , cacheInsertError
+ -- * Eviction
+ , cacheEvict
+ , cacheEvictSource
+ , cacheEvictWhere
+ -- * Warming & export
+ , cacheWarm
+ , cacheContents
+ ) where
+
+import Fetch.Class
+import Fetch.IVar
+
+import Data.Dynamic
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HM
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.IORef
+import Type.Reflection (SomeTypeRep, someTypeRep)
+
+-- | Internal representation: each entry is a Dynamic wrapping
+-- @HashMap k (IVar (Result k))@.
+type ResultMap = Map SomeTypeRep Dynamic
+
+-- | A mutable, shared cache. Stores IVars so that in-flight
+-- requests can be deduplicated and concurrent readers can
+-- block on pending results.
+newtype CacheRef = CacheRef (IORef ResultMap)
+
+-- | Create an empty cache.
+newCacheRef :: IO CacheRef
+newCacheRef = CacheRef <$> newIORef Map.empty
+
+-- ──────────────────────────────────────────────
+-- Lookup
+-- ──────────────────────────────────────────────
+
+-- | Result of looking up a key in the cache.
+data CacheLookup a
+ = CacheMiss
+ -- ^ Key has never been requested.
+ | CacheHitPending (IVar a)
+ -- ^ Key is being fetched by another round. Wait on the IVar.
+ | CacheHitReady a
+ -- ^ Key has a resolved value.
+
+-- | Look up a key in the cache. Distinguishes between miss,
+-- pending (in-flight), and ready (resolved).
+cacheLookup :: forall k. (FetchKey k, Typeable (Result k))
+ => CacheRef -> k -> IO (CacheLookup (Result k))
+cacheLookup (CacheRef ref) k = do
+ cache <- readIORef ref
+ let trep = someTypeRep (Proxy @k)
+ case Map.lookup trep cache >>= fromDynamic of
+ Just (ivars :: HashMap k (IVar (Result k))) ->
+ case HM.lookup k ivars of
+ Just iv -> do
+ mr <- tryReadIVar iv
+ case mr of
+ Just (Right v) -> pure (CacheHitReady v)
+ Just (Left _) -> pure CacheMiss
+ -- Errored IVars are treated as a miss: allow retry.
+ Nothing -> pure (CacheHitPending iv)
+ Nothing -> pure CacheMiss
+ Nothing -> pure CacheMiss
+
+-- ──────────────────────────────────────────────
+-- Allocation
+-- ──────────────────────────────────────────────
+
+-- | Atomically allocate IVars for keys not already in the cache.
+-- Returns only the newly allocated (key, IVar) pairs; keys that
+-- already had IVars (filled or pending) are skipped.
+--
+-- This is the deduplication point: concurrent calls to
+-- @cacheAllocate@ for the same key will only allocate once.
+cacheAllocate :: forall k. (FetchKey k, Typeable (Result k))
+ => CacheRef -> [k] -> IO [(k, IVar (Result k))]
+cacheAllocate (CacheRef ref) keys = do
+ -- Allocate IVars in IO before the atomic update. Some may be
+ -- wasted if the key is already cached, but this avoids the
+ -- unsafePerformIO-inside-atomicModifyIORef pitfall where GHC
+ -- optimisations can break sharing of thunks.
+ candidates <- mapM (\k -> do iv <- newIVar; pure (k, iv)) keys
+ atomicModifyIORef' ref $ \cache ->
+ let trep = someTypeRep (Proxy @k)
+ existing :: HashMap k (IVar (Result k))
+ existing = case Map.lookup trep cache >>= fromDynamic of
+ Just m -> m
+ Nothing -> HM.empty
+
+ go [] acc ivMap = (acc, ivMap)
+ go ((k, iv):rest) acc ivMap =
+ case HM.lookup k ivMap of
+ Just _ -> go rest acc ivMap
+ Nothing -> go rest ((k, iv) : acc) (HM.insert k iv ivMap)
+
+ (newPairs, updated) = go candidates [] existing
+ cache' = Map.insert trep (toDyn updated) cache
+ in (cache', newPairs)
+
+-- | Like 'cacheAllocate', but always creates fresh IVars,
+-- overwriting any existing entries for the same keys.
+--
+-- Used by the engine for 'NoCaching' data sources. The old IVar
+-- (if any) is replaced atomically, so:
+--
+-- * Continuations from the /current/ round all share the new IVar
+-- (within-round deduplication is preserved).
+-- * Continuations from a /prior/ round that already read the old
+-- IVar are unaffected (they completed before the overwrite).
+-- * The next round will overwrite again, ensuring the source is
+-- re-fetched every time.
+cacheAllocateForce :: forall k. (FetchKey k, Typeable (Result k))
+ => CacheRef -> [k] -> IO [(k, IVar (Result k))]
+cacheAllocateForce (CacheRef ref) keys = do
+ candidates <- mapM (\k -> do iv <- newIVar; pure (k, iv)) keys
+ atomicModifyIORef' ref $ \cache ->
+ let trep = someTypeRep (Proxy @k)
+ existing :: HashMap k (IVar (Result k))
+ existing = case Map.lookup trep cache >>= fromDynamic of
+ Just m -> m
+ Nothing -> HM.empty
+
+ -- Always overwrite: insert every candidate regardless of
+ -- whether the key already has an IVar in the cache.
+ updated = foldl (\m (k, iv) -> HM.insert k iv m) existing candidates
+ cache' = Map.insert trep (toDyn updated) cache
+ in (cache', candidates)
+
+-- ──────────────────────────────────────────────
+-- Writing
+-- ──────────────────────────────────────────────
+
+-- | Look up the IVar for a key and apply an action to it.
+-- No-op if the key has no allocated IVar.
+withCachedIVar :: forall k. (FetchKey k, Typeable (Result k))
+ => CacheRef -> k -> (IVar (Result k) -> IO ()) -> IO ()
+withCachedIVar (CacheRef ref) k action = do
+ cache <- readIORef ref
+ let trep = someTypeRep (Proxy @k)
+ case Map.lookup trep cache >>= fromDynamic of
+ Just (ivars :: HashMap k (IVar (Result k))) ->
+ case HM.lookup k ivars of
+ Just iv -> action iv
+ Nothing -> pure ()
+ Nothing -> pure ()
+
+-- | Write a success result into a previously allocated IVar.
+cacheInsert :: forall k. (FetchKey k, Typeable (Result k))
+ => CacheRef -> k -> Result k -> IO ()
+cacheInsert cRef k v = withCachedIVar cRef k $ \iv -> writeIVar iv v
+
+-- | Write an error into a previously allocated IVar.
+cacheInsertError :: forall k. (FetchKey k, Typeable (Result k))
+ => CacheRef -> k -> SomeException -> IO ()
+cacheInsertError cRef k e = withCachedIVar cRef k $ \iv -> writeIVarError iv e
+
+-- ──────────────────────────────────────────────
+-- Eviction
+-- ──────────────────────────────────────────────
+
+-- | Evict a single key.
+cacheEvict :: forall k. (FetchKey k, Typeable (Result k))
+ => CacheRef -> k -> IO ()
+cacheEvict (CacheRef ref) k = do
+ let trep = someTypeRep (Proxy @k)
+ atomicModifyIORef' ref $ \cache ->
+ ( Map.adjust
+ (\dyn ->
+ let ivars = fromDyn dyn (HM.empty :: HashMap k (IVar (Result k)))
+ in toDyn (HM.delete k ivars))
+ trep cache
+ , () )
+
+-- | Evict all cached results for a data source.
+cacheEvictSource :: forall k. (Typeable k)
+ => CacheRef -> Proxy k -> IO ()
+cacheEvictSource (CacheRef ref) _ =
+ atomicModifyIORef' ref $ \cache ->
+ (Map.delete (someTypeRep (Proxy @k)) cache, ())
+
+-- | Evict keys matching a predicate.
+cacheEvictWhere :: forall k. (FetchKey k, Typeable (Result k))
+ => CacheRef -> Proxy k -> (k -> Bool) -> IO ()
+cacheEvictWhere (CacheRef ref) _ predicate = do
+ let trep = someTypeRep (Proxy @k)
+ atomicModifyIORef' ref $ \cache ->
+ ( Map.adjust
+ (\dyn ->
+ let ivars = fromDyn dyn (HM.empty :: HashMap k (IVar (Result k)))
+ in toDyn (HM.filterWithKey (\k' _ -> not (predicate k')) ivars))
+ trep cache
+ , () )
+
+-- ──────────────────────────────────────────────
+-- Warming & export
+-- ──────────────────────────────────────────────
+
+-- | Warm the cache with known values. Creates pre-filled IVars.
+-- Useful for hydrating from an external cache (Redis, etc.)
+-- at request start.
+cacheWarm :: forall k. (FetchKey k, Typeable (Result k))
+ => CacheRef -> HashMap k (Result k) -> IO ()
+cacheWarm (CacheRef ref) values = do
+ let trep = someTypeRep (Proxy @k)
+ ivars <- HM.traverseWithKey (\_ v -> do
+ iv <- newIVar
+ writeIVar iv v
+ pure iv) values
+ atomicModifyIORef' ref $ \cache ->
+ let existing :: HashMap k (IVar (Result k))
+ existing = case Map.lookup trep cache >>= fromDynamic of
+ Just m -> m
+ Nothing -> HM.empty
+ in (Map.insert trep (toDyn (HM.union ivars existing)) cache, ())
+
+-- | Read all resolved values for a source (for debugging/export).
+cacheContents :: forall k. (FetchKey k, Typeable (Result k))
+ => CacheRef -> Proxy k -> IO (HashMap k (Result k))
+cacheContents (CacheRef ref) _ = do
+ cache <- readIORef ref
+ let trep = someTypeRep (Proxy @k)
+ case Map.lookup trep cache >>= fromDynamic of
+ Just (ivars :: HashMap k (IVar (Result k))) ->
+ HM.mapMaybe id <$> traverse (\iv -> do
+ mr <- tryReadIVar iv
+ pure $ case mr of
+ Just (Right v) -> Just v
+ _ -> Nothing) ivars
+ Nothing -> pure HM.empty
diff --git a/src/Fetch/Class.hs b/src/Fetch/Class.hs
new file mode 100644
--- /dev/null
+++ b/src/Fetch/Class.hs
@@ -0,0 +1,344 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE RankNTypes #-}
+
+module Fetch.Class
+ ( -- * Keys
+ FetchKey(..)
+ -- * Data sources
+ , DataSource(..)
+ , FetchStrategy(..)
+ , CachePolicy(..)
+ -- * Batching protocol
+ , Status(..)
+ , Batches(..)
+ , SomeBatch(..)
+ , singletonBatch
+ , batchKeys
+ , batchSize
+ , batchSourceCount
+ , mapStatus
+ -- * MonadFetch
+ , MonadFetch(..)
+ -- * MonadFetchBatch
+ , MonadFetchBatch(..)
+ -- * Mutations
+ , MutationKey(..)
+ -- * Re-exports
+ , Typeable
+ , Hashable
+ , NonEmpty(..)
+ , Proxy(..)
+ , SomeException
+ ) where
+
+import Control.Exception (SomeException)
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HM
+import Data.HashSet (HashSet)
+import qualified Data.HashSet as HS
+import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.List.NonEmpty as NE
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Hashable (Hashable)
+import Data.Proxy (Proxy(..))
+import Data.Typeable (Typeable)
+import Type.Reflection (SomeTypeRep, someTypeRep, eqTypeRep, typeRep, (:~~:)(HRefl))
+
+-- ──────────────────────────────────────────────
+-- Keys
+-- ──────────────────────────────────────────────
+
+-- | A typed key for a data fetch. The associated type family
+-- pairs each key type with its result type, replacing Haxl's
+-- GADT-based approach.
+class (Typeable k, Hashable k, Eq k, Show k) => FetchKey k where
+ type Result k
+
+-- ──────────────────────────────────────────────
+-- Data sources
+-- ──────────────────────────────────────────────
+
+-- | How the engine should schedule this source relative to others.
+data FetchStrategy
+ = Sequential -- ^ Block on this source before starting others.
+ | Concurrent -- ^ Run alongside other sources (default).
+ | EagerStart -- ^ Start before sequential sources to overlap latency.
+ deriving (Eq, Show)
+
+-- | Whether results should be cached across rounds.
+--
+-- The default is 'CacheResults', which means a key fetched in round
+-- /N/ is remembered: if the same key appears again in round /N+1/
+-- (or anywhere later in the computation), the cached value is returned
+-- immediately without dispatching a new batch.
+--
+-- 'NoCaching' opts out of this. Every round that mentions the key
+-- dispatches a fresh batch to the data source, even if the key was
+-- fetched moments ago. This is the right choice for data sources
+-- whose results are non-idempotent or time-sensitive: counters,
+-- "current timestamp" endpoints, queue-drain operations, etc.
+--
+-- __Within a single round__, deduplication still applies regardless
+-- of policy: @(\',\') \<$\> fetch k \<*\> fetch k@ hits the source
+-- once and both sides see the same value. The "no caching" guarantee
+-- is strictly /across/ round boundaries introduced by @(>>=)@.
+data CachePolicy
+ = CacheResults
+ -- ^ Cache results (default). Use for idempotent reads.
+ -- A key is fetched at most once per 'CacheRef' lifetime.
+ | NoCaching
+ -- ^ Do not cache across rounds. The data source is re-fetched
+ -- every round the key appears in. Within a single round,
+ -- duplicate keys are still deduplicated.
+ deriving (Eq, Show)
+
+-- | A data source knows how to batch-fetch keys given capabilities
+-- provided by the monad @m@.
+--
+-- The @m@ parameter replaces both the old @env@ parameter and
+-- the concrete @IO@ in @batchFetch@. If your data source needs a
+-- connection pool, @m@ should be a monad with access to one
+-- (e.g. via 'MonadReader' or a newtype over 'ReaderT').
+--
+-- Type safety: if there is no @DataSource m k@ instance, code that
+-- tries to @fetch@ a @k@ won't compile. No runtime errors from
+-- missing config.
+--
+-- Libraries that use a restricted monad (e.g. a @Transaction@ type
+-- that deliberately hides @MonadIO@) should export a convenience
+-- runner:
+--
+-- @
+-- fetchInTransaction :: Fetch Transaction a -> Transaction a
+-- fetchInTransaction = runFetch unsafeRunTransaction unsafeLiftIO
+-- @
+--
+-- This keeps the unsafe escape hatches private while giving users
+-- a safe, typed entry point.
+class (FetchKey k, Monad m) => DataSource m k where
+ -- | Fetch a batch of keys. Must return a result for every key provided.
+ -- The engine handles concurrency, error wrapping, and caching.
+ --
+ -- The list is guaranteed non-empty by the engine (a batch exists
+ -- only because at least one @fetch@ blocked on it).
+ --
+ -- If your data source has no native batch API, implement 'fetchOne'
+ -- instead; the default 'batchFetch' calls it for each key.
+ batchFetch :: NonEmpty k -> m (HashMap k (Result k))
+ batchFetch keys = HM.fromList . NE.toList <$> traverse (\k -> fmap (\v -> (k, v)) (fetchOne k)) keys
+
+ -- | Fetch a single key. Override this for data sources that don't
+ -- support batch operations; the default 'batchFetch' will call it
+ -- for each key and assemble the results.
+ --
+ -- The default implementation delegates to @'batchFetch' (k :| [])@
+ -- and extracts the result. You must implement at least one of
+ -- 'batchFetch' or 'fetchOne'.
+ --
+ -- @
+ -- instance DataSource AppM UserId where
+ -- fetchOne (UserId uid) = lookupUserById uid
+ -- @
+ fetchOne :: k -> m (Result k)
+ fetchOne k = do
+ hm <- batchFetch (k :| [])
+ case HM.lookup k hm of
+ Just v -> pure v
+ Nothing -> error $
+ "DataSource.fetchOne: batchFetch did not return key: " <> show k
+
+ -- __Important:__ you must implement at least one of 'batchFetch' or
+ -- 'fetchOne'. The defaults are mutually recursive: if neither is
+ -- overridden, calls will loop at runtime. The @MINIMAL@ pragma
+ -- below emits a compile-time warning, but it is not a hard error
+ -- unless @-Werror@ is enabled.
+ {-# MINIMAL batchFetch | fetchOne #-}
+
+ -- | Optional: streaming fetch for sources where results arrive
+ -- incrementally (gRPC streams, websockets, etc.).
+ --
+ -- Default delegates to 'batchFetch'.
+ streamingFetch :: NonEmpty k -> (k -> Result k -> m ()) -> m ()
+ streamingFetch ks callback = do
+ results <- batchFetch ks
+ _ <- HM.traverseWithKey callback results
+ pure ()
+
+ -- | How should the engine schedule this source?
+ fetchStrategy :: Proxy k -> FetchStrategy
+ fetchStrategy _ = Concurrent
+
+ -- | Should results be cached across rounds?
+ --
+ -- Override to 'NoCaching' for data sources whose results are
+ -- non-idempotent or time-sensitive. With 'NoCaching':
+ --
+ -- * @fetch@ never returns a cached value; it always blocks and
+ -- waits for a fresh batch dispatch.
+ -- * Within a single applicative round, duplicate keys are still
+ -- deduplicated (one batch call, one result shared by all
+ -- continuations).
+ -- * Across @(>>=)@ round boundaries, each round dispatches a
+ -- fresh batch, and the data source is called again.
+ --
+ -- @
+ -- instance DataSource AppM CurrentTime where
+ -- fetchOne _ = liftIO getCurrentTime
+ -- cachePolicy _ = NoCaching
+ -- @
+ cachePolicy :: Proxy k -> CachePolicy
+ cachePolicy _ = CacheResults
+
+ -- | Human-readable name for tracing/logging.
+ dataSourceName :: Proxy k -> String
+ dataSourceName _ = show (someTypeRep (Proxy @k))
+
+-- ──────────────────────────────────────────────
+-- Batching protocol
+-- ──────────────────────────────────────────────
+
+-- | The result of probing a computation: either a final value
+-- or a set of blocked fetches with a continuation.
+data Status m f a
+ = Done a
+ | Blocked (Batches m) (f a)
+
+instance Functor f => Functor (Status m f) where
+ fmap f (Done a) = Done (f a)
+ fmap f (Blocked bs k) = Blocked bs (fmap f k)
+
+-- | Transform the continuation type in a 'Status'.
+mapStatus :: (forall x. f x -> g x) -> Status m f a -> Status m g a
+mapStatus _ (Done a) = Done a
+mapStatus f (Blocked bs k) = Blocked bs (f k)
+
+-- | A collection of pending fetch requests, grouped by key type.
+newtype Batches m = Batches (Map SomeTypeRep (SomeBatch m))
+
+instance Semigroup (Batches m) where
+ Batches a <> Batches b = Batches (Map.unionWith mergeBatch a b)
+
+instance Monoid (Batches m) where
+ mempty = Batches Map.empty
+
+-- | Total number of (deduplicated) keys across all sources.
+batchSize :: Batches m -> Int
+batchSize (Batches m) = Map.foldl' (\acc b -> acc + someBatchLen b) 0 m
+ where
+ someBatchLen :: SomeBatch n -> Int
+ someBatchLen (SomeBatch ks) = HS.size ks
+
+-- | Number of distinct data sources in this batch.
+batchSourceCount :: Batches m -> Int
+batchSourceCount (Batches m) = Map.size m
+
+-- | Extract the keys for a specific source type (for testing/tracing).
+batchKeys :: forall k m. (Typeable k) => Batches m -> [k]
+batchKeys (Batches m) =
+ case Map.lookup (someTypeRep (Proxy @k)) m of
+ Just (SomeBatch (ks :: HashSet k')) ->
+ case eqTypeRep (typeRep @k) (typeRep @k') of
+ Just HRefl -> HS.toList ks
+ Nothing -> []
+ Nothing -> []
+
+-- | Existentially wraps a batch for a single data source.
+-- The @m@ parameter carries the monad needed to dispatch.
+data SomeBatch m = forall k.
+ (DataSource m k, Typeable k, Typeable (Result k))
+ => SomeBatch (HashSet k)
+
+mergeBatch :: SomeBatch m -> SomeBatch m -> SomeBatch m
+mergeBatch (SomeBatch (a :: HashSet k1)) (SomeBatch (b :: HashSet k2)) =
+ case eqTypeRep (typeRep @k1) (typeRep @k2) of
+ Just HRefl -> SomeBatch (HS.union a b)
+ Nothing -> error "Fetch.Class.mergeBatch: impossible type mismatch"
+
+-- | Create a batch containing a single key.
+singletonBatch :: forall m k.
+ (DataSource m k, Typeable (Result k))
+ => k -> Batches m
+singletonBatch k = Batches $
+ Map.singleton (someTypeRep (Proxy @k)) (SomeBatch (HS.singleton k))
+
+-- ──────────────────────────────────────────────
+-- MonadFetch
+-- ──────────────────────────────────────────────
+
+-- | The interface application code programs against.
+--
+-- @m@ is the /source monad/ (the monad that 'DataSource'
+-- implementations run in). @n@ is the /fetch monad/: the monad
+-- your application code runs in, typically 'Fetch' @m@.
+--
+-- The functional dependency @n -> m@ means the source monad is
+-- determined by the fetch monad.
+class Monad n => MonadFetch m n | n -> m where
+ -- | Fetch a single key. Throws on error.
+ fetch :: (DataSource m k, Typeable (Result k)) => k -> n (Result k)
+
+ -- | Fetch a single key with explicit error handling.
+ tryFetch :: (DataSource m k, Typeable (Result k))
+ => k -> n (Either SomeException (Result k))
+
+ -- | Seed the cache with a known key\/value pair.
+ --
+ -- * __Miss__: inserts a new resolved entry.
+ -- * __Pending__: fills the in-flight IVar, waking any blocked
+ -- continuations immediately. The batch\'s later write is
+ -- idempotent and silently ignored.
+ -- * __Resolved__: overwrites with the new value.
+ --
+ -- Use this to prime sub-entities extracted from compound responses:
+ --
+ -- @
+ -- posts <- fetch (PostsFeed feedId)
+ -- mapM_ (\\p -> primeCache (PostById (postId p)) p) posts
+ -- @
+ primeCache :: (FetchKey k, Typeable (Result k)) => k -> Result k -> n ()
+
+-- | The batching protocol. Only needed by implementations and runners,
+-- not by application code.
+class MonadFetch m n => MonadFetchBatch m n | n -> m where
+ -- | Expose the next blocking point of a computation.
+ probe :: n a -> n (Status m n a)
+
+ -- | Inject a 'Status' back into the monad.
+ --
+ -- __Warning:__ for a @'Blocked' batches k@ status, @embed@
+ -- discards @batches@ and runs the continuation @k@ directly.
+ -- The continuation expects its IVars to have been filled by the
+ -- engine. If you call @embed@ on a 'Blocked' status without
+ -- first executing the batches (via 'executeBatches' or the
+ -- run-loop), every blocked key will error with
+ -- @\"Key not found in cache after round\"@.
+ --
+ -- Typical usage: call 'probe' to inspect the status, execute
+ -- the batches yourself, /then/ call @embed@ (or feed the
+ -- continuation to the next iteration of your custom loop).
+ embed :: Status m n a -> n a
+ embed (Done a) = pure a
+ embed (Blocked _ k) = k
+
+-- ──────────────────────────────────────────────
+-- Mutations
+-- ──────────────────────────────────────────────
+
+-- | A typed key for a mutation operation. The key itself encodes
+-- both the identity and the input (e.g., @UpdateUserName uid name@).
+--
+-- Unlike 'FetchKey', mutation keys only require 'Typeable' (no
+-- 'Hashable', 'Eq', or 'Show') because mutations are never
+-- deduplicated, cached, or shown in engine error messages.
+class Typeable k => MutationKey k where
+ type MutationResult k
diff --git a/src/Fetch/Combinators.hs b/src/Fetch/Combinators.hs
new file mode 100644
--- /dev/null
+++ b/src/Fetch/Combinators.hs
@@ -0,0 +1,309 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Fetch.Combinators
+ ( -- * Fetch combinators
+ fetchAll
+ , fetchWith
+ , fetchThrough
+ , fetchMap
+ , fetchMaybe
+ , fetchMapWith
+ -- * Lifted operators
+ --
+ -- | Operators for working with applicative values (e.g. fetched
+ -- results) without explicit binding. Prefix @.@ distinguishes
+ -- them from their pure counterparts.
+ --
+ -- @
+ -- do userAge <- fetch (UserAge uid)
+ -- pure (userAge >= 18)
+ -- @
+ --
+ -- becomes:
+ --
+ -- @
+ -- fetch (UserAge uid) .>= pure 18
+ -- @
+ , (.>)
+ , (.<)
+ , (.>=)
+ , (.<=)
+ , (.==)
+ , (./=)
+ , (.&&)
+ , (.||)
+ , (.++)
+ -- * Applicative pairing
+ , pair
+ -- * Parallel short-circuiting
+ , biselect
+ , pAnd
+ , pOr
+ -- * Sequencing
+ , andThen
+ -- * Applicative filter
+ , filterA
+ -- * Error recovery
+ , withDefault
+ ) where
+
+import Fetch.Class
+import Fetch.Batched (Fetch(..))
+
+import Control.Monad.Catch (MonadCatch, catch)
+import Data.Foldable (toList)
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HM
+
+-- ──────────────────────────────────────────────
+-- Fetch combinators
+-- ──────────────────────────────────────────────
+
+-- | Fetch all keys, preserving the container shape.
+--
+-- @fetchAll [k1, k2, k3]@ batches all three keys into one round.
+fetchAll :: (MonadFetch m n, DataSource m k, Typeable (Result k), Traversable t)
+ => t k -> n (t (Result k))
+fetchAll = traverse fetch
+
+-- | Fetch all keys and pair each with its result.
+fetchWith :: (MonadFetch m n, DataSource m k, Typeable (Result k), Traversable t)
+ => t k -> n (t (k, Result k))
+fetchWith = traverse (\k -> (,) k <$> fetch k)
+
+-- | Extract a key from each element, fetch, and pair back.
+--
+-- @fetchThrough commentAuthor comments@ fetches all authors in one
+-- round and pairs each comment with its author.
+fetchThrough :: (MonadFetch m n, DataSource m k, Typeable (Result k), Traversable t)
+ => (a -> k) -> t a -> n (t (a, Result k))
+fetchThrough toKey = traverse (\a -> (,) a <$> fetch (toKey a))
+
+-- | Extract a key from each element, fetch, and transform.
+--
+-- @fetchMap commentAuthor (\\c u -> CommentView c u) comments@
+fetchMap :: (MonadFetch m n, DataSource m k, Typeable (Result k), Traversable t)
+ => (a -> k) -> (a -> Result k -> b) -> t a -> n (t b)
+fetchMap toKey combine = traverse (\a -> combine a <$> fetch (toKey a))
+
+-- | Fetch a key if present.
+fetchMaybe :: (MonadFetch m n, DataSource m k, Typeable (Result k))
+ => Maybe k -> n (Maybe (Result k))
+fetchMaybe = traverse fetch
+
+-- | Fetch a collection of keys and return a map of results.
+-- Duplicates are deduplicated.
+fetchMapWith :: (MonadFetch m n, DataSource m k, Typeable (Result k), Foldable f)
+ => f k -> n (HashMap k (Result k))
+fetchMapWith ks =
+ let keys = toList ks
+ in HM.fromList <$> traverse (\k -> (,) k <$> fetch k) keys
+
+-- ──────────────────────────────────────────────
+-- Lifted operators
+-- ──────────────────────────────────────────────
+
+infixr 3 .&&
+infixr 2 .||
+infix 4 .>, .<, .>=, .<=, .==, ./=
+
+-- | Lifted @(>)@.
+(.>) :: (Ord a, Applicative f) => f a -> f a -> f Bool
+(.>) = liftA2 (>)
+
+-- | Lifted @(<)@.
+(.<) :: (Ord a, Applicative f) => f a -> f a -> f Bool
+(.<) = liftA2 (<)
+
+-- | Lifted @(>=)@.
+(.>=) :: (Ord a, Applicative f) => f a -> f a -> f Bool
+(.>=) = liftA2 (>=)
+
+-- | Lifted @(<=)@.
+(.<=) :: (Ord a, Applicative f) => f a -> f a -> f Bool
+(.<=) = liftA2 (<=)
+
+-- | Lifted @(==)@.
+(.==) :: (Eq a, Applicative f) => f a -> f a -> f Bool
+(.==) = liftA2 (==)
+
+-- | Lifted @(/=)@.
+(./=) :: (Eq a, Applicative f) => f a -> f a -> f Bool
+(./=) = liftA2 (/=)
+
+-- | Short-circuiting lifted @(&&)@. Evaluates the second argument
+-- only if the first returns 'True'.
+(.&&) :: Monad m => m Bool -> m Bool -> m Bool
+ma .&& mb = do a <- ma; if a then mb else pure False
+
+-- | Short-circuiting lifted @(||)@. Evaluates the second argument
+-- only if the first returns 'False'.
+(.||) :: Monad m => m Bool -> m Bool -> m Bool
+ma .|| mb = do a <- ma; if a then pure True else mb
+
+-- | Lifted @(++)@.
+(.++) :: Applicative f => f [a] -> f [a] -> f [a]
+(.++) = liftA2 (++)
+
+-- ──────────────────────────────────────────────
+-- Applicative pairing
+-- ──────────────────────────────────────────────
+
+-- | Pair two applicative computations. When used with 'Fetch',
+-- both sides are batched into the same round.
+--
+-- @pair (fetch userKey) (fetch postKey)@
+pair :: Applicative f => f a -> f b -> f (a, b)
+pair = liftA2 (,)
+
+-- ──────────────────────────────────────────────
+-- Parallel short-circuiting
+-- ──────────────────────────────────────────────
+
+infixr 5 `pAnd`
+infixr 4 `pOr`
+
+-- | Select from two computations that each return @Either a@.
+--
+-- Both sides are probed in the same round (their fetches are batched
+-- together). If either side resolves to @Left a@, the other side is
+-- abandoned and the result is @Left a@. Only when both sides resolve
+-- to @Right@ are the two values paired.
+--
+-- After each round, resolved sides are checked for early exit so
+-- that multi-round computations can short-circuit as soon as
+-- possible.
+--
+-- This is the fundamental building block for 'pAnd' and 'pOr'.
+biselect :: Monad m
+ => Fetch m (Either a b)
+ -> Fetch m (Either a c)
+ -> Fetch m (Either a (b, c))
+biselect = go
+ where
+ go l r = Fetch $ \e -> do
+ sl <- unFetch l e
+ sr <- unFetch r e
+ pure $ case (sl, sr) of
+ -- Either side short-circuits
+ (Done (Left a), _) -> Done (Left a)
+ (_, Done (Left a)) -> Done (Left a)
+ -- Both sides done
+ (Done (Right b), Done (Right c)) -> Done (Right (b, c))
+ -- One side done, the other blocked. Keep probing the
+ -- blocked side each round in case it short-circuits.
+ (Done (Right b), Blocked bs kr) -> Blocked bs (goRight b kr)
+ (Blocked bs kl, Done (Right c)) -> Blocked bs (goLeft kl c)
+ -- Both blocked: merge batches, recurse next round
+ (Blocked bs1 kl, Blocked bs2 kr) -> Blocked (bs1 <> bs2) (go kl kr)
+
+ -- Left resolved to @Right b@; keep probing right for early exit.
+ goRight b r = Fetch $ \e -> do
+ sr <- unFetch r e
+ pure $ case sr of
+ Done (Left a) -> Done (Left a)
+ Done (Right c) -> Done (Right (b, c))
+ Blocked bs kr -> Blocked bs (goRight b kr)
+
+ -- Right resolved to @Right c@; keep probing left for early exit.
+ goLeft l c = Fetch $ \e -> do
+ sl <- unFetch l e
+ pure $ case sl of
+ Done (Left a) -> Done (Left a)
+ Done (Right b) -> Done (Right (b, c))
+ Blocked bs kl -> Blocked bs (goLeft kl c)
+
+-- | Parallel @(&&)@. Both sides are probed in the same round
+-- (batched together). If either side returns 'False' before the
+-- other completes, the result is 'False' immediately; the other
+-- side's remaining rounds are not evaluated.
+--
+-- Compare with '.&&' which is sequential short-circuiting
+-- (left-to-right), and @liftA2 (&&)@ which is concurrent but
+-- never short-circuits.
+--
+-- @
+-- pAnd (fetch (IsActive uid)) (fetch (HasPermission uid "admin"))
+-- @
+pAnd :: Monad m => Fetch m Bool -> Fetch m Bool -> Fetch m Bool
+pAnd x y = fromEither <$> biselect (discrim <$> x) (discrim <$> y)
+ where
+ discrim False = Left False -- short-circuit
+ discrim True = Right () -- continue
+ fromEither (Left b) = b
+ fromEither (Right _) = True
+
+-- | Parallel @(||)@. Both sides are probed in the same round
+-- (batched together). If either side returns 'True' before the
+-- other completes, the result is 'True' immediately; the other
+-- side's remaining rounds are not evaluated.
+--
+-- Compare with '.||' which is sequential short-circuiting
+-- (left-to-right), and @liftA2 (||)@ which is concurrent but
+-- never short-circuits.
+--
+-- @
+-- pOr (fetch (IsAdmin uid)) (fetch (IsModerator uid))
+-- @
+pOr :: Monad m => Fetch m Bool -> Fetch m Bool -> Fetch m Bool
+pOr x y = fromEither <$> biselect (discrim <$> x) (discrim <$> y)
+ where
+ discrim True = Left True -- short-circuit
+ discrim False = Right () -- continue
+ fromEither (Left b) = b
+ fromEither (Right _) = False
+
+-- ──────────────────────────────────────────────
+-- Sequencing
+-- ──────────────────────────────────────────────
+
+-- | Monadic sequencing: run the first computation, discard its
+-- result, then run the second.
+--
+-- In a fetch monad where @('>>')@ equals @('*>')@ (i.e. both sides
+-- are batched into one round), 'andThen' forces sequential execution
+-- across round boundaries.
+--
+-- @
+-- -- These batch together (one round):
+-- fetch keyA *> fetch keyB
+--
+-- -- This forces two rounds:
+-- fetch keyA \`andThen\` fetch keyB
+-- @
+andThen :: Monad m => m a -> m b -> m b
+andThen a b = a >>= \_ -> b
+
+-- ──────────────────────────────────────────────
+-- Applicative filter
+-- ──────────────────────────────────────────────
+
+-- | Applicative version of 'Control.Monad.filterM'.
+--
+-- The predicate is applied to all elements via 'traverse', so when
+-- used with a fetch monad, all predicate evaluations are batched
+-- into the same round.
+--
+-- @
+-- filterA (\\uid -> fetch (IsActive uid)) userIds
+-- @
+filterA :: Applicative f => (a -> f Bool) -> [a] -> f [a]
+filterA predicate xs =
+ filt <$> traverse predicate xs
+ where
+ filt bools = map fst $ filter snd $ zip xs bools
+
+-- ──────────────────────────────────────────────
+-- Error recovery
+-- ──────────────────────────────────────────────
+
+-- | Run a computation; if it throws any exception, return the
+-- supplied default value instead.
+--
+-- @
+-- userName <- withDefault "unknown" (fetch (UserName uid))
+-- @
+withDefault :: MonadCatch m => a -> m a -> m a
+withDefault d a = a `catch` \(_ :: SomeException) -> pure d
diff --git a/src/Fetch/Deriving.hs b/src/Fetch/Deriving.hs
new file mode 100644
--- /dev/null
+++ b/src/Fetch/Deriving.hs
@@ -0,0 +1,120 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+-- | Helpers for writing typeclass instances with less boilerplate.
+--
+-- = DerivingVia for transformer newtypes
+--
+-- If you define a newtype over 'Fetch', 'MockFetch', 'Mutate',
+-- or any of the library's monads, @GeneralizedNewtypeDeriving@ can
+-- derive all the standard instances automatically:
+--
+-- @
+-- {-\# LANGUAGE GeneralizedNewtypeDeriving, DerivingStrategies \#-}
+--
+-- newtype AppFetch a = AppFetch ('Fetch.Batched.Fetch' AppM a)
+-- deriving newtype
+-- ( Functor, Applicative, Monad
+-- , MonadFail, MonadThrow, MonadCatch
+-- , 'Fetch.Class.MonadFetch' AppM
+-- )
+-- @
+--
+-- For a newtype over 'Mutate' that also supports mutations:
+--
+-- @
+-- newtype AppMutate a = AppMutate ('Fetch.Mutate.Mutate' AppM AppM a)
+-- deriving newtype
+-- ( Functor, Applicative, Monad
+-- , MonadFail, MonadThrow, MonadCatch
+-- , 'Fetch.Class.MonadFetch' AppM
+-- , 'Fetch.Mutate.MonadMutate' AppM
+-- )
+-- @
+--
+-- For a newtype over 'MockFetch' in tests:
+--
+-- @
+-- newtype TestFetch a = TestFetch ('Fetch.Mock.MockFetch' AppM IO a)
+-- deriving newtype
+-- ( Functor, Applicative, Monad
+-- , 'Fetch.Class.MonadFetch' AppM
+-- )
+-- @
+--
+-- The library's own 'Fetch.Traced.TracedFetch' uses this exact pattern.
+--
+-- == Why not FetchKey or DataSource?
+--
+-- 'FetchKey', 'MutationKey', and 'MemoKey' use associated type families,
+-- which @DerivingVia@ cannot handle, so you must write the @type Result@
+-- line manually. That said, the instances are minimal (2 lines each).
+--
+-- 'DataSource' methods mention @HashMap k (Result k)@ in return
+-- positions, and @HashMap@'s key role is nominal, preventing coercion.
+-- Use 'fetchOne' or the helpers below to reduce the boilerplate instead.
+--
+-- = Simpler DataSource instances
+--
+-- For data sources with no native batch API, implement 'fetchOne'
+-- instead of 'batchFetch'. The default 'batchFetch' calls 'fetchOne'
+-- for each key and assembles the results:
+--
+-- @
+-- instance DataSource AppM UserId where
+-- fetchOne (UserId uid) = lookupUserById uid
+-- @
+--
+-- For more control over how missing keys are handled, use
+-- 'optionalBatchFetch' or 'traverseBatchFetch' in your 'batchFetch'
+-- implementation.
+module Fetch.Deriving
+ ( -- * DataSource helpers
+ optionalBatchFetch
+ , traverseBatchFetch
+ ) where
+
+import Fetch.Class
+
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HM
+import qualified Data.List.NonEmpty as NE
+import Data.Maybe (mapMaybe)
+
+-- | Build a 'batchFetch' from a per-key lookup that may not find a result.
+--
+-- Missing keys are silently omitted from the 'HashMap'. The engine
+-- fills them with an error via @fillUnfilled@, so callers using
+-- 'fetch' see an exception and callers using 'tryFetch' see @Left@.
+--
+-- @
+-- instance DataSource AppM UserId where
+-- batchFetch = optionalBatchFetch $ \\(UserId uid) ->
+-- lookupUserMaybe uid
+-- @
+optionalBatchFetch :: (FetchKey k, Monad m)
+ => (k -> m (Maybe (Result k)))
+ -> NonEmpty k -> m (HashMap k (Result k))
+optionalBatchFetch f keys = do
+ results <- traverse (\k -> fmap (\mv -> (k, mv)) (f k)) keys
+ pure $ HM.fromList (mapMaybe (\(k, mv) -> fmap (\v -> (k, v)) mv) (NE.toList results))
+
+-- | Build a 'batchFetch' from a per-key action that always succeeds.
+--
+-- Equivalent to the default 'batchFetch' when only 'fetchOne' is
+-- implemented, but as a standalone combinator for use in custom
+-- 'batchFetch' implementations (e.g. to add logging around each
+-- individual fetch).
+--
+-- @
+-- instance DataSource AppM UserId where
+-- batchFetch keys = do
+-- logBatchStart (length keys)
+-- traverseBatchFetch lookupUser keys
+-- @
+traverseBatchFetch :: (FetchKey k, Monad m)
+ => (k -> m (Result k))
+ -> NonEmpty k -> m (HashMap k (Result k))
+traverseBatchFetch f keys =
+ HM.fromList . NE.toList <$> traverse (\k -> fmap (\v -> (k, v)) (f k)) keys
diff --git a/src/Fetch/Engine.hs b/src/Fetch/Engine.hs
new file mode 100644
--- /dev/null
+++ b/src/Fetch/Engine.hs
@@ -0,0 +1,172 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE RankNTypes #-}
+
+module Fetch.Engine
+ ( executeBatches
+ , RoundStats(..)
+ , emptyRoundStats
+ ) where
+
+import Fetch.Class
+import Fetch.Cache
+import Fetch.IVar
+
+import Control.Concurrent.Async (async, wait)
+import Control.Exception (try, toException)
+import Control.Monad (unless)
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HM
+import Data.HashSet (HashSet)
+import qualified Data.HashSet as HS
+import qualified Data.Map.Strict as Map
+
+-- | Stats for a single round of fetching.
+data RoundStats = RoundStats
+ { roundSources :: !Int -- ^ Number of distinct data sources
+ , roundKeys :: !Int -- ^ Total (deduplicated) keys fetched
+ , roundCacheHits :: !Int -- ^ Keys found in cache (skipped)
+ } deriving (Eq, Show)
+
+emptyRoundStats :: RoundStats
+emptyRoundStats = RoundStats 0 0 0
+
+-- | Execute all batches in a round. Respects FetchStrategy ordering:
+--
+-- 1. EagerStart sources dispatched first (async, high-latency head start)
+-- 2. Sequential sources dispatched one at a time (blocking)
+-- 3. Concurrent sources dispatched in parallel (async)
+-- 4. All async handles awaited
+--
+-- The two natural transformations bridge the source monad @m@ with @IO@:
+--
+-- * @lower@ runs @m@ actions in @IO@ (for dispatching @batchFetch@).
+-- * @liftM@ lifts @IO@ actions into @m@ (for IVar writes inside
+-- streaming callbacks).
+executeBatches :: forall m.
+ (forall x. m x -> IO x)
+ -> (forall x. IO x -> m x)
+ -> CacheRef
+ -> Batches m
+ -> IO RoundStats
+executeBatches lower liftM cacheRef (Batches batchMap) = do
+ let batches = Map.elems batchMap
+ (eager, sequential, concurrent) = partitionBatches batches
+
+ -- Phase 1: Start eager sources first (async, high-latency head start)
+ eagerHandles <- mapM (async . dispatchBatch lower liftM cacheRef) eager
+
+ -- Phase 2: Run sequential sources synchronously
+ seqHits <- sum <$> mapM (dispatchBatch lower liftM cacheRef) sequential
+
+ -- Phase 3: Start concurrent sources in parallel
+ concurrentHandles <- mapM (async . dispatchBatch lower liftM cacheRef) concurrent
+
+ -- Phase 4: Wait for all async work
+ eagerHits <- sum <$> mapM wait eagerHandles
+ concurrentHits <- sum <$> mapM wait concurrentHandles
+
+ let totalKeys = sum (fmap someBatchSize batches)
+ hits = eagerHits + seqHits + concurrentHits
+ pure RoundStats
+ { roundSources = length batches
+ , roundKeys = totalKeys
+ , roundCacheHits = hits
+ }
+
+-- | Number of keys in a single existentially-wrapped batch.
+someBatchSize :: SomeBatch m -> Int
+someBatchSize (SomeBatch ks) = HS.size ks
+
+-- | Partition batches by their fetch strategy.
+partitionBatches :: forall m. [SomeBatch m] -> ([SomeBatch m], [SomeBatch m], [SomeBatch m])
+partitionBatches = go [] [] []
+ where
+ go e s c [] = (reverse e, reverse s, reverse c)
+ go e s c (b@(SomeBatch (_ :: HashSet k)) : rest) =
+ case fetchStrategy @m @k Proxy of
+ EagerStart -> go (b : e) s c rest
+ Sequential -> go e (b : s) c rest
+ Concurrent -> go e s (b : c) rest
+
+-- | Dispatch a single batch: allocate IVars for new keys, call
+-- streamingFetch, and fill IVars with results. If the source throws,
+-- fill all unfilled IVars with the exception.
+-- Returns the number of cache hits (keys already in cache).
+dispatchBatch :: forall m. (forall x. m x -> IO x) -> (forall x. IO x -> m x) -> CacheRef -> SomeBatch m -> IO Int
+dispatchBatch lower liftM cacheRef (SomeBatch (ks :: HashSet k)) = do
+ let policy = cachePolicy @m @k Proxy
+ case policy of
+ CacheResults -> dispatchCached lower liftM cacheRef ks
+ NoCaching -> dispatchUncached lower liftM cacheRef ks
+
+-- | Normal path: allocate IVars, skip already-cached keys, fetch the rest.
+-- Returns the number of cache hits (keys that were already cached).
+dispatchCached :: forall m k. (DataSource m k, Typeable (Result k))
+ => (forall x. m x -> IO x) -> (forall x. IO x -> m x)
+ -> CacheRef -> HashSet k -> IO Int
+dispatchCached lower liftM cacheRef ks = do
+ let totalRequested = HS.size ks
+ newPairs <- cacheAllocate cacheRef (HS.toList ks)
+ let hits = totalRequested - length newPairs
+ runStreamingFetch lower liftM newPairs
+ pure hits
+
+-- | Uncached path for 'NoCaching' data sources.
+--
+-- IVars are still placed in the cache for result delivery /within/
+-- this round (so that deduplicated continuations from @\<*\>@ can
+-- all read the same value via 'lookupOrAwait'). However, results
+-- do not persist across rounds:
+--
+-- * 'cacheAllocateForce' overwrites any stale IVars left by a
+-- prior round, so the continuation always reads a fresh result.
+-- * @fetch@\/@tryFetch@ skip the cache check for 'NoCaching' keys,
+-- so a subsequent round always returns 'Blocked' and re-enters
+-- this dispatch path.
+--
+-- Together, these two mechanisms guarantee that the data source is
+-- called once per round the key appears in, while within-round
+-- deduplication is preserved.
+dispatchUncached :: forall m k. (DataSource m k, Typeable (Result k))
+ => (forall x. m x -> IO x) -> (forall x. IO x -> m x)
+ -> CacheRef -> HashSet k -> IO Int
+dispatchUncached lower liftM cacheRef ks = do
+ newPairs <- cacheAllocateForce cacheRef (HS.toList ks)
+ runStreamingFetch lower liftM newPairs
+ pure 0
+
+-- | Run streamingFetch for newly allocated IVars and fill any
+-- missing or errored ones. No-op when the pair list is empty
+-- (all keys were already cached or in-flight).
+runStreamingFetch :: forall m k. DataSource m k
+ => (forall x. m x -> IO x)
+ -> (forall x. IO x -> m x)
+ -> [(k, IVar (Result k))]
+ -> IO ()
+runStreamingFetch _ _ [] = pure ()
+runStreamingFetch lower liftM (p : ps) = do
+ let newPairs = p : ps
+ ivarMap = HM.fromList newPairs
+ newKeys = fst p :| map fst ps
+ -- streamingFetch runs in m; the callback lifts IO IVar writes into m.
+ -- We lower the whole m action to IO.
+ result <- try $ lower $ streamingFetch @m @k newKeys $ \k v ->
+ case HM.lookup k ivarMap of
+ Just iv -> liftM $ writeIVar iv v
+ Nothing -> pure ()
+ case result of
+ Right () -> fillUnfilled missingKeyError ivarMap
+ Left ex -> fillUnfilled ex ivarMap
+
+-- | Fill all unfilled IVars with an error.
+fillUnfilled :: SomeException -> HashMap k (IVar a) -> IO ()
+fillUnfilled ex = mapM_ $ \iv -> do
+ filled <- isIVarFilled iv
+ unless filled $ writeIVarError iv ex
+
+missingKeyError :: SomeException
+missingKeyError = toException $ FetchError "Key not returned by data source"
diff --git a/src/Fetch/IVar.hs b/src/Fetch/IVar.hs
new file mode 100644
--- /dev/null
+++ b/src/Fetch/IVar.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DerivingStrategies #-}
+
+module Fetch.IVar
+ ( IVar
+ , newIVar
+ , writeIVar
+ , writeIVarError
+ , tryReadIVar
+ , awaitIVar
+ , isIVarFilled
+ , FetchError(..)
+ ) where
+
+import Control.Concurrent.MVar
+import Control.Exception (Exception, SomeException)
+import Control.Monad (void)
+
+-- | A write-once variable with error support.
+--
+-- Used internally by the cache to track in-flight fetches.
+-- Reading blocks until the IVar is filled. Writing is idempotent:
+-- only the first write takes effect.
+newtype IVar a = IVar
+ { ivarResult :: MVar (Either SomeException a)
+ -- ^ Blocks readers until filled.
+ }
+
+-- | Create an empty IVar.
+newIVar :: IO (IVar a)
+newIVar = IVar <$> newEmptyMVar
+
+-- | Non-blocking: is this IVar already resolved?
+isIVarFilled :: IVar a -> IO Bool
+isIVarFilled = fmap not . isEmptyMVar . ivarResult
+
+-- | Non-blocking read. Returns 'Nothing' if not yet filled.
+tryReadIVar :: IVar a -> IO (Maybe (Either SomeException a))
+tryReadIVar = tryReadMVar . ivarResult
+
+-- | Blocking read. Waits until the IVar is filled.
+awaitIVar :: IVar a -> IO (Either SomeException a)
+awaitIVar = readMVar . ivarResult
+
+-- | Fill with a success value. Only the first write wins.
+writeIVar :: IVar a -> a -> IO ()
+writeIVar iv a = void $ tryPutMVar (ivarResult iv) (Right a)
+
+-- | Fill with an error. Only the first write wins.
+writeIVarError :: IVar a -> SomeException -> IO ()
+writeIVarError iv e = void $ tryPutMVar (ivarResult iv) (Left e)
+
+-- | Errors produced by the fetch engine itself (not by data sources).
+newtype FetchError = FetchError String
+ deriving stock (Eq, Show)
+ deriving anyclass (Exception)
diff --git a/src/Fetch/Memo.hs b/src/Fetch/Memo.hs
new file mode 100644
--- /dev/null
+++ b/src/Fetch/Memo.hs
@@ -0,0 +1,103 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RankNTypes #-}
+
+module Fetch.Memo
+ ( MemoKey(..)
+ , MemoStore
+ , newMemoStore
+ , memo
+ , memoOn
+ ) where
+
+import Data.Dynamic
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HM
+import Data.Hashable (Hashable)
+import Data.IORef
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Proxy
+import Type.Reflection (SomeTypeRep, someTypeRep)
+
+-- | A typed key for memoized computations.
+class (Typeable k, Hashable k, Eq k) => MemoKey k where
+ type MemoResult k
+
+-- | A mutable store for memoized computation results.
+-- Separate from the fetch cache (different lifetime, different concerns).
+newtype MemoStore = MemoStore (IORef (Map SomeTypeRep Dynamic))
+
+-- | Create an empty memo store.
+newMemoStore :: IO MemoStore
+newMemoStore = MemoStore <$> newIORef Map.empty
+
+-- | Memoize a computation by key. If the key has been computed before
+-- (in this MemoStore), return the cached result. Otherwise, run the
+-- computation and cache it.
+--
+-- __Concurrency note:__ if two threads call @memo@ with the same key
+-- concurrently and no cached value exists yet, both may execute the
+-- action. One result will be stored (last writer wins); the other is
+-- discarded. This is safe when the action is idempotent or pure, but
+-- means @memo@ is /not/ a once-only guarantee; it is a best-effort
+-- deduplication. If you need exactly-once semantics, synchronise
+-- externally (e.g. with an 'MVar' per key).
+memo :: forall k m. (MemoKey k, Typeable (MemoResult k), Monad m)
+ => MemoStore
+ -> (forall x. IO x -> m x)
+ -> k
+ -> m (MemoResult k)
+ -> m (MemoResult k)
+memo store toIO k = memoImpl store toIO (someTypeRep (Proxy @k)) k
+
+-- | Memoize with an inline key type. Convenient for one-off
+-- memoization without declaring a MemoKey instance.
+--
+-- Uses the result type for disambiguation, so beware of
+-- ambiguous types.
+--
+-- Same concurrency caveat as 'memo': concurrent calls for the
+-- same key may execute the action more than once.
+memoOn :: forall k a m. (Typeable a, Typeable k, Hashable k, Monad m)
+ => MemoStore
+ -> (forall x. IO x -> m x)
+ -> k
+ -> m a
+ -> m a
+memoOn store toIO k =
+ -- Key the store entry by (key type, result type) to disambiguate
+ -- different result types sharing the same key type.
+ memoImpl store toIO (someTypeRep (Proxy @(k, a))) k
+
+-- | Shared memoization logic. Looks up @trep@ in the store,
+-- returning the cached value if found, otherwise runs the action
+-- and atomically inserts the result.
+memoImpl :: forall k v m.
+ (Typeable k, Typeable v, Hashable k, Monad m)
+ => MemoStore
+ -> (forall x. IO x -> m x)
+ -> SomeTypeRep
+ -> k
+ -> m v
+ -> m v
+memoImpl (MemoStore ref) toIO trep k action = do
+ existing <- toIO $ atomicModifyIORef' ref $ \store ->
+ case Map.lookup trep store >>= fromDynamic of
+ Just (hm :: HashMap k v) -> (store, HM.lookup k hm)
+ Nothing -> (store, Nothing)
+ case existing of
+ Just v -> pure v
+ Nothing -> do
+ v <- action
+ -- Atomic insert: re-reads the current map to avoid clobbering
+ -- concurrent writes to other keys.
+ toIO $ atomicModifyIORef' ref $ \store ->
+ let hm :: HashMap k v
+ hm = case Map.lookup trep store >>= fromDynamic of
+ Just m -> m
+ Nothing -> HM.empty
+ in (Map.insert trep (toDyn (HM.insert k v hm)) store, ())
+ pure v
diff --git a/src/Fetch/Mock.hs b/src/Fetch/Mock.hs
new file mode 100644
--- /dev/null
+++ b/src/Fetch/Mock.hs
@@ -0,0 +1,264 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE KindSignatures #-}
+
+module Fetch.Mock
+ ( -- * Mock fetch
+ MockFetch
+ , runMockFetch
+ , ResultMap
+ , mockData
+ , emptyMockData
+ -- * Mock mutations
+ , MockMutate
+ , runMockMutate
+ , MutationHandlers
+ , mockMutation
+ , emptyMutationHandlers
+ , RecordedMutation(..)
+ ) where
+
+import Data.Kind (Type)
+
+import Fetch.Class
+import Fetch.Mutate (MonadMutate(..))
+import Fetch.IVar (FetchError(..))
+
+import Control.Exception (toException, try, evaluate, throw, throwIO)
+import Control.Monad.Catch (MonadThrow(..), MonadCatch(..))
+import Data.Dynamic
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HM
+import Data.IORef
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Type.Reflection (SomeTypeRep(..), someTypeRep, typeOf)
+
+-- | Pre-built result data for testing. Each entry wraps a
+-- @HashMap k (Result k)@ as a Dynamic, keyed by source type.
+newtype ResultMap = ResultMap (Map SomeTypeRep Dynamic)
+
+instance Semigroup ResultMap where
+ ResultMap a <> ResultMap b = ResultMap (Map.union a b)
+
+instance Monoid ResultMap where
+ mempty = ResultMap Map.empty
+
+-- | Create mock data for a specific key type.
+--
+-- @mockData \@UserId [(UserId 1, testUser), (UserId 2, otherUser)]@
+mockData :: forall k. (FetchKey k, Typeable (Result k))
+ => [(k, Result k)] -> ResultMap
+mockData pairs = ResultMap $
+ Map.singleton
+ (someTypeRep (Proxy @k))
+ (toDyn (HM.fromList pairs :: HashMap k (Result k)))
+
+-- | Empty mock data.
+emptyMockData :: ResultMap
+emptyMockData = mempty
+
+-- | Look up a key in the mock data.
+lookupMock :: forall k. (FetchKey k, Typeable (Result k))
+ => ResultMap -> k -> Either SomeException (Result k)
+lookupMock (ResultMap m) k =
+ case Map.lookup (someTypeRep (Proxy @k)) m >>= fromDynamic of
+ Just (hm :: HashMap k (Result k)) ->
+ case HM.lookup k hm of
+ Just v -> Right v
+ Nothing -> Left $ toException $ FetchError $
+ "Mock data missing key: " <> show k
+ Nothing -> Left $ toException $ FetchError $
+ "No mock data for source: " <> show (someTypeRep (Proxy @k))
+
+-- | A test-oriented MonadFetch that reads from a pre-built result map.
+-- No IO, no batching, no caching. Just direct lookups.
+--
+-- The @m@ phantom type parameter means the same @MonadFetch m n@
+-- constraints work in both production and test code. Users specify
+-- @m@ at the call site (e.g. @runMockFetch \@AppM mocks action@).
+-- | @m@ is a phantom type representing the source monad (for instance selection).
+newtype MockFetch (m :: Type -> Type) n a = MockFetch { unMockFetch :: ResultMap -> n a }
+
+instance Functor n => Functor (MockFetch m n) where
+ fmap f (MockFetch g) = MockFetch (fmap f . g)
+
+instance Applicative n => Applicative (MockFetch m n) where
+ pure a = MockFetch $ \_ -> pure a
+ MockFetch ff <*> MockFetch fx = MockFetch $ \rm ->
+ ff rm <*> fx rm
+
+instance Monad n => Monad (MockFetch m n) where
+ MockFetch ma >>= f = MockFetch $ \rm -> do
+ a <- ma rm
+ unMockFetch (f a) rm
+
+-- | Note: the 'DataSource m k' constraint is still required for
+-- type inference, but the batchFetch is never used.
+-- Only the ResultMap is consulted.
+instance Monad n => MonadFetch m (MockFetch m n) where
+ fetch k = MockFetch $ \rm ->
+ case lookupMock rm k of
+ Right v -> pure v
+ Left ex -> throw ex
+
+ tryFetch k = MockFetch $ \rm ->
+ pure (lookupMock rm k)
+
+ primeCache _ _ = pure ()
+
+instance MonadFail n => MonadFail (MockFetch m n) where
+ fail msg = MockFetch $ \_ -> fail msg
+
+instance MonadThrow n => MonadThrow (MockFetch m n) where
+ throwM e = MockFetch $ \_ -> throwM e
+
+instance MonadCatch n => MonadCatch (MockFetch m n) where
+ catch (MockFetch f) handler = MockFetch $ \rm ->
+ catch (f rm) (\e -> unMockFetch (handler e) rm)
+
+-- | Run a computation against mock data.
+--
+-- @
+-- testGetUserFeed :: IO ()
+-- testGetUserFeed = do
+-- let mocks = mockData \@UserId [(UserId 1, testUser)]
+-- <> mockData \@PostsByAuthor [(PostsByAuthor 1, [testPost])]
+-- feed <- runMockFetch \@AppM mocks (getUserFeed (UserId 1))
+-- assertEqual (feedUser feed) testUser
+-- @
+runMockFetch :: ResultMap -> MockFetch m n a -> n a
+runMockFetch rm (MockFetch f) = f rm
+
+-- ──────────────────────────────────────────────
+-- Mock mutation support
+-- ──────────────────────────────────────────────
+
+-- | A map of mutation handlers, keyed by mutation key type.
+-- Each handler is a @Dynamic@-wrapped @k -> MutationResult k@.
+newtype MutationHandlers = MutationHandlers (Map SomeTypeRep Dynamic)
+
+instance Semigroup MutationHandlers where
+ MutationHandlers a <> MutationHandlers b = MutationHandlers (Map.union a b)
+
+instance Monoid MutationHandlers where
+ mempty = MutationHandlers Map.empty
+
+-- | Empty mutation handlers.
+emptyMutationHandlers :: MutationHandlers
+emptyMutationHandlers = mempty
+
+-- | Register a mock handler for a mutation key type.
+--
+-- @mockMutation \@UpdateUser (\\(UpdateUser uid name) -> User uid name)@
+mockMutation :: forall k. (MutationKey k, Typeable (MutationResult k))
+ => (k -> MutationResult k) -> MutationHandlers
+mockMutation handler = MutationHandlers $
+ Map.singleton
+ (someTypeRep (Proxy @k))
+ (toDyn handler)
+
+-- | Look up a mutation handler.
+lookupMutationHandler :: forall k. (MutationKey k, Typeable (MutationResult k))
+ => MutationHandlers -> k -> Either SomeException (MutationResult k)
+lookupMutationHandler (MutationHandlers m) k =
+ case Map.lookup (someTypeRep (Proxy @k)) m >>= fromDynamic of
+ Just (handler :: k -> MutationResult k) -> Right (handler k)
+ Nothing -> Left $ toException $ FetchError $
+ "No mock mutation handler for: " <> show (someTypeRep (Proxy @k))
+
+-- | A recorded mutation: captures the type and the existentially-wrapped
+-- key for assertions. Pattern match on 'recordedMutationKey' when you
+-- need to inspect the concrete key value.
+data RecordedMutation = forall k. MutationKey k
+ => RecordedMutation
+ { recordedMutationType :: !SomeTypeRep
+ , recordedMutationKey :: !k
+ }
+
+instance Show RecordedMutation where
+ show (RecordedMutation tr _) =
+ "RecordedMutation " <> show tr
+
+-- | A test-oriented monad that supports both fetches (from 'ResultMap')
+-- and mutations (from 'MutationHandlers'), recording all mutations
+-- for assertions.
+-- | @m@ is a phantom type representing the source monad (for instance selection).
+newtype MockMutate (m :: Type -> Type) n a = MockMutate
+ { unMockMutate :: ResultMap -> MutationHandlers -> IORef [RecordedMutation] -> n a }
+
+instance Functor n => Functor (MockMutate m n) where
+ fmap f (MockMutate g) = MockMutate $ \rm mh ref -> fmap f (g rm mh ref)
+
+instance Applicative n => Applicative (MockMutate m n) where
+ pure a = MockMutate $ \_ _ _ -> pure a
+ MockMutate ff <*> MockMutate fx = MockMutate $ \rm mh ref ->
+ ff rm mh ref <*> fx rm mh ref
+
+instance Monad n => Monad (MockMutate m n) where
+ MockMutate ma >>= f = MockMutate $ \rm mh ref -> do
+ a <- ma rm mh ref
+ unMockMutate (f a) rm mh ref
+
+instance (Monad n, n ~ IO) => MonadFetch m (MockMutate m n) where
+ fetch k = MockMutate $ \rm _ _ ->
+ case lookupMock rm k of
+ Right v -> pure v
+ Left ex -> throwIO ex
+ tryFetch k = MockMutate $ \rm _ _ ->
+ pure (lookupMock rm k)
+ primeCache _ _ = pure ()
+
+instance (Monad n, n ~ IO) => MonadMutate m (MockMutate m n) where
+ mutate k = MockMutate $ \_ mh ref ->
+ case lookupMutationHandler mh k of
+ Right v -> do
+ let tr = SomeTypeRep (typeOf k)
+ atomicModifyIORef' ref $ \recs ->
+ (recs <> [RecordedMutation tr k], ())
+ pure v
+ Left ex -> throwIO ex
+
+ tryMutate k = MockMutate $ \_ mh ref -> do
+ result <- try $ evaluate $ lookupMutationHandler mh k
+ case result of
+ Right (Right v) -> do
+ let tr = SomeTypeRep (typeOf k)
+ atomicModifyIORef' ref $ \recs ->
+ (recs <> [RecordedMutation tr k], ())
+ pure (Right v)
+ Right (Left ex) -> pure (Left ex)
+ Left ex -> pure (Left ex)
+
+instance MonadFail n => MonadFail (MockMutate m n) where
+ fail msg = MockMutate $ \_ _ _ -> fail msg
+
+instance MonadThrow n => MonadThrow (MockMutate m n) where
+ throwM e = MockMutate $ \_ _ _ -> throwM e
+
+instance MonadCatch n => MonadCatch (MockMutate m n) where
+ catch (MockMutate f) handler = MockMutate $ \rm mh ref ->
+ catch (f rm mh ref) (\e -> unMockMutate (handler e) rm mh ref)
+
+-- | Run a computation against mock data and mutation handlers.
+-- Returns the result and a list of recorded mutations.
+--
+-- @
+-- let mocks = mockData \@UserId [(UserId 1, User 1 "alice")]
+-- handlers = mockMutation \@UpdateUser (\\(UpdateUser uid name) -> User uid name)
+-- (result, mutations) <- runMockMutate \@AppM mocks handlers myAction
+-- length mutations \`shouldBe\` 1
+-- @
+runMockMutate :: ResultMap -> MutationHandlers -> MockMutate m IO a -> IO (a, [RecordedMutation])
+runMockMutate rm mh (MockMutate f) = do
+ ref <- newIORef []
+ a <- f rm mh ref
+ mutations <- readIORef ref
+ pure (a, mutations)
diff --git a/src/Fetch/Mutate.hs b/src/Fetch/Mutate.hs
new file mode 100644
--- /dev/null
+++ b/src/Fetch/Mutate.hs
@@ -0,0 +1,253 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE TypeApplications #-}
+
+-- | Principled mutation support for sofetch.
+--
+-- 'Mutate' is a free-monad-like transformer layered on top of 'Fetch'.
+-- A computation is a sequence of __fetch phases__ (batched reads via
+-- 'Fetch') interleaved with __mutation steps__ (sequential writes).
+--
+-- Mutations are inert data during 'Fetch' probing; they only
+-- execute when the runner processes them. This guarantees:
+--
+-- * Within a fetch phase: all fetches batch via 'Fetch'\'s 'Applicative'.
+-- * Between phases: mutations execute one at a time, sequentially.
+-- * In @\<*\>@: fetches run first (batched), then mutations left-to-right.
+-- * Cache consistency: 'reconcileCache' runs after each mutation,
+-- before any subsequent fetch phase sees the cache.
+module Fetch.Mutate
+ ( -- * Mutation classes
+ MutationSource(..)
+ , MonadMutate(..)
+ -- * Mutate transformer
+ , Mutate(..)
+ , Step(..)
+ , liftFetch
+ -- * Runners
+ , runMutate
+ ) where
+
+import Fetch.Class
+import Fetch.Cache (CacheRef, newCacheRef)
+import Fetch.Batched (Fetch, FetchConfig(..), runFetch)
+
+import Control.Exception (try)
+import Control.Monad.Catch (MonadThrow(..), MonadCatch(..))
+
+-- ──────────────────────────────────────────────
+-- MutationSource
+-- ──────────────────────────────────────────────
+
+-- | How to execute a mutation in the source monad @m@.
+--
+-- The @m@ parameter replaces the old @env@ parameter, just as
+-- in 'DataSource'. The monad @m@ provides access to any needed
+-- resources (database connections, etc.).
+--
+-- @
+-- instance MutationSource AppM UpdateUserName where
+-- executeMutation (UpdateUserName uid name) =
+-- updateUserInDB uid name
+--
+-- reconcileCache (UpdateUserName uid _) result cRef =
+-- cacheWarm cRef (HM.singleton (UserId uid) result)
+-- @
+class (MutationKey k, Typeable (MutationResult k)) => MutationSource m k where
+ -- | Execute the mutation. Called by the runner, never during
+ -- 'Fetch' probing.
+ executeMutation :: k -> m (MutationResult k)
+
+ -- | Reconcile the cache after a successful mutation.
+ -- Use this to evict stale entries or warm the cache with
+ -- fresh data from the mutation response.
+ --
+ -- Note: 'reconcileCache' runs in @IO@ because cache operations
+ -- are inherently @IO@-based ('CacheRef' is an 'IORef').
+ --
+ -- Default: no-op.
+ reconcileCache :: k -> MutationResult k -> CacheRef -> IO ()
+ reconcileCache _ _ _ = pure ()
+
+-- ──────────────────────────────────────────────
+-- MonadMutate
+-- ──────────────────────────────────────────────
+
+-- | The mutation interface. Extends 'MonadFetch' with write operations.
+--
+-- @mutate@ ends the current fetch phase, executes the mutation via
+-- the runner, reconciles the cache, and returns the result. Subsequent
+-- fetches see the reconciled cache.
+class MonadFetch m n => MonadMutate m n | n -> m where
+ -- | Execute a mutation. Throws on error.
+ mutate :: MutationSource m k => k -> n (MutationResult k)
+
+ -- | Execute a mutation with explicit error handling.
+ tryMutate :: MutationSource m k
+ => k -> n (Either SomeException (MutationResult k))
+
+-- ──────────────────────────────────────────────
+-- Step
+-- ──────────────────────────────────────────────
+
+-- | The result of a fetch phase: either a final value or a mutation
+-- boundary with a continuation.
+data Step m n a
+ = StepDone a
+ | forall k. MutationSource m k
+ => StepMutate k (MutationResult k -> Mutate m n a)
+ | forall k. MutationSource m k
+ => StepTryMutate k (Either SomeException (MutationResult k) -> Mutate m n a)
+
+-- | Map a function over the final value of a 'Step'.
+mapStep :: Monad n => (a -> b) -> Step m n a -> Step m n b
+mapStep f (StepDone a) = StepDone (f a)
+mapStep f (StepMutate k cont) = StepMutate k (fmap f . cont)
+mapStep f (StepTryMutate k cont) = StepTryMutate k (fmap f . cont)
+
+-- | Combine two 'Step' values applicatively.
+-- Fetch-phase results combine directly; mutations sequence left-to-right.
+apStep :: Monad n => Step m n (a -> b) -> Step m n a -> Step m n b
+apStep (StepDone f) (StepDone x) =
+ StepDone (f x)
+apStep (StepDone f) (StepMutate k cont) =
+ StepMutate k (fmap f . cont)
+apStep (StepDone f) (StepTryMutate k cont) =
+ StepTryMutate k (fmap f . cont)
+apStep (StepMutate k cont) (StepDone x) =
+ StepMutate k (fmap ($ x) . cont)
+apStep (StepTryMutate k cont) (StepDone x) =
+ StepTryMutate k (fmap ($ x) . cont)
+-- Two mutations: sequence left first, then embed the right step
+-- into the left's continuation.
+apStep (StepMutate k1 cont1) step2 =
+ StepMutate k1 $ \r1 ->
+ cont1 r1 <*> embedStep step2
+apStep (StepTryMutate k1 cont1) step2 =
+ StepTryMutate k1 $ \r1 ->
+ cont1 r1 <*> embedStep step2
+
+-- | Inject a 'Step' into 'Mutate' as a trivial fetch phase.
+embedStep :: Monad n => Step m n a -> Mutate m n a
+embedStep (StepDone a) = Mutate (pure (StepDone a))
+embedStep (StepMutate k cont) = Mutate (pure (StepMutate k cont))
+embedStep (StepTryMutate k cont) = Mutate (pure (StepTryMutate k cont))
+
+-- ──────────────────────────────────────────────
+-- Mutate
+-- ──────────────────────────────────────────────
+
+-- | A computation that interleaves batched fetch phases with
+-- sequential mutations.
+--
+-- @m@ is the source monad (same as in 'DataSource' and 'Fetch').
+-- @n@ is the base monad for 'Fetch'.
+--
+-- In practice, @n@ is always @m@ and 'Mutate m m' is layered on
+-- 'Fetch m'.
+--
+-- @
+-- do (user, posts) <- (,) \<$\> fetch uid \<*\> fetch pid -- batched
+-- updated <- mutate (UpdateUserName uid "new") -- mutation boundary
+-- fetch uid -- cache hit
+-- @
+newtype Mutate m n a = Mutate
+ { unMutate :: Fetch n (Step m n a) }
+
+instance Monad n => Functor (Mutate m n) where
+ fmap f (Mutate inner) = Mutate (fmap (mapStep f) inner)
+
+instance Monad n => Applicative (Mutate m n) where
+ pure a = Mutate (pure (StepDone a))
+
+ Mutate ff <*> Mutate fx = Mutate $
+ -- Delegate to Fetch's Applicative for batching, then combine Steps.
+ liftA2 apStep ff fx
+
+instance Monad n => Monad (Mutate m n) where
+ Mutate ma >>= f = Mutate $ do
+ step <- ma -- runs in Fetch
+ case step of
+ StepDone a -> unMutate (f a) -- continue in same Fetch phase
+ StepMutate k cont ->
+ pure $ StepMutate k (\r -> cont r >>= f)
+ StepTryMutate k cont ->
+ pure $ StepTryMutate k (\r -> cont r >>= f)
+
+-- ──────────────────────────────────────────────
+-- Instances
+-- ──────────────────────────────────────────────
+
+instance Monad m => MonadFetch m (Mutate m m) where
+ fetch k = Mutate (StepDone <$> fetch k)
+ tryFetch k = Mutate (StepDone <$> tryFetch k)
+ primeCache k v = Mutate (StepDone <$> primeCache k v)
+
+instance Monad m => MonadMutate m (Mutate m m) where
+ mutate k = Mutate (pure (StepMutate k pure))
+ tryMutate k = Mutate (pure (StepTryMutate k pure))
+
+instance MonadFail m => MonadFail (Mutate m m) where
+ fail msg = Mutate (fail msg)
+
+instance MonadThrow m => MonadThrow (Mutate m m) where
+ throwM e = Mutate (throwM e)
+
+-- | Propagates the handler through both 'Fetch' round continuations
+-- (handled by 'Fetch'\'s 'MonadCatch') and 'Step' mutation
+-- continuations.
+instance MonadCatch m => MonadCatch (Mutate m m) where
+ catch (Mutate inner) handler = Mutate $
+ fmap catchStep $
+ catch inner (\ex -> unMutate (handler ex))
+ where
+ catchStep (StepDone a) = StepDone a
+ catchStep (StepMutate k cont) = StepMutate k (\r -> catch (cont r) handler)
+ catchStep (StepTryMutate k cont) = StepTryMutate k (\r -> catch (cont r) handler)
+
+-- | Lift a 'Fetch' computation into 'Mutate'.
+-- The entire 'Fetch' runs as a single fetch phase.
+liftFetch :: Monad m => Fetch m a -> Mutate m m a
+liftFetch action = Mutate (StepDone <$> action)
+
+-- ──────────────────────────────────────────────
+-- Runners
+-- ──────────────────────────────────────────────
+
+-- | Run a 'Mutate' computation.
+--
+-- @
+-- let cfg = fetchConfig (runAppM env) liftIO
+-- runMutate cfg action
+-- @
+runMutate :: forall m a. Monad m => FetchConfig m -> Mutate m m a -> m a
+runMutate cfg action = do
+ cRef <- case configCache cfg of
+ Just ref -> pure ref
+ Nothing -> configLift cfg newCacheRef
+ let fetchCfg = cfg { configCache = Just cRef }
+ go :: Mutate m m a -> m a
+ go (Mutate fetchPhase) = do
+ step <- runFetch fetchCfg fetchPhase
+ case step of
+ StepDone a -> pure a
+ StepMutate k cont -> do
+ result <- executeMutation k
+ configLift cfg $ reconcileCache @m k result cRef
+ go (cont result)
+ StepTryMutate k cont -> do
+ result <- configLift cfg $ try $ configLower cfg $ executeMutation k
+ case result of
+ Right v -> do
+ configLift cfg $ reconcileCache @m k v cRef
+ go (cont (Right v))
+ Left ex ->
+ go (cont (Left ex))
+ go action
diff --git a/src/Fetch/Traced.hs b/src/Fetch/Traced.hs
new file mode 100644
--- /dev/null
+++ b/src/Fetch/Traced.hs
@@ -0,0 +1,118 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DerivingStrategies #-}
+
+module Fetch.Traced
+ ( TracedFetch
+ , TraceConfig(..)
+ , defaultTraceConfig
+ , FetchStats(..)
+ , runTracedFetch
+ ) where
+
+import Fetch.Class
+import Fetch.Cache
+import Fetch.Batched (Fetch(..), FetchConfig(..), FetchEnv(..), runLoopWith)
+import Fetch.Engine (RoundStats(..))
+
+import Control.Monad.Catch (MonadThrow(..), MonadCatch(..))
+import Data.IORef
+import Data.Time.Clock (NominalDiffTime, getCurrentTime, diffUTCTime)
+
+-- | Callbacks for observing the batching process.
+data TraceConfig m = TraceConfig
+ { onRoundStart :: Int -> Batches m -> m ()
+ -- ^ Called before each round with round number and pending batches.
+ , onRoundComplete :: Int -> RoundStats -> m ()
+ -- ^ Called after each round.
+ , onFetchComplete :: FetchStats -> m ()
+ -- ^ Called when the entire computation finishes.
+ }
+
+-- | No-op trace config.
+defaultTraceConfig :: Applicative m => TraceConfig m
+defaultTraceConfig = TraceConfig
+ { onRoundStart = \_ _ -> pure ()
+ , onRoundComplete = \_ _ -> pure ()
+ , onFetchComplete = \_ -> pure ()
+ }
+
+-- | Aggregate stats for an entire Fetch computation.
+data FetchStats = FetchStats
+ { totalRounds :: !Int
+ , totalKeys :: !Int
+ , maxSourcesPerRound :: !Int
+ -- ^ Peak number of distinct data sources dispatched in any single round.
+ , totalTime :: !NominalDiffTime
+ } deriving (Eq, Show)
+
+-- | A traced variant of Fetch. Same batching\/caching behavior,
+-- just adds observability hooks.
+--
+-- This is a newtype over 'Fetch' so it shares the exact same
+-- Applicative batching. The tracing happens at the runner level.
+--
+-- All instances are derived via @GeneralizedNewtypeDeriving@.
+-- If you define your own newtype over 'Fetch', you can use the
+-- same pattern:
+--
+-- @
+-- {-\# LANGUAGE GeneralizedNewtypeDeriving, DerivingStrategies \#-}
+--
+-- newtype MyFetch m a = MyFetch (Fetch m a)
+-- deriving newtype
+-- ( Functor, Applicative, Monad
+-- , MonadFail, MonadThrow, MonadCatch
+-- , MonadFetch m
+-- )
+-- @
+newtype TracedFetch m a = TracedFetch (Fetch m a)
+ deriving newtype
+ ( Functor, Applicative, Monad
+ , MonadFail, MonadThrow, MonadCatch
+ , MonadFetch m
+ )
+
+-- | Run with tracing. Fires callbacks at each round boundary.
+runTracedFetch :: Monad m
+ => FetchConfig m
+ -> TraceConfig m
+ -> TracedFetch m a
+ -> m (a, FetchStats)
+runTracedFetch cfg tc (TracedFetch action) = do
+ cacheRef <- case configCache cfg of
+ Just ref -> pure ref
+ Nothing -> configLift cfg newCacheRef
+ startTime <- configLift cfg getCurrentTime
+ statsRef <- configLift cfg $ newIORef (FetchStats 0 0 0 0)
+
+ let e = FetchEnv
+ { fetchCache = cacheRef
+ , fetchLower = configLower cfg
+ , fetchLift = configLift cfg
+ }
+
+ withRound n batches exec = do
+ onRoundStart tc n batches
+ rs <- exec
+ configLift cfg $ modifyIORef' statsRef $ \s -> s
+ { totalRounds = totalRounds s + 1
+ , totalKeys = totalKeys s + roundKeys rs
+ , maxSourcesPerRound = max (maxSourcesPerRound s) (roundSources rs)
+ }
+ onRoundComplete tc n rs
+
+ a <- runLoopWith e withRound action
+
+ endTime <- configLift cfg getCurrentTime
+ configLift cfg $ modifyIORef' statsRef $ \s ->
+ s { totalTime = diffUTCTime endTime startTime }
+ stats <- configLift cfg $ readIORef statsRef
+
+ onFetchComplete tc stats
+ pure (a, stats)
diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
--- /dev/null
+++ b/test/Spec.hs
@@ -0,0 +1,3215 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+
+module Main (main) where
+
+import Fetch
+import Fetch.Batched (Fetch(..))
+import Fetch.Class (singletonBatch, batchKeys)
+import Fetch.Combinators (biselect, pAnd, pOr)
+import Fetch.IVar
+import Fetch.Cache
+
+import Control.Concurrent (forkIO)
+import Control.Concurrent.Async (async, wait, waitCatch, cancel, replicateConcurrently_)
+import Control.Concurrent.MVar
+import Control.Exception (SomeException, toException, try, throwTo)
+import qualified Control.Monad.Catch as MC
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HM
+import Data.IORef
+import qualified Data.List.NonEmpty as NE
+import Data.Maybe (mapMaybe)
+import GHC.Generics (Generic)
+import Test.Hspec
+
+-- ══════════════════════════════════════════════
+-- Test key types and data sources
+-- ══════════════════════════════════════════════
+
+newtype UserId = UserId Int
+ deriving stock (Eq, Ord, Show, Generic)
+ deriving anyclass (Hashable)
+
+instance FetchKey UserId where
+ type Result UserId = String
+
+newtype PostId = PostId Int
+ deriving stock (Eq, Ord, Show, Generic)
+ deriving anyclass (Hashable)
+
+instance FetchKey PostId where
+ type Result PostId = String
+
+-- | Key type with Sequential fetch strategy.
+newtype SeqKey = SeqKey Int
+ deriving stock (Eq, Ord, Show, Generic)
+ deriving anyclass (Hashable)
+
+instance FetchKey SeqKey where
+ type Result SeqKey = String
+
+-- | Key type with EagerStart fetch strategy.
+newtype EagerKey = EagerKey Int
+ deriving stock (Eq, Ord, Show, Generic)
+ deriving anyclass (Hashable)
+
+instance FetchKey EagerKey where
+ type Result EagerKey = String
+
+-- | Key type whose data source always throws.
+newtype FailKey = FailKey Int
+ deriving stock (Eq, Ord, Show, Generic)
+ deriving anyclass (Hashable)
+
+instance FetchKey FailKey where
+ type Result FailKey = String
+
+-- | Key type with NoCaching policy.
+newtype MutKey = MutKey Int
+ deriving stock (Eq, Ord, Show, Generic)
+ deriving anyclass (Hashable)
+
+instance FetchKey MutKey where
+ type Result MutKey = Int
+
+-- | Key type whose data source blocks on a barrier before returning.
+newtype SlowKey = SlowKey Int
+ deriving stock (Eq, Ord, Show, Generic)
+ deriving anyclass (Hashable)
+
+instance FetchKey SlowKey where
+ type Result SlowKey = String
+
+-- | Key type that always returns a value for any Int key.
+-- Used for high-fan-out stress tests.
+newtype RangeKey = RangeKey Int
+ deriving stock (Eq, Ord, Show, Generic)
+ deriving anyclass (Hashable)
+
+instance FetchKey RangeKey where
+ type Result RangeKey = String
+
+-- | Key type whose source only returns results for even-numbered keys.
+-- Odd keys are silently omitted, triggering fillUnfilled.
+newtype PartialKey = PartialKey Int
+ deriving stock (Eq, Ord, Show, Generic)
+ deriving anyclass (Hashable)
+
+instance FetchKey PartialKey where
+ type Result PartialKey = String
+
+-- | Second Sequential-strategy source for ordering tests.
+newtype SeqKey2 = SeqKey2 Int
+ deriving stock (Eq, Ord, Show, Generic)
+ deriving anyclass (Hashable)
+
+instance FetchKey SeqKey2 where
+ type Result SeqKey2 = String
+
+-- | Sequential strategy + always throws.
+newtype FailSeqKey = FailSeqKey Int
+ deriving stock (Eq, Ord, Show, Generic)
+ deriving anyclass (Hashable)
+
+instance FetchKey FailSeqKey where
+ type Result FailSeqKey = String
+
+-- | EagerStart strategy + always throws.
+newtype FailEagerKey = FailEagerKey Int
+ deriving stock (Eq, Ord, Show, Generic)
+ deriving anyclass (Hashable)
+
+instance FetchKey FailEagerKey where
+ type Result FailEagerKey = String
+
+-- | Key whose batchFetch signals on a barrier before blocking.
+-- Used for async exception tests.
+newtype BlockingKey = BlockingKey Int
+ deriving stock (Eq, Ord, Show, Generic)
+ deriving anyclass (Hashable)
+
+instance FetchKey BlockingKey where
+ type Result BlockingKey = String
+
+-- ══════════════════════════════════════════════
+-- Test environment and monad
+-- ══════════════════════════════════════════════
+
+data TestEnv = TestEnv
+ { envUsers :: HashMap UserId String
+ , envUserLog :: IORef [[UserId]]
+ , envPosts :: HashMap PostId String
+ , envPostLog :: IORef [[PostId]]
+ , envMutLog :: IORef [[MutKey]]
+ , envMutCount :: IORef Int
+ , envSlowBarrier :: MVar ()
+ , envDispatchLog :: IORef [String]
+ -- ^ Each source's batchFetch atomically appends its type name.
+ , envAsyncStarted :: MVar ()
+ -- ^ BlockingKey's batchFetch signals here when it enters.
+ , envAsyncProceed :: MVar ()
+ -- ^ BlockingKey's batchFetch blocks here until released.
+ }
+
+mkTestEnv :: IO TestEnv
+mkTestEnv = TestEnv
+ <$> pure defaultUsers
+ <*> newIORef []
+ <*> pure defaultPosts
+ <*> newIORef []
+ <*> newIORef []
+ <*> newIORef 0
+ <*> newMVar () -- starts full so non-SlowKey tests are unaffected
+ <*> newIORef []
+ <*> newEmptyMVar -- envAsyncStarted: empty until BlockingKey signals
+ <*> newEmptyMVar -- envAsyncProceed: empty until test releases
+
+defaultUsers :: HashMap UserId String
+defaultUsers = HM.fromList
+ [ (UserId 1, "Alice")
+ , (UserId 2, "Bob")
+ , (UserId 3, "Carol")
+ ]
+
+defaultPosts :: HashMap PostId String
+defaultPosts = HM.fromList
+ [ (PostId 10, "Hello World")
+ , (PostId 20, "Haskell Tips")
+ , (PostId 30, "Type Families")
+ ]
+
+-- | The test monad. A thin Reader over IO carrying 'TestEnv'.
+-- This is what 'DataSource' instances run in.
+newtype TestM a = TestM { unTestM :: TestEnv -> IO a }
+
+instance Functor TestM where
+ fmap f (TestM g) = TestM $ \env -> fmap f (g env)
+
+instance Applicative TestM where
+ pure a = TestM $ \_ -> pure a
+ TestM ff <*> TestM fx = TestM $ \env -> ff env <*> fx env
+
+instance Monad TestM where
+ TestM ma >>= f = TestM $ \env -> do
+ a <- ma env
+ unTestM (f a) env
+
+askTestEnv :: TestM TestEnv
+askTestEnv = TestM pure
+
+-- | Lift an IO action into TestM.
+testLiftIO :: IO a -> TestM a
+testLiftIO io = TestM $ \_ -> io
+
+-- | Run a TestM action in IO, given the environment.
+runTestM :: TestEnv -> TestM a -> IO a
+runTestM env (TestM f) = f env
+
+-- ══════════════════════════════════════════════
+-- DataSource instances
+-- ══════════════════════════════════════════════
+
+instance DataSource TestM UserId where
+ batchFetch keysNE = do
+ let keys = NE.toList keysNE
+ env <- askTestEnv
+ testLiftIO $ modifyIORef' (envUserLog env) (keys :)
+ testLiftIO $ atomicModifyIORef' (envDispatchLog env) (\l -> (l ++ ["UserId"], ()))
+ pure $ HM.fromList
+ (mapMaybe (\k -> fmap (\v -> (k, v)) (HM.lookup k (envUsers env))) keys)
+
+instance DataSource TestM PostId where
+ batchFetch keysNE = do
+ let keys = NE.toList keysNE
+ env <- askTestEnv
+ testLiftIO $ modifyIORef' (envPostLog env) (keys :)
+ testLiftIO $ atomicModifyIORef' (envDispatchLog env) (\l -> (l ++ ["PostId"], ()))
+ pure $ HM.fromList
+ (mapMaybe (\k -> fmap (\v -> (k, v)) (HM.lookup k (envPosts env))) keys)
+
+instance DataSource TestM SeqKey where
+ batchFetch keysNE = do
+ env <- askTestEnv
+ testLiftIO $ atomicModifyIORef' (envDispatchLog env) (\l -> (l ++ ["SeqKey"], ()))
+ pure $ HM.fromList
+ (map (\k@(SeqKey n) -> (k, "seq-" <> show n)) (NE.toList keysNE))
+ fetchStrategy _ = Sequential
+
+instance DataSource TestM EagerKey where
+ batchFetch keysNE = do
+ env <- askTestEnv
+ testLiftIO $ atomicModifyIORef' (envDispatchLog env) (\l -> (l ++ ["EagerKey"], ()))
+ pure $ HM.fromList
+ (map (\k@(EagerKey n) -> (k, "eager-" <> show n)) (NE.toList keysNE))
+ fetchStrategy _ = EagerStart
+
+instance DataSource TestM FailKey where
+ batchFetch _ = do
+ env <- askTestEnv
+ testLiftIO $ atomicModifyIORef' (envDispatchLog env) (\l -> (l ++ ["FailKey"], ()))
+ error "FailKey data source exploded"
+
+instance DataSource TestM MutKey where
+ batchFetch keysNE = do
+ let keys = NE.toList keysNE
+ env <- askTestEnv
+ testLiftIO $ modifyIORef' (envMutLog env) (keys :)
+ n <- testLiftIO $ atomicModifyIORef' (envMutCount env) (\c -> (c + 1, c))
+ pure $ HM.fromList (map (\k -> (k, n)) keys)
+ cachePolicy _ = NoCaching
+
+instance DataSource TestM SlowKey where
+ batchFetch keysNE = do
+ env <- askTestEnv
+ testLiftIO $ takeMVar (envSlowBarrier env) -- block until test releases
+ pure $ HM.fromList
+ (map (\k@(SlowKey n) -> (k, "slow-" <> show n)) (NE.toList keysNE))
+
+instance DataSource TestM RangeKey where
+ batchFetch keysNE =
+ pure $ HM.fromList
+ (map (\k@(RangeKey n) -> (k, "range-" <> show n)) (NE.toList keysNE))
+
+instance DataSource TestM PartialKey where
+ batchFetch keysNE = do
+ env <- askTestEnv
+ testLiftIO $ atomicModifyIORef' (envDispatchLog env) (\l -> (l ++ ["PartialKey"], ()))
+ -- Only return results for even-numbered keys; odd keys are silently omitted.
+ pure $ HM.fromList
+ (mapMaybe (\k@(PartialKey n) ->
+ if even n then Just (k, "partial-" <> show n) else Nothing)
+ (NE.toList keysNE))
+
+instance DataSource TestM SeqKey2 where
+ batchFetch keysNE = do
+ env <- askTestEnv
+ testLiftIO $ atomicModifyIORef' (envDispatchLog env) (\l -> (l ++ ["SeqKey2"], ()))
+ pure $ HM.fromList
+ (map (\k@(SeqKey2 n) -> (k, "seq2-" <> show n)) (NE.toList keysNE))
+ fetchStrategy _ = Sequential
+
+instance DataSource TestM FailSeqKey where
+ batchFetch _ = do
+ env <- askTestEnv
+ testLiftIO $ atomicModifyIORef' (envDispatchLog env) (\l -> (l ++ ["FailSeqKey"], ()))
+ error "FailSeqKey data source exploded"
+ fetchStrategy _ = Sequential
+
+instance DataSource TestM FailEagerKey where
+ batchFetch _ = do
+ env <- askTestEnv
+ testLiftIO $ atomicModifyIORef' (envDispatchLog env) (\l -> (l ++ ["FailEagerKey"], ()))
+ error "FailEagerKey data source exploded"
+ fetchStrategy _ = EagerStart
+
+instance DataSource TestM BlockingKey where
+ batchFetch keysNE = do
+ env <- askTestEnv
+ -- Signal that the batch has entered
+ testLiftIO $ putMVar (envAsyncStarted env) ()
+ -- Block until the test releases
+ testLiftIO $ takeMVar (envAsyncProceed env)
+ pure $ HM.fromList
+ (map (\k@(BlockingKey n) -> (k, "blocking-" <> show n)) (NE.toList keysNE))
+
+-- ══════════════════════════════════════════════
+-- Helpers
+-- ══════════════════════════════════════════════
+
+-- | Run a Fetch computation over TestM in IO.
+runTest :: TestEnv -> Fetch TestM a -> IO a
+runTest env = runTestM env . runFetch (fetchConfig (runTestM env) testLiftIO)
+
+-- | Run a Fetch computation with an externally-provided cache.
+runTestWithCache :: TestEnv -> CacheRef -> Fetch TestM a -> IO a
+runTestWithCache env cRef = runTestM env . runFetch ((fetchConfig (runTestM env) testLiftIO) { configCache = Just cRef })
+
+-- | Run a Fetch computation and capture per-round (roundNumber, batchSize, sourceCount).
+runTestWithRoundLog :: TestEnv -> Fetch TestM a -> IO (a, [(Int, Int, Int)])
+runTestWithRoundLog env action = do
+ logRef <- newIORef ([] :: [(Int, Int, Int)])
+ cRef <- newCacheRef
+ let e = FetchEnv
+ { fetchCache = cRef
+ , fetchLower = runTestM env
+ , fetchLift = testLiftIO
+ }
+ a <- runTestM env $ runLoopWith e (\n batches exec -> do
+ testLiftIO $ modifyIORef' logRef
+ (\l -> l ++ [(n, batchSize batches, batchSourceCount batches)])
+ _ <- exec
+ pure ()
+ ) action
+ lg <- readIORef logRef
+ pure (a, lg)
+
+instance MC.MonadThrow TestM where
+ throwM = testLiftIO . MC.throwM
+
+instance MC.MonadCatch TestM where
+ catch (TestM f) handler = TestM $ \env ->
+ MC.catch (f env) (\e -> unTestM (handler e) env)
+
+-- ══════════════════════════════════════════════
+-- Main
+-- ══════════════════════════════════════════════
+
+main :: IO ()
+main = hspec $ do
+ ivarSpec
+ cacheSpec
+ batchesSpec
+ batchedSpec
+ primeCacheSpec
+ engineSpec
+ combinatorSpec
+ biselectSpec
+ mockSpec
+ tracedSpec
+ memoSpec
+ raceSpec
+ mutateSpec
+ applicativeErrorSpec
+ sourceIsolationSpec
+ partialBatchSpec
+ strategyIsolationSpec
+ complexPatternSpec
+ liftSourceSpec
+ noCachingSpec
+ roundStatsSpec
+ throwCatchSpec
+ asyncExceptionSpec
+
+-- ══════════════════════════════════════════════
+-- IVar tests
+-- ══════════════════════════════════════════════
+
+ivarSpec :: Spec
+ivarSpec = describe "Fetch.IVar" $ do
+
+ it "newIVar starts empty" $ do
+ iv <- newIVar @Int
+ filled <- isIVarFilled iv
+ filled `shouldBe` False
+
+ it "tryReadIVar on empty returns Nothing" $ do
+ iv <- newIVar @Int
+ mr <- tryReadIVar iv
+ case mr of
+ Nothing -> pure ()
+ Just _ -> expectationFailure "Expected Nothing"
+
+ it "writeIVar then awaitIVar returns Right value" $ do
+ iv <- newIVar
+ writeIVar iv (42 :: Int)
+ result <- awaitIVar iv
+ case result of
+ Right v -> v `shouldBe` 42
+ Left _ -> expectationFailure "Expected Right"
+
+ it "writeIVarError then awaitIVar returns Left" $ do
+ iv <- newIVar @Int
+ let ex = toException (FetchError "test error")
+ writeIVarError iv ex
+ result <- awaitIVar iv
+ case result of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected Left"
+
+ it "isIVarFilled returns True after write" $ do
+ iv <- newIVar
+ writeIVar iv (99 :: Int)
+ filled <- isIVarFilled iv
+ filled `shouldBe` True
+
+ it "tryReadIVar on filled returns Just (Right value)" $ do
+ iv <- newIVar
+ writeIVar iv ("hello" :: String)
+ mr <- tryReadIVar iv
+ case mr of
+ Just (Right v) -> v `shouldBe` "hello"
+ _ -> expectationFailure "Expected Just (Right ...)"
+
+ it "second write is ignored (idempotent)" $ do
+ iv <- newIVar
+ writeIVar iv (1 :: Int)
+ writeIVar iv 2
+ result <- awaitIVar iv
+ case result of
+ Right v -> v `shouldBe` 1
+ Left _ -> expectationFailure "Expected Right"
+
+ it "awaitIVar blocks until written" $ do
+ -- Coordinate with MVar, no threadDelay
+ iv <- newIVar
+ resultVar <- newEmptyMVar
+ _ <- forkIO $ do
+ v <- awaitIVar iv
+ putMVar resultVar v
+ -- The forked thread is now blocked on awaitIVar.
+ -- Write to unblock it.
+ writeIVar iv (42 :: Int)
+ result <- takeMVar resultVar
+ case result of
+ Right v -> v `shouldBe` 42
+ Left _ -> expectationFailure "Expected Right"
+
+ it "isIVarFilled returns True after error write" $ do
+ iv <- newIVar @Int
+ writeIVarError iv (toException (FetchError "boom"))
+ filled <- isIVarFilled iv
+ filled `shouldBe` True
+
+ it "writeIVarError then writeIVar is ignored (error wins)" $ do
+ iv <- newIVar
+ writeIVarError iv (toException (FetchError "first"))
+ writeIVar iv (99 :: Int)
+ result <- awaitIVar iv
+ case result of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected Left (error should win)"
+
+ it "writeIVar then writeIVarError is ignored (value wins)" $ do
+ iv <- newIVar
+ writeIVar iv (1 :: Int)
+ writeIVarError iv (toException (FetchError "late"))
+ result <- awaitIVar iv
+ case result of
+ Right v -> v `shouldBe` 1
+ Left _ -> expectationFailure "Expected Right (value should win)"
+
+ it "multiple concurrent readers all get same value" $ do
+ iv <- newIVar
+ vars <- mapM (\_ -> do
+ v <- newEmptyMVar
+ _ <- forkIO $ awaitIVar iv >>= putMVar v
+ pure v) [1 :: Int .. 5]
+ writeIVar iv (42 :: Int)
+ results <- mapM takeMVar vars
+ mapM_ (\r -> case r of
+ Right v -> v `shouldBe` 42
+ Left _ -> expectationFailure "Expected Right") results
+
+-- ══════════════════════════════════════════════
+-- Cache tests
+-- ══════════════════════════════════════════════
+
+cacheSpec :: Spec
+cacheSpec = describe "Fetch.Cache" $ do
+
+ it "cacheLookup on empty returns CacheMiss" $ do
+ cRef <- newCacheRef
+ hit <- cacheLookup cRef (UserId 1)
+ case hit of
+ CacheMiss -> pure ()
+ _ -> expectationFailure "Expected CacheMiss"
+
+ it "cacheAllocate + write + lookup returns CacheHitReady" $ do
+ cRef <- newCacheRef
+ pairs <- cacheAllocate @UserId cRef [UserId 1]
+ case pairs of
+ [(_, iv)] -> do
+ writeIVar iv "Alice"
+ hit <- cacheLookup cRef (UserId 1)
+ case hit of
+ CacheHitReady v -> v `shouldBe` "Alice"
+ _ -> expectationFailure "Expected CacheHitReady"
+ _ -> expectationFailure "Expected one allocated pair"
+
+ it "cacheAllocate without write returns CacheHitPending" $ do
+ cRef <- newCacheRef
+ _ <- cacheAllocate @UserId cRef [UserId 1]
+ hit <- cacheLookup cRef (UserId 1)
+ case hit of
+ CacheHitPending _ -> pure ()
+ _ -> expectationFailure "Expected CacheHitPending"
+
+ it "cacheAllocate deduplicates" $ do
+ cRef <- newCacheRef
+ pairs1 <- cacheAllocate @UserId cRef [UserId 1, UserId 2]
+ length pairs1 `shouldBe` 2
+ pairs2 <- cacheAllocate @UserId cRef [UserId 1, UserId 3]
+ -- UserId 1 already allocated, only UserId 3 is new
+ length pairs2 `shouldBe` 1
+ case pairs2 of
+ [(k, _)] -> k `shouldBe` UserId 3
+ _ -> expectationFailure "Expected exactly one new pair"
+
+ it "cacheEvict removes a key" $ do
+ cRef <- newCacheRef
+ cacheWarm @UserId cRef (HM.singleton (UserId 1) "Alice")
+ cacheEvict cRef (UserId 1)
+ hit <- cacheLookup cRef (UserId 1)
+ case hit of
+ CacheMiss -> pure ()
+ _ -> expectationFailure "Expected CacheMiss after eviction"
+
+ it "cacheEvictSource removes all keys for a source" $ do
+ cRef <- newCacheRef
+ cacheWarm @UserId cRef (HM.fromList [(UserId 1, "Alice"), (UserId 2, "Bob")])
+ cacheEvictSource @UserId cRef Proxy
+ hit1 <- cacheLookup cRef (UserId 1)
+ hit2 <- cacheLookup cRef (UserId 2)
+ case (hit1, hit2) of
+ (CacheMiss, CacheMiss) -> pure ()
+ _ -> expectationFailure "Expected CacheMiss for both after evictSource"
+
+ it "cacheEvictWhere removes matching keys" $ do
+ cRef <- newCacheRef
+ cacheWarm @UserId cRef (HM.fromList [(UserId 1, "Alice"), (UserId 2, "Bob")])
+ cacheEvictWhere @UserId cRef Proxy (\(UserId n) -> n == 1)
+ hit1 <- cacheLookup cRef (UserId 1)
+ hit2 <- cacheLookup cRef (UserId 2)
+ case hit1 of
+ CacheMiss -> pure ()
+ _ -> expectationFailure "Expected CacheMiss for evicted key"
+ case hit2 of
+ CacheHitReady v -> v `shouldBe` "Bob"
+ _ -> expectationFailure "Expected CacheHitReady for non-evicted key"
+
+ it "cacheWarm pre-fills values" $ do
+ cRef <- newCacheRef
+ cacheWarm @UserId cRef (HM.fromList [(UserId 1, "Alice"), (UserId 2, "Bob")])
+ hit <- cacheLookup cRef (UserId 1)
+ case hit of
+ CacheHitReady v -> v `shouldBe` "Alice"
+ _ -> expectationFailure "Expected CacheHitReady"
+
+ it "cacheContents returns all resolved values" $ do
+ cRef <- newCacheRef
+ cacheWarm @UserId cRef (HM.fromList [(UserId 1, "Alice"), (UserId 2, "Bob")])
+ contents <- cacheContents @UserId cRef Proxy
+ contents `shouldBe` HM.fromList [(UserId 1, "Alice"), (UserId 2, "Bob")]
+
+ it "errored IVars treated as CacheMiss on re-lookup" $ do
+ cRef <- newCacheRef
+ pairs <- cacheAllocate @UserId cRef [UserId 1]
+ case pairs of
+ [(_, iv)] -> do
+ writeIVarError iv (toException (FetchError "boom"))
+ hit <- cacheLookup cRef (UserId 1)
+ case hit of
+ CacheMiss -> pure ()
+ _ -> expectationFailure "Expected CacheMiss for errored IVar"
+ _ -> expectationFailure "Expected one allocated pair"
+
+ it "cacheAllocate with empty key list returns []" $ do
+ cRef <- newCacheRef
+ pairs <- cacheAllocate @UserId cRef []
+ length pairs `shouldBe` 0
+
+ it "cacheAllocate across different key types is independent" $ do
+ cRef <- newCacheRef
+ pairsU <- cacheAllocate @UserId cRef [UserId 1]
+ pairsP <- cacheAllocate @PostId cRef [PostId 1]
+ length pairsU `shouldBe` 1
+ length pairsP `shouldBe` 1
+
+ it "cacheWarm overwrites a previously resolved entry" $ do
+ cRef <- newCacheRef
+ cacheWarm @UserId cRef (HM.singleton (UserId 1) "Alice")
+ cacheWarm @UserId cRef (HM.singleton (UserId 1) "Alice2")
+ hit <- cacheLookup cRef (UserId 1)
+ case hit of
+ CacheHitReady v -> v `shouldBe` "Alice2"
+ _ -> expectationFailure "Expected CacheHitReady with overwritten value"
+
+ it "cacheContents on empty cache returns HM.empty" $ do
+ cRef <- newCacheRef
+ contents <- cacheContents @UserId cRef Proxy
+ contents `shouldBe` HM.empty
+
+ it "cacheContents excludes pending (unfilled) IVars" $ do
+ cRef <- newCacheRef
+ _ <- cacheAllocate @UserId cRef [UserId 1]
+ cacheWarm @UserId cRef (HM.singleton (UserId 2) "Bob")
+ contents <- cacheContents @UserId cRef Proxy
+ contents `shouldBe` HM.singleton (UserId 2) "Bob"
+
+ it "cacheContents excludes errored IVars" $ do
+ cRef <- newCacheRef
+ pairs <- cacheAllocate @UserId cRef [UserId 1]
+ case pairs of
+ [(_, iv)] -> writeIVarError iv (toException (FetchError "boom"))
+ _ -> expectationFailure "Expected one pair"
+ cacheWarm @UserId cRef (HM.singleton (UserId 2) "Bob")
+ contents <- cacheContents @UserId cRef Proxy
+ contents `shouldBe` HM.singleton (UserId 2) "Bob"
+
+ it "cacheEvict on non-existent key is a no-op" $ do
+ cRef <- newCacheRef
+ cacheEvict cRef (UserId 999)
+ hit <- cacheLookup cRef (UserId 999)
+ case hit of
+ CacheMiss -> pure ()
+ _ -> expectationFailure "Expected CacheMiss"
+
+ it "cacheEvictSource on non-existent source type is a no-op" $ do
+ cRef <- newCacheRef
+ cacheWarm @UserId cRef (HM.singleton (UserId 1) "Alice")
+ cacheEvictSource @PostId cRef Proxy
+ hit <- cacheLookup cRef (UserId 1)
+ case hit of
+ CacheHitReady v -> v `shouldBe` "Alice"
+ _ -> expectationFailure "Expected CacheHitReady, PostId eviction shouldn't touch UserId"
+
+ it "cacheEvictWhere with always-False predicate removes nothing" $ do
+ cRef <- newCacheRef
+ cacheWarm @UserId cRef (HM.fromList [(UserId 1, "Alice"), (UserId 2, "Bob")])
+ cacheEvictWhere @UserId cRef Proxy (const False)
+ contents <- cacheContents @UserId cRef Proxy
+ HM.size contents `shouldBe` 2
+
+ it "cacheInsert writes into a previously allocated IVar" $ do
+ cRef <- newCacheRef
+ _ <- cacheAllocate @UserId cRef [UserId 1]
+ cacheInsert cRef (UserId 1) "Alice"
+ hit <- cacheLookup cRef (UserId 1)
+ case hit of
+ CacheHitReady v -> v `shouldBe` "Alice"
+ _ -> expectationFailure "Expected CacheHitReady"
+
+-- ══════════════════════════════════════════════
+-- Batches data type tests
+-- ══════════════════════════════════════════════
+
+batchesSpec :: Spec
+batchesSpec = describe "Fetch.Class Batches" $ do
+
+ it "mempty has size 0 and source count 0" $ do
+ let b = mempty :: Batches TestM
+ batchSize b `shouldBe` 0
+ batchSourceCount b `shouldBe` 0
+
+ it "singletonBatch <> singletonBatch same source deduplicates keys" $ do
+ let b1 = singletonBatch @TestM (UserId 1)
+ b2 = singletonBatch @TestM (UserId 1)
+ merged = b1 <> b2
+ batchSourceCount merged `shouldBe` 1
+ -- Duplicate key is deduplicated
+ batchSize merged `shouldBe` 1
+
+ it "singletonBatch <> singletonBatch different sources yields source count 2" $ do
+ let b1 = singletonBatch @TestM (UserId 1)
+ b2 = singletonBatch @TestM (PostId 1)
+ merged = b1 <> b2
+ batchSourceCount merged `shouldBe` 2
+
+ it "batchKeys @UserId extracts the correct keys" $ do
+ let b = singletonBatch @TestM (UserId 1)
+ <> singletonBatch @TestM (UserId 2)
+ keys = batchKeys @UserId b
+ length keys `shouldBe` 2
+ keys `shouldSatisfy` elem (UserId 1)
+ keys `shouldSatisfy` elem (UserId 2)
+
+ it "batchKeys for absent source type returns []" $ do
+ let b = singletonBatch @TestM (UserId 1)
+ keys = batchKeys @PostId b
+ keys `shouldBe` []
+
+-- ══════════════════════════════════════════════
+-- Fetch / Batched tests
+-- ══════════════════════════════════════════════
+
+batchedSpec :: Spec
+batchedSpec = describe "Fetch.Batched" $ do
+
+ it "simple single fetch returns correct value" $ do
+ env <- mkTestEnv
+ result <- runTest env $ fetch (UserId 1)
+ result `shouldBe` "Alice"
+
+ it "applicative <*> batches independent fetches into one round" $ do
+ env <- mkTestEnv
+ (a, b) <- runTest env $
+ (,) <$> fetch (UserId 1) <*> fetch (UserId 2)
+ a `shouldBe` "Alice"
+ b `shouldBe` "Bob"
+ batches <- readIORef (envUserLog env)
+ -- Both keys in a single batch (one round)
+ length batches `shouldBe` 1
+
+ it "monadic >>= creates separate rounds" $ do
+ env <- mkTestEnv
+ _ <- runTest env $ do
+ _ <- fetch (UserId 1)
+ fetch (UserId 2)
+ batches <- readIORef (envUserLog env)
+ length batches `shouldBe` 2
+
+ it "same key fetched twice in applicative is deduplicated" $ do
+ env <- mkTestEnv
+ (a, b) <- runTest env $
+ (,) <$> fetch (UserId 1) <*> fetch (UserId 1)
+ a `shouldBe` "Alice"
+ b `shouldBe` "Alice"
+ batches <- readIORef (envUserLog env)
+ length batches `shouldBe` 1
+
+ it "second fetch of same key hits cache (no second batch)" $ do
+ env <- mkTestEnv
+ _ <- runTest env $ do
+ _ <- fetch (UserId 1)
+ fetch (UserId 1)
+ batches <- readIORef (envUserLog env)
+ length batches `shouldBe` 1
+
+ it "tryFetch returns Right on success" $ do
+ env <- mkTestEnv
+ result <- runTest env $ tryFetch (UserId 1)
+ case result of
+ Right v -> v `shouldBe` "Alice"
+ Left _ -> expectationFailure "Expected Right"
+
+ it "tryFetch returns Left on missing key" $ do
+ env <- mkTestEnv
+ result <- runTest env $ tryFetch (UserId 999)
+ case result of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected Left for missing key"
+
+ it "data source exception is caught by tryFetch" $ do
+ env <- mkTestEnv
+ result <- runTest env $ tryFetch (FailKey 1)
+ case result of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected Left for failed source"
+
+ it "multi-source batching (UserId + PostId in same round)" $ do
+ env <- mkTestEnv
+ (user, post) <- runTest env $
+ (,) <$> fetch (UserId 1) <*> fetch (PostId 10)
+ user `shouldBe` "Alice"
+ post `shouldBe` "Hello World"
+ userBatches <- readIORef (envUserLog env)
+ postBatches <- readIORef (envPostLog env)
+ -- Each source got exactly one batch call
+ length userBatches `shouldBe` 1
+ length postBatches `shouldBe` 1
+
+ it "runFetchWithCache shares cache across runs" $ do
+ env <- mkTestEnv
+ cRef <- newCacheRef
+ _ <- runTestWithCache env cRef $ fetch (UserId 1)
+ -- Second run should hit cache
+ _ <- runTestWithCache env cRef $ fetch (UserId 1)
+ batches <- readIORef (envUserLog env)
+ -- Only one batch was issued (first run); second run hit cache
+ length batches `shouldBe` 1
+
+ it "NoCaching sources don't persist in cache across rounds" $ do
+ env <- mkTestEnv
+ (a, b) <- runTest env $ do
+ x <- fetch (MutKey 1)
+ y <- fetch (MutKey 1)
+ pure (x, y)
+ mutBatches <- readIORef (envMutLog env)
+ -- Must dispatch exactly twice, once per round
+ length mutBatches `shouldBe` 2
+ -- Counter-based source returns different values across rounds
+ a `shouldSatisfy` (/= b)
+
+ it "fetch throws on missing key" $ do
+ env <- mkTestEnv
+ result <- try @SomeException $ runTest env $ fetch (UserId 999)
+ case result of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected exception for missing key"
+
+ it "fetch throws on data source exception" $ do
+ env <- mkTestEnv
+ result <- try @SomeException $ runTest env $ fetch (FailKey 1)
+ case result of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected exception for FailKey"
+
+ it "pure with no fetches completes with zero rounds" $ do
+ env <- mkTestEnv
+ result <- runTest env $ pure (42 :: Int)
+ result `shouldBe` 42
+ batches <- readIORef (envUserLog env)
+ length batches `shouldBe` 0
+
+ it "fmap over a fetch transforms the result" $ do
+ env <- mkTestEnv
+ result <- runTest env $ fmap (++ "!") (fetch (UserId 1))
+ result `shouldBe` "Alice!"
+
+ it "three-way applicative batches in one round" $ do
+ env <- mkTestEnv
+ (a, b, c) <- runTest env $
+ (,,) <$> fetch (UserId 1) <*> fetch (UserId 2) <*> fetch (UserId 3)
+ a `shouldBe` "Alice"
+ b `shouldBe` "Bob"
+ c `shouldBe` "Carol"
+ batches <- readIORef (envUserLog env)
+ length batches `shouldBe` 1
+
+ it "mixed monadic + applicative: 2 rounds, second round batches 2 keys" $ do
+ env <- mkTestEnv
+ (_, (b, c)) <- runTest env $ do
+ a <- fetch (UserId 1)
+ bc <- (,) <$> fetch (UserId 2) <*> fetch (UserId 3)
+ pure (a, bc)
+ b `shouldBe` "Bob"
+ c `shouldBe` "Carol"
+ batches <- readIORef (envUserLog env)
+ length batches `shouldBe` 2
+ case batches of
+ (lastRound : _) -> length lastRound `shouldBe` 2
+ _ -> expectationFailure "Expected at least one batch"
+
+ it "pre-warmed cache is hit without issuing a batch" $ do
+ env <- mkTestEnv
+ cRef <- newCacheRef
+ cacheWarm @UserId cRef (HM.singleton (UserId 1) "Cached-Alice")
+ result <- runTestWithCache env cRef $ fetch (UserId 1)
+ result `shouldBe` "Cached-Alice"
+ batches <- readIORef (envUserLog env)
+ length batches `shouldBe` 0
+
+ it "tryFetch after a failed key retries on the next round" $ do
+ env <- mkTestEnv
+ (first, second) <- runTest env $ do
+ r1 <- tryFetch (FailKey 1)
+ r2 <- tryFetch (FailKey 1)
+ pure (r1, r2)
+ case first of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected Left for first tryFetch"
+ case second of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected Left for second tryFetch"
+
+-- ══════════════════════════════════════════════
+-- primeCache tests
+-- ══════════════════════════════════════════════
+
+primeCacheSpec :: Spec
+primeCacheSpec = describe "MonadFetch.primeCache" $ do
+
+ it "primed value is returned by subsequent fetch without a batch" $ do
+ env <- mkTestEnv
+ result <- runTest env $ do
+ primeCache (UserId 1) "Primed-Alice"
+ fetch (UserId 1)
+ result `shouldBe` "Primed-Alice"
+ batches <- readIORef (envUserLog env)
+ length batches `shouldBe` 0
+
+ it "overwrites a resolved cache entry" $ do
+ env <- mkTestEnv
+ result <- runTest env $ do
+ _ <- fetch (UserId 1) -- fetches "Alice" from source
+ primeCache (UserId 1) "Updated" -- overwrites
+ fetch (UserId 1) -- should return the primed value
+ result `shouldBe` "Updated"
+
+ it "is a no-op in MockFetch" $ do
+ let mocks = mockData @UserId [(UserId 1, "Alice")]
+ result <- runMockFetch @TestM mocks $ do
+ primeCache (UserId 2) "Ghost"
+ fetch (UserId 1)
+ result `shouldBe` "Alice"
+
+ it "fills a pending IVar" $ do
+ env <- mkTestEnv
+ cRef <- newCacheRef
+ _ <- cacheAllocate @UserId cRef [UserId 1]
+ _ <- runTestWithCache env cRef $ do
+ primeCache (UserId 1) "Primed"
+ fetch (UserId 1)
+ batches <- readIORef (envUserLog env)
+ length batches `shouldBe` 0
+
+ it "primeCache multiple keys, all subsequently fetched from cache" $ do
+ env <- mkTestEnv
+ (a, b, c) <- runTest env $ do
+ primeCache (UserId 1) "P-Alice"
+ primeCache (UserId 2) "P-Bob"
+ primeCache (UserId 3) "P-Carol"
+ (,,) <$> fetch (UserId 1) <*> fetch (UserId 2) <*> fetch (UserId 3)
+ a `shouldBe` "P-Alice"
+ b `shouldBe` "P-Bob"
+ c `shouldBe` "P-Carol"
+ batches <- readIORef (envUserLog env)
+ length batches `shouldBe` 0
+
+ it "primeCache works through TracedFetch" $ do
+ env <- mkTestEnv
+ (result, _) <- runTestM env $
+ runTracedFetch (fetchConfig (runTestM env) testLiftIO) defaultTraceConfig $ do
+ primeCache (UserId 1) "Traced-Primed"
+ fetch (UserId 1)
+ result `shouldBe` "Traced-Primed"
+ batches <- readIORef (envUserLog env)
+ length batches `shouldBe` 0
+
+-- ══════════════════════════════════════════════
+-- Engine tests
+-- ══════════════════════════════════════════════
+
+engineSpec :: Spec
+engineSpec = describe "Fetch.Engine" $ do
+
+ it "executeBatches returns RoundStats" $ do
+ env <- mkTestEnv
+ cRef <- newCacheRef
+ let batches = singletonBatch @TestM (UserId 1)
+ <> singletonBatch @TestM (PostId 10)
+ stats <- executeBatches (runTestM env) testLiftIO cRef batches
+ roundSources stats `shouldBe` 2
+ roundKeys stats `shouldBe` 2
+
+ it "FetchStrategy ordering: Eager starts before Sequential" $ do
+ env <- mkTestEnv
+ (a, b, c) <- runTest env $
+ (,,) <$> fetch (SeqKey 1) <*> fetch (EagerKey 1) <*> fetch (UserId 1)
+ a `shouldBe` "seq-1"
+ b `shouldBe` "eager-1"
+ c `shouldBe` "Alice"
+
+ it "fillMissing fills unfilled IVars with FetchError" $ do
+ env <- mkTestEnv
+ result <- runTest env $ tryFetch (UserId 999)
+ case result of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected Left for missing key"
+
+-- ══════════════════════════════════════════════
+-- Combinator tests
+-- ══════════════════════════════════════════════
+
+combinatorSpec :: Spec
+combinatorSpec = describe "Fetch.Combinators" $ do
+
+ it "fetchAll over a list" $ do
+ env <- mkTestEnv
+ results <- runTest env $ fetchAll [UserId 1, UserId 2, UserId 3]
+ results `shouldBe` ["Alice", "Bob", "Carol"]
+ batches <- readIORef (envUserLog env)
+ length batches `shouldBe` 1
+
+ it "fetchWith pairs keys with results" $ do
+ env <- mkTestEnv
+ results <- runTest env $ fetchWith [UserId 1, UserId 2]
+ results `shouldBe` [(UserId 1, "Alice"), (UserId 2, "Bob")]
+
+ it "fetchThrough extracts key, fetches, and pairs back" $ do
+ env <- mkTestEnv
+ let items = [(10 :: Int, UserId 1), (20, UserId 2)]
+ results <- runTest env $ fetchThrough snd items
+ results `shouldBe` [((10, UserId 1), "Alice"), ((20, UserId 2), "Bob")]
+
+ it "fetchMap transforms results" $ do
+ env <- mkTestEnv
+ let items = [UserId 1, UserId 2]
+ results <- runTest env $
+ fetchMap id (\(UserId n) name -> show n <> ":" <> name) items
+ results `shouldBe` ["1:Alice", "2:Bob"]
+
+ it "fetchMaybe Nothing returns Nothing" $ do
+ env <- mkTestEnv
+ result <- runTest env $ fetchMaybe (Nothing :: Maybe UserId)
+ result `shouldBe` Nothing
+
+ it "fetchMaybe Just returns Just result" $ do
+ env <- mkTestEnv
+ result <- runTest env $ fetchMaybe (Just (UserId 1))
+ result `shouldBe` Just "Alice"
+
+ it "fetchMapWith returns HashMap" $ do
+ env <- mkTestEnv
+ result <- runTest env $ fetchMapWith [UserId 1, UserId 2]
+ result `shouldBe` HM.fromList [(UserId 1, "Alice"), (UserId 2, "Bob")]
+
+ it "fetchAll with empty list returns []" $ do
+ env <- mkTestEnv
+ results <- runTest env $ fetchAll ([] :: [UserId])
+ results `shouldBe` []
+ batches <- readIORef (envUserLog env)
+ length batches `shouldBe` 0
+
+ it "fetchWith with empty list returns []" $ do
+ env <- mkTestEnv
+ results <- runTest env $ fetchWith ([] :: [UserId])
+ results `shouldBe` []
+
+ it "fetchMapWith with duplicate keys deduplicates in result map" $ do
+ env <- mkTestEnv
+ result <- runTest env $ fetchMapWith [UserId 1, UserId 1, UserId 2]
+ HM.size result `shouldBe` 2
+ HM.lookup (UserId 1) result `shouldBe` Just "Alice"
+ HM.lookup (UserId 2) result `shouldBe` Just "Bob"
+
+ it "fetchMaybe batches with other applicative fetches in same round" $ do
+ env <- mkTestEnv
+ (mVal, val) <- runTest env $
+ (,) <$> fetchMaybe (Just (UserId 1)) <*> fetch (UserId 2)
+ mVal `shouldBe` Just "Alice"
+ val `shouldBe` "Bob"
+ batches <- readIORef (envUserLog env)
+ length batches `shouldBe` 1
+
+-- ══════════════════════════════════════════════
+-- biselect / pAnd / pOr tests
+-- ══════════════════════════════════════════════
+
+biselectSpec :: Spec
+biselectSpec = describe "biselect / pAnd / pOr" $ do
+
+ -- ── biselect ──────────────────────────────────
+
+ describe "biselect" $ do
+
+ it "both pure Right → pairs values" $ do
+ env <- mkTestEnv
+ result <- runTest env $
+ biselect
+ (pure (Right "a") :: Fetch TestM (Either () String))
+ (pure (Right "b") :: Fetch TestM (Either () String))
+ result `shouldBe` Right ("a", "b")
+
+ it "left pure Left → short-circuits immediately" $ do
+ env <- mkTestEnv
+ result <- runTest env $
+ biselect
+ (pure (Left "stop") :: Fetch TestM (Either String String))
+ (pure (Right "b") :: Fetch TestM (Either String String))
+ result `shouldBe` Left "stop"
+
+ it "right pure Left → short-circuits immediately" $ do
+ env <- mkTestEnv
+ result <- runTest env $
+ biselect
+ (pure (Right "a") :: Fetch TestM (Either String String))
+ (pure (Left "stop") :: Fetch TestM (Either String String))
+ result `shouldBe` Left "stop"
+
+ it "both Left → picks the left one" $ do
+ env <- mkTestEnv
+ result <- runTest env $
+ biselect
+ (pure (Left "first") :: Fetch TestM (Either String String))
+ (pure (Left "second") :: Fetch TestM (Either String String))
+ result `shouldBe` Left "first"
+
+ it "both blocked, both Right → pairs values in one round" $ do
+ env <- mkTestEnv
+ (result, rounds) <- runTestWithRoundLog env $
+ biselect
+ (Right <$> fetch (UserId 1) :: Fetch TestM (Either () String))
+ (Right <$> fetch (PostId 10))
+ result `shouldBe` Right ("Alice", "Hello World")
+ length rounds `shouldBe` 1
+ -- Both sources dispatched in the same round
+ dispLog <- readIORef (envDispatchLog env)
+ dispLog `shouldContain` ["UserId"]
+ dispLog `shouldContain` ["PostId"]
+
+ it "left immediate Left, right blocked → batch never executed (MVar proof)" $ do
+ env <- mkTestEnv
+ -- BlockingKey's batchFetch signals envAsyncStarted then blocks on envAsyncProceed.
+ -- If biselect short-circuits, that batchFetch is never called.
+ result <- runTest env $
+ biselect
+ (pure (Left "short") :: Fetch TestM (Either String String))
+ (Right <$> fetch (BlockingKey 1))
+ result `shouldBe` Left "short"
+ -- Prove the blocked side's batch was never entered
+ started <- tryTakeMVar (envAsyncStarted env)
+ started `shouldBe` Nothing
+
+ it "right immediate Left, left blocked → batch never executed (MVar proof)" $ do
+ env <- mkTestEnv
+ result <- runTest env $
+ biselect
+ (Right <$> fetch (BlockingKey 1) :: Fetch TestM (Either String String))
+ (pure (Left "short") :: Fetch TestM (Either String String))
+ result `shouldBe` Left "short"
+ started <- tryTakeMVar (envAsyncStarted env)
+ started `shouldBe` Nothing
+
+ it "both blocked, left resolves Left → right continuation abandoned (MVar proof)" $ do
+ env <- mkTestEnv
+ -- Round 1: fetch UserId and PostId (both fast).
+ -- After round 1: left produces Left, right would need BlockingKey (never reached).
+ (result, rounds) <- runTestWithRoundLog env $
+ biselect
+ (do name <- fetch (UserId 1)
+ pure (Left name) :: Fetch TestM (Either String ()))
+ (do _ <- fetch (PostId 10)
+ v <- fetch (BlockingKey 1) -- would block forever
+ pure (Right v))
+ result `shouldBe` Left "Alice"
+ -- Only one round of batch execution (UserId + PostId)
+ length rounds `shouldBe` 1
+ -- BlockingKey's batchFetch was never entered
+ started <- tryTakeMVar (envAsyncStarted env)
+ started `shouldBe` Nothing
+
+ -- ── pOr ───────────────────────────────────────
+
+ describe "pOr" $ do
+
+ it "True || False → True" $ do
+ env <- mkTestEnv
+ result <- runTest env $ pOr (pure True) (pure False)
+ result `shouldBe` True
+
+ it "False || True → True" $ do
+ env <- mkTestEnv
+ result <- runTest env $ pOr (pure False) (pure True)
+ result `shouldBe` True
+
+ it "False || False → False" $ do
+ env <- mkTestEnv
+ result <- runTest env $ pOr (pure False) (pure False)
+ result `shouldBe` False
+
+ it "left pure True → right fetch never executed (MVar proof)" $ do
+ env <- mkTestEnv
+ result <- runTest env $
+ pOr (pure True) (const False <$> fetch (BlockingKey 1))
+ result `shouldBe` True
+ started <- tryTakeMVar (envAsyncStarted env)
+ started `shouldBe` Nothing
+
+ it "right pure True → left fetch never executed (MVar proof)" $ do
+ env <- mkTestEnv
+ result <- runTest env $
+ pOr (const False <$> fetch (BlockingKey 1)) (pure True)
+ result `shouldBe` True
+ started <- tryTakeMVar (envAsyncStarted env)
+ started `shouldBe` Nothing
+
+ it "both fetched, left True → True in one round" $ do
+ env <- mkTestEnv
+ (result, rounds) <- runTestWithRoundLog env $
+ pOr
+ ((== "Alice") <$> fetch (UserId 1))
+ ((== "nonexistent") <$> fetch (PostId 10))
+ result `shouldBe` True
+ length rounds `shouldBe` 1
+
+ it "both fetched, both False → False in one round" $ do
+ env <- mkTestEnv
+ (result, rounds) <- runTestWithRoundLog env $
+ pOr
+ ((== "nonexistent") <$> fetch (UserId 1))
+ ((== "nonexistent") <$> fetch (PostId 10))
+ result `shouldBe` False
+ length rounds `shouldBe` 1
+
+ it "multi-round: left True after round 1, right's round 2 abandoned (MVar proof)" $ do
+ env <- mkTestEnv
+ (result, rounds) <- runTestWithRoundLog env $
+ pOr
+ -- Left: fetches UserId in round 1, resolves True
+ (do name <- fetch (UserId 1)
+ pure (name == "Alice"))
+ -- Right: fetches PostId in round 1, then would need BlockingKey in round 2
+ (do _ <- fetch (PostId 10)
+ _ <- fetch (BlockingKey 1) -- never reached
+ pure False)
+ result `shouldBe` True
+ -- Only one batch round was executed
+ length rounds `shouldBe` 1
+ -- BlockingKey's batchFetch was never entered
+ started <- tryTakeMVar (envAsyncStarted env)
+ started `shouldBe` Nothing
+
+ -- ── pAnd ──────────────────────────────────────
+
+ describe "pAnd" $ do
+
+ it "True && True → True" $ do
+ env <- mkTestEnv
+ result <- runTest env $ pAnd (pure True) (pure True)
+ result `shouldBe` True
+
+ it "True && False → False" $ do
+ env <- mkTestEnv
+ result <- runTest env $ pAnd (pure True) (pure False)
+ result `shouldBe` False
+
+ it "False && True → False" $ do
+ env <- mkTestEnv
+ result <- runTest env $ pAnd (pure False) (pure True)
+ result `shouldBe` False
+
+ it "left pure False → right fetch never executed (MVar proof)" $ do
+ env <- mkTestEnv
+ result <- runTest env $
+ pAnd (pure False) (const True <$> fetch (BlockingKey 1))
+ result `shouldBe` False
+ started <- tryTakeMVar (envAsyncStarted env)
+ started `shouldBe` Nothing
+
+ it "right pure False → left fetch never executed (MVar proof)" $ do
+ env <- mkTestEnv
+ result <- runTest env $
+ pAnd (const True <$> fetch (BlockingKey 1)) (pure False)
+ result `shouldBe` False
+ started <- tryTakeMVar (envAsyncStarted env)
+ started `shouldBe` Nothing
+
+ it "both fetched, both True → True in one round" $ do
+ env <- mkTestEnv
+ (result, rounds) <- runTestWithRoundLog env $
+ pAnd
+ ((== "Alice") <$> fetch (UserId 1))
+ ((== "Hello World") <$> fetch (PostId 10))
+ result `shouldBe` True
+ length rounds `shouldBe` 1
+
+ it "both fetched, one False → False in one round" $ do
+ env <- mkTestEnv
+ (result, rounds) <- runTestWithRoundLog env $
+ pAnd
+ ((== "Alice") <$> fetch (UserId 1))
+ ((== "nonexistent") <$> fetch (PostId 10))
+ result `shouldBe` False
+ length rounds `shouldBe` 1
+
+ it "multi-round: left False after round 1, right's round 2 abandoned (MVar proof)" $ do
+ env <- mkTestEnv
+ (result, rounds) <- runTestWithRoundLog env $
+ pAnd
+ -- Left: fetches UserId in round 1, resolves False
+ (do name <- fetch (UserId 1)
+ pure (name == "nonexistent"))
+ -- Right: fetches PostId in round 1, then would need BlockingKey in round 2
+ (do _ <- fetch (PostId 10)
+ _ <- fetch (BlockingKey 1) -- never reached
+ pure True)
+ result `shouldBe` False
+ length rounds `shouldBe` 1
+ started <- tryTakeMVar (envAsyncStarted env)
+ started `shouldBe` Nothing
+
+-- ══════════════════════════════════════════════
+-- Mock tests
+-- ══════════════════════════════════════════════
+
+mockSpec :: Spec
+mockSpec = describe "Fetch.Mock" $ do
+
+ it "runMockFetch with matching data returns value" $ do
+ let mocks = mockData @UserId [(UserId 1, "Alice")]
+ result <- runMockFetch @TestM mocks $ fetch (UserId 1)
+ result `shouldBe` "Alice"
+
+ it "fetch with missing key throws" $ do
+ let mocks = mockData @UserId [(UserId 1, "Alice")]
+ result <- try @SomeException $
+ runMockFetch @TestM mocks $ fetch (UserId 999)
+ case result of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected exception for missing key"
+
+ it "tryFetch with missing key returns Left" $ do
+ let mocks = mockData @UserId [(UserId 1, "Alice")]
+ result <- runMockFetch @TestM mocks $ tryFetch (UserId 999)
+ case result of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected Left for missing key"
+
+ it "multiple source types in one ResultMap" $ do
+ let mocks = mockData @UserId [(UserId 1, "Alice")]
+ <> mockData @PostId [(PostId 10, "Hello")]
+ (user, post) <- runMockFetch @TestM mocks $
+ (,) <$> fetch (UserId 1) <*> fetch (PostId 10)
+ user `shouldBe` "Alice"
+ post `shouldBe` "Hello"
+
+ it "emptyMockData causes tryFetch to return Left" $ do
+ result <- runMockFetch @TestM emptyMockData $ tryFetch (UserId 1)
+ case result of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected Left for empty mock data"
+
+ it "mock applicative: two fetches from different sources both succeed" $ do
+ let mocks = mockData @UserId [(UserId 1, "Alice")]
+ <> mockData @PostId [(PostId 10, "Post")]
+ (u, p) <- runMockFetch @TestM mocks $
+ (,) <$> fetch (UserId 1) <*> fetch (PostId 10)
+ u `shouldBe` "Alice"
+ p `shouldBe` "Post"
+
+ it "mock tryFetch returns Right on success" $ do
+ let mocks = mockData @UserId [(UserId 1, "Alice")]
+ result <- runMockFetch @TestM mocks $ tryFetch (UserId 1)
+ case result of
+ Right v -> v `shouldBe` "Alice"
+ Left _ -> expectationFailure "Expected Right"
+
+ it "mock fetch with no data for that source type returns error" $ do
+ let mocks = mockData @PostId [(PostId 10, "Post")]
+ result <- try @SomeException $
+ runMockFetch @TestM mocks $ fetch (UserId 1)
+ case result of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected exception for missing source type"
+
+ it "mock fetch missing key throws FetchError (not ErrorCall)" $ do
+ let mocks = mockData @UserId [(UserId 1, "Alice")]
+ result <- try @FetchError $
+ runMockFetch @TestM mocks $ fetch (UserId 999)
+ case result of
+ Left (FetchError _) -> pure ()
+ Right _ -> expectationFailure "Expected FetchError for missing key"
+
+ it "MockMutate fetch missing key throws FetchError (not ErrorCall)" $ do
+ let mocks = mockData @UserId [(UserId 1, "Alice")]
+ handlers = emptyMutationHandlers
+ result <- try @FetchError $ do
+ (v, _) <- runMockMutate @TestM mocks handlers $ fetch (UserId 999)
+ pure v
+ case result of
+ Left (FetchError _) -> pure ()
+ Right _ -> expectationFailure "Expected FetchError for missing key"
+
+-- ══════════════════════════════════════════════
+-- Traced tests
+-- ══════════════════════════════════════════════
+
+tracedSpec :: Spec
+tracedSpec = describe "Fetch.Traced" $ do
+
+ it "callbacks fire and FetchStats reports correct counts" $ do
+ env <- mkTestEnv
+ roundStartRef <- newIORef (0 :: Int)
+ roundCompleteRef <- newIORef (0 :: Int)
+ let tc = TraceConfig
+ { onRoundStart = \_ _ -> testLiftIO $ modifyIORef' roundStartRef (+ 1)
+ , onRoundComplete = \_ _ -> testLiftIO $ modifyIORef' roundCompleteRef (+ 1)
+ , onFetchComplete = \_ -> pure ()
+ }
+ (result, stats) <- runTestM env $
+ runTracedFetch (fetchConfig (runTestM env) testLiftIO) tc $ do
+ (,) <$> fetch (UserId 1) <*> fetch (UserId 2)
+ fst result `shouldBe` "Alice"
+ snd result `shouldBe` "Bob"
+ totalRounds stats `shouldBe` 1
+ totalKeys stats `shouldBe` 2
+ starts <- readIORef roundStartRef
+ starts `shouldBe` 1
+ completes <- readIORef roundCompleteRef
+ completes `shouldBe` 1
+
+ it "multiple rounds tracked correctly" $ do
+ env <- mkTestEnv
+ (_, stats) <- runTestM env $
+ runTracedFetch (fetchConfig (runTestM env) testLiftIO) defaultTraceConfig $ do
+ _ <- fetch (UserId 1)
+ fetch (UserId 2)
+ totalRounds stats `shouldBe` 2
+ totalKeys stats `shouldBe` 2
+
+ it "same batching behavior as Fetch" $ do
+ env <- mkTestEnv
+ ((a, b), _) <- runTestM env $
+ runTracedFetch (fetchConfig (runTestM env) testLiftIO) defaultTraceConfig $
+ (,) <$> fetch (UserId 1) <*> fetch (PostId 10)
+ a `shouldBe` "Alice"
+ b `shouldBe` "Hello World"
+
+ it "onFetchComplete callback fires and receives stats" $ do
+ env <- mkTestEnv
+ statsRef <- newIORef Nothing
+ let tc = TraceConfig
+ { onRoundStart = \_ _ -> pure ()
+ , onRoundComplete = \_ _ -> pure ()
+ , onFetchComplete = \s -> testLiftIO $ writeIORef statsRef (Just s)
+ }
+ _ <- runTestM env $
+ runTracedFetch (fetchConfig (runTestM env) testLiftIO) tc $ fetch (UserId 1)
+ ms <- readIORef statsRef
+ case ms of
+ Just s -> totalRounds s `shouldBe` 1
+ Nothing -> expectationFailure "onFetchComplete was not called"
+
+ it "FetchStats.totalTime is non-negative" $ do
+ env <- mkTestEnv
+ (_, stats) <- runTestM env $
+ runTracedFetch (fetchConfig (runTestM env) testLiftIO) defaultTraceConfig $
+ fetch (UserId 1)
+ totalTime stats `shouldSatisfy` (>= 0)
+
+ it "FetchStats.maxSourcesPerRound reports correct max" $ do
+ env <- mkTestEnv
+ (_, stats) <- runTestM env $
+ runTracedFetch (fetchConfig (runTestM env) testLiftIO) defaultTraceConfig $
+ (,) <$> fetch (UserId 1) <*> fetch (PostId 10)
+ maxSourcesPerRound stats `shouldBe` 2
+
+ it "primeCache through TracedFetch works" $ do
+ env <- mkTestEnv
+ (result, stats) <- runTestM env $
+ runTracedFetch (fetchConfig (runTestM env) testLiftIO) defaultTraceConfig $ do
+ primeCache (UserId 1) "Traced-Prime"
+ fetch (UserId 1)
+ result `shouldBe` "Traced-Prime"
+ totalRounds stats `shouldBe` 0
+
+ it "tryFetch returns Left for missing key through TracedFetch" $ do
+ env <- mkTestEnv
+ (result, _) <- runTestM env $
+ runTracedFetch (fetchConfig (runTestM env) testLiftIO) defaultTraceConfig $
+ tryFetch (UserId 999)
+ case result of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected Left for missing key"
+
+ it "round numbers passed to onRoundStart are sequential starting at 1" $ do
+ env <- mkTestEnv
+ roundNums <- newIORef ([] :: [Int])
+ let tc = TraceConfig
+ { onRoundStart = \n _ -> testLiftIO $ modifyIORef' roundNums (++ [n])
+ , onRoundComplete = \_ _ -> pure ()
+ , onFetchComplete = \_ -> pure ()
+ }
+ _ <- runTestM env $
+ runTracedFetch (fetchConfig (runTestM env) testLiftIO) tc $ do
+ _ <- fetch (UserId 1)
+ _ <- fetch (UserId 2)
+ fetch (UserId 3)
+ nums <- readIORef roundNums
+ nums `shouldBe` [1, 2, 3]
+
+-- ══════════════════════════════════════════════
+-- Memo tests
+-- ══════════════════════════════════════════════
+
+newtype ComputeKey = ComputeKey Int
+ deriving stock (Eq, Ord, Show, Generic)
+ deriving anyclass (Hashable)
+
+instance MemoKey ComputeKey where
+ type MemoResult ComputeKey = String
+
+memoSpec :: Spec
+memoSpec = describe "Fetch.Memo" $ do
+
+ it "memo caches computation (action runs once)" $ do
+ store <- newMemoStore
+ callCount <- newIORef (0 :: Int)
+ let action :: IO String
+ action = do
+ modifyIORef' callCount (+ 1)
+ pure "computed"
+ v1 <- memo store id (ComputeKey 1) action
+ v2 <- memo store id (ComputeKey 1) action
+ v1 `shouldBe` "computed"
+ v2 `shouldBe` "computed"
+ count <- readIORef callCount
+ count `shouldBe` 1
+
+ it "memo with different keys runs action for each" $ do
+ store <- newMemoStore
+ callCount <- newIORef (0 :: Int)
+ let action :: IO String
+ action = do
+ n <- atomicModifyIORef' callCount (\c -> (c + 1, c))
+ pure ("result-" <> show n)
+ v1 <- memo store id (ComputeKey 1) action
+ v2 <- memo store id (ComputeKey 2) action
+ v1 `shouldBe` "result-0"
+ v2 `shouldBe` "result-1"
+ count <- readIORef callCount
+ count `shouldBe` 2
+
+ it "memoOn works without MemoKey instance" $ do
+ store <- newMemoStore
+ callCount <- newIORef (0 :: Int)
+ let action :: IO Int
+ action = do
+ modifyIORef' callCount (+ 1)
+ pure 42
+ v1 <- memoOn store id ("key1" :: String) action
+ v2 <- memoOn store id ("key1" :: String) action
+ v1 `shouldBe` (42 :: Int)
+ v2 `shouldBe` 42
+ count <- readIORef callCount
+ count `shouldBe` 1
+
+ it "memoOn with different result types distinguished" $ do
+ store <- newMemoStore
+ v1 <- memoOn store id ("key" :: String) (pure (42 :: Int))
+ v2 <- memoOn store id ("key" :: String) (pure ("hello" :: String))
+ v1 `shouldBe` (42 :: Int)
+ v2 `shouldBe` "hello"
+
+ it "two separate MemoStores are independent" $ do
+ store1 <- newMemoStore
+ store2 <- newMemoStore
+ count1 <- newIORef (0 :: Int)
+ count2 <- newIORef (0 :: Int)
+ let action1 :: IO String
+ action1 = modifyIORef' count1 (+ 1) >> pure "store1"
+ action2 :: IO String
+ action2 = modifyIORef' count2 (+ 1) >> pure "store2"
+ v1 <- memo store1 id (ComputeKey 1) action1
+ v2 <- memo store2 id (ComputeKey 1) action2
+ v1 `shouldBe` "store1"
+ v2 `shouldBe` "store2"
+ c1 <- readIORef count1
+ c2 <- readIORef count2
+ c1 `shouldBe` 1
+ c2 `shouldBe` 1
+
+ it "memoOn with same key and same result type returns cached value" $ do
+ store <- newMemoStore
+ callCount <- newIORef (0 :: Int)
+ let action :: IO Int
+ action = do
+ modifyIORef' callCount (+ 1)
+ pure 100
+ v1 <- memoOn store id ("same" :: String) action
+ v2 <- memoOn store id ("same" :: String) (pure (999 :: Int))
+ v1 `shouldBe` (100 :: Int)
+ v2 `shouldBe` (100 :: Int)
+ count <- readIORef callCount
+ count `shouldBe` 1
+
+ it "memo after an errored first attempt re-runs" $ do
+ store <- newMemoStore
+ callCount <- newIORef (0 :: Int)
+ let action :: IO String
+ action = do
+ n <- atomicModifyIORef' callCount (\c -> (c + 1, c))
+ if n == 0
+ then error "first attempt fails"
+ else pure "success"
+ r1 <- try @SomeException $ memo store id (ComputeKey 1) action
+ case r1 of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected exception on first attempt"
+ v2 <- memo store id (ComputeKey 1) action
+ v2 `shouldBe` "success"
+ count <- readIORef callCount
+ count `shouldBe` 2
+
+-- ══════════════════════════════════════════════
+-- Race condition tests
+-- ══════════════════════════════════════════════
+
+raceSpec :: Spec
+raceSpec = describe "Race conditions" $ do
+ ivarRaceSpec
+ cacheRaceSpec
+ engineRaceSpec
+ fetchTRaceSpec
+ memoRaceSpec
+
+-- ──────────────────────────────────────────────
+-- IVar races
+-- ──────────────────────────────────────────────
+
+ivarRaceSpec :: Spec
+ivarRaceSpec = describe "IVar" $ do
+
+ it "concurrent write storm: exactly one winner across 100 threads" $ do
+ iv <- newIVar
+ doneVars <- mapM (\_ -> newEmptyMVar) [1 :: Int .. 100]
+ barrier <- newEmptyMVar
+ mapM_ (\(i, done) -> forkIO $ do
+ readMVar barrier
+ writeIVar iv i
+ putMVar done ()
+ ) (zip [1 :: Int .. 100] doneVars)
+ putMVar barrier ()
+ mapM_ takeMVar doneVars
+ result <- awaitIVar iv
+ case result of
+ Right v -> v `shouldSatisfy` (\x -> x >= 1 && x <= 100)
+ Left _ -> expectationFailure "Expected Right"
+
+ it "concurrent error + value writes: one winner, all readers agree" $ do
+ iv <- newIVar
+ let n = 100
+ doneVars <- mapM (\_ -> newEmptyMVar) [1 :: Int .. n]
+ barrier <- newEmptyMVar
+ mapM_ (\(i, done) -> forkIO $ do
+ readMVar barrier
+ if i <= 50
+ then writeIVar iv (i :: Int)
+ else writeIVarError iv (toException (FetchError ("err-" <> show i)))
+ putMVar done ()
+ ) (zip [1..n] doneVars)
+ putMVar barrier ()
+ mapM_ takeMVar doneVars
+ results <- mapM (\_ -> awaitIVar iv) [1 :: Int .. 10]
+ case results of
+ [] -> expectationFailure "No results"
+ (first : rest) -> case first of
+ Right winner -> mapM_ (\r -> case r of
+ Right v -> v `shouldBe` winner
+ Left _ -> expectationFailure "Inconsistent: first was Right, got Left") rest
+ Left _ -> mapM_ (\r -> case r of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Inconsistent: first was Left, got Right") rest
+
+ it "reader-writer interleave: N readers unblocked by single write" $ do
+ iv <- newIVar
+ let numReaders = 50
+ resultVars <- mapM (\_ -> newEmptyMVar) [1 :: Int .. numReaders]
+ mapM_ (\rv -> forkIO (awaitIVar iv >>= putMVar rv)) resultVars
+ writeIVar iv (42 :: Int)
+ results <- mapM takeMVar resultVars
+ mapM_ (\r -> case r of
+ Right v -> v `shouldBe` 42
+ Left _ -> expectationFailure "Expected Right") results
+
+ it "rapid alloc-write-read cycle stress (1000 iterations)" $ do
+ mapM_ (\i -> do
+ iv <- newIVar
+ writeIVar iv (i :: Int)
+ result <- awaitIVar iv
+ case result of
+ Right v -> v `shouldBe` i
+ Left _ -> expectationFailure "Expected Right"
+ ) [1 :: Int .. 1000]
+
+-- ──────────────────────────────────────────────
+-- Cache races
+-- ──────────────────────────────────────────────
+
+cacheRaceSpec :: Spec
+cacheRaceSpec = describe "Cache" $ do
+
+ it "concurrent cacheAllocate same key: exactly one allocator wins" $ do
+ cRef <- newCacheRef
+ resultsVar <- newIORef ([] :: [Int])
+ barrier <- newEmptyMVar
+ let n = 100
+ doneVars <- mapM (\_ -> newEmptyMVar) [1 :: Int .. n]
+ mapM_ (\(_, done) -> forkIO $ do
+ readMVar barrier
+ pairs <- cacheAllocate @UserId cRef [UserId 1]
+ atomicModifyIORef' resultsVar (\rs -> (length pairs : rs, ()))
+ putMVar done ()
+ ) (zip [1 :: Int .. n] doneVars)
+ putMVar barrier ()
+ mapM_ takeMVar doneVars
+ results <- readIORef resultsVar
+ let allocators = filter (> 0) results
+ length allocators `shouldBe` 1
+
+ it "cacheAllocate + cacheEvict interleave: no corruption" $ do
+ cRef <- newCacheRef
+ barrier <- newEmptyMVar
+ h1 <- async $ do
+ readMVar barrier
+ pairs <- cacheAllocate @UserId cRef [UserId 1]
+ case pairs of
+ [(_, iv)] -> writeIVar iv "value"
+ _ -> pure ()
+ h2 <- async $ do
+ readMVar barrier
+ cacheEvict cRef (UserId 1)
+ putMVar barrier ()
+ wait h1
+ wait h2
+ hit <- cacheLookup cRef (UserId 1)
+ case hit of
+ CacheMiss -> pure ()
+ CacheHitReady v -> v `shouldBe` "value"
+ CacheHitPending _ -> pure ()
+
+ it "cacheWarm + cacheLookup concurrent: never corrupt state" $ do
+ cRef <- newCacheRef
+ let warmMap = HM.fromList [ (UserId i, "user-" <> show i)
+ | i <- [1..100] ]
+ barrier <- newEmptyMVar
+ h1 <- async $ do
+ readMVar barrier
+ cacheWarm @UserId cRef warmMap
+ badRef <- newIORef False
+ h2 <- async $ do
+ readMVar barrier
+ mapM_ (\i -> do
+ hit <- cacheLookup cRef (UserId i)
+ case hit of
+ CacheMiss -> pure ()
+ CacheHitReady _ -> pure ()
+ CacheHitPending _ -> pure ()
+ ) [1..100]
+ putMVar barrier ()
+ wait h1
+ wait h2
+ bad <- readIORef badRef
+ bad `shouldBe` False
+
+ it "cacheInsert after concurrent evict: no crash" $ do
+ cRef <- newCacheRef
+ _ <- cacheAllocate @UserId cRef [UserId 1]
+ barrier <- newEmptyMVar
+ h1 <- async $ do
+ readMVar barrier
+ cacheInsert cRef (UserId 1) "value"
+ h2 <- async $ do
+ readMVar barrier
+ cacheEvict cRef (UserId 1)
+ putMVar barrier ()
+ wait h1
+ wait h2
+ hit <- cacheLookup cRef (UserId 1)
+ case hit of
+ CacheMiss -> pure ()
+ CacheHitReady _ -> pure ()
+ CacheHitPending _ -> pure ()
+
+ it "concurrent cacheWarm different keys: both sets present" $ do
+ cRef <- newCacheRef
+ let set1 = HM.fromList [ (UserId i, "a-" <> show i) | i <- [1..50] ]
+ set2 = HM.fromList [ (UserId i, "b-" <> show i) | i <- [51..100] ]
+ h1 <- async $ cacheWarm @UserId cRef set1
+ h2 <- async $ cacheWarm @UserId cRef set2
+ wait h1
+ wait h2
+ contents <- cacheContents @UserId cRef Proxy
+ mapM_ (\i -> HM.member (UserId i) contents `shouldBe` True) [1..100]
+
+ it "cacheContents during concurrent writes: internally consistent" $ do
+ cRef <- newCacheRef
+ barrier <- newEmptyMVar
+ h1 <- async $ do
+ readMVar barrier
+ mapM_ (\i -> do
+ cacheWarm @UserId cRef (HM.singleton (UserId i) ("val-" <> show i))
+ ) [1 :: Int .. 50]
+ h2 <- async $ do
+ readMVar barrier
+ mapM_ (\_ -> do
+ contents <- cacheContents @UserId cRef Proxy
+ mapM_ (\(_, v) ->
+ length v `shouldSatisfy` (> 0)) (HM.toList contents)
+ ) [1 :: Int .. 50]
+ putMVar barrier ()
+ wait h1
+ wait h2
+
+-- ──────────────────────────────────────────────
+-- Engine / dispatch races
+-- ──────────────────────────────────────────────
+
+engineRaceSpec :: Spec
+engineRaceSpec = describe "Engine dispatch" $ do
+
+ it "concurrent executeBatches on same CacheRef: no crash, all IVars filled" $ do
+ env <- mkTestEnv
+ cRef <- newCacheRef
+ let b1 = singletonBatch @TestM (UserId 1) <> singletonBatch @TestM (UserId 2)
+ b2 = singletonBatch @TestM (PostId 10) <> singletonBatch @TestM (PostId 20)
+ h1 <- async $ executeBatches (runTestM env) testLiftIO cRef b1
+ h2 <- async $ executeBatches (runTestM env) testLiftIO cRef b2
+ _ <- wait h1
+ _ <- wait h2
+ u1 <- cacheLookup cRef (UserId 1)
+ u2 <- cacheLookup cRef (UserId 2)
+ p1 <- cacheLookup cRef (PostId 10)
+ p2 <- cacheLookup cRef (PostId 20)
+ case (u1, u2, p1, p2) of
+ (CacheHitReady a, CacheHitReady b, CacheHitReady c, CacheHitReady d) -> do
+ a `shouldBe` "Alice"
+ b `shouldBe` "Bob"
+ c `shouldBe` "Hello World"
+ d `shouldBe` "Haskell Tips"
+ _ -> expectationFailure "Expected all CacheHitReady"
+
+ it "all three strategies in one round: Eager + Sequential + Concurrent" $ do
+ env <- mkTestEnv
+ (a, b, c) <- runTest env $
+ (,,) <$> fetch (EagerKey 1) <*> fetch (SeqKey 1) <*> fetch (UserId 1)
+ a `shouldBe` "eager-1"
+ b `shouldBe` "seq-1"
+ c `shouldBe` "Alice"
+
+ it "high-fan-out: 100 distinct keys in one applicative round" $ do
+ env <- mkTestEnv
+ let keys = map RangeKey [1..100]
+ results <- runTest env $ fetchAll keys
+ length results `shouldBe` 100
+ results `shouldBe` ["range-" <> show i | i <- [1 :: Int .. 100]]
+
+ it "concurrent runFetchWithCache from multiple threads: no crash" $ do
+ env <- mkTestEnv
+ cRef <- newCacheRef
+ barrier <- newEmptyMVar
+ let n = 20
+ doneVars <- mapM (\_ -> newEmptyMVar) [1 :: Int .. n]
+ mapM_ (\(i, done) -> forkIO $ do
+ readMVar barrier
+ result <- runTestWithCache env cRef $ fetch (UserId (1 + i `mod` 3))
+ length result `shouldSatisfy` (> 0)
+ putMVar done ()
+ ) (zip [0 :: Int .. n - 1] doneVars)
+ putMVar barrier ()
+ mapM_ takeMVar doneVars
+
+-- ──────────────────────────────────────────────
+-- Fetch / primeCache races
+-- ──────────────────────────────────────────────
+
+fetchTRaceSpec :: Spec
+fetchTRaceSpec = describe "Fetch / primeCache" $ do
+
+ it "concurrent primeCache + fetch for same key: no corruption" $ do
+ mapM_ (\_ -> do
+ env <- mkTestEnv
+ cRef <- newCacheRef
+ barrier <- newEmptyMVar
+ resultVar <- newEmptyMVar
+ _ <- forkIO $ do
+ readMVar barrier
+ runTestWithCache env cRef $ primeCache (UserId 1) "primed"
+ pure ()
+ _ <- forkIO $ do
+ readMVar barrier
+ r <- runTestWithCache env cRef $ fetch (UserId 1)
+ putMVar resultVar r
+ putMVar barrier ()
+ result <- takeMVar resultVar
+ result `shouldSatisfy` (\v -> v == "primed" || v == "Alice")
+ ) [1 :: Int .. 50]
+
+ it "primeCache into pending IVar while batch in flight" $ do
+ env0 <- mkTestEnv
+ slowBarrier <- newEmptyMVar
+ let env' = env0 { envSlowBarrier = slowBarrier }
+ cRef <- newCacheRef
+ fetchDone <- newEmptyMVar
+ _ <- forkIO $ do
+ r <- runTestWithCache env' cRef $ fetch (SlowKey 1)
+ putMVar fetchDone r
+ let waitForPending = do
+ hit <- cacheLookup cRef (SlowKey 1)
+ case hit of
+ CacheHitPending _ -> pure ()
+ _ -> waitForPending
+ waitForPending
+ runTestWithCache env' cRef $ primeCache (SlowKey 1) "primed-value"
+ putMVar slowBarrier ()
+ result <- takeMVar fetchDone
+ result `shouldBe` "primed-value"
+
+ it "concurrent primeCache storm: one value wins" $ do
+ env <- mkTestEnv
+ cRef <- newCacheRef
+ barrier <- newEmptyMVar
+ let n = 50
+ doneVars <- mapM (\_ -> newEmptyMVar) [1 :: Int .. n]
+ mapM_ (\(i, done) -> forkIO $ do
+ readMVar barrier
+ runTestWithCache env cRef $
+ primeCache (UserId 1) ("prime-" <> show i)
+ putMVar done ()
+ ) (zip [1 :: Int .. n] doneVars)
+ putMVar barrier ()
+ mapM_ takeMVar doneVars
+ result <- runTestWithCache env cRef $ fetch (UserId 1)
+ let hasPrimePrefix v = take 6 v == "prime-"
+ result `shouldSatisfy` (\v -> hasPrimePrefix v || v == "Alice")
+
+ it "primeCache + cacheEvict race: no crash" $ do
+ mapM_ (\_ -> do
+ env <- mkTestEnv
+ cRef <- newCacheRef
+ barrier <- newEmptyMVar
+ h1 <- async $ do
+ readMVar barrier
+ runTestWithCache env cRef $ primeCache (UserId 1) "primed"
+ h2 <- async $ do
+ readMVar barrier
+ cacheEvict cRef (UserId 1)
+ putMVar barrier ()
+ wait h1
+ wait h2
+ hit <- cacheLookup cRef (UserId 1)
+ case hit of
+ CacheMiss -> pure ()
+ CacheHitReady _ -> pure ()
+ CacheHitPending _ -> pure ()
+ ) [1 :: Int .. 50]
+
+-- ──────────────────────────────────────────────
+-- Memo races
+-- ──────────────────────────────────────────────
+
+memoRaceSpec :: Spec
+memoRaceSpec = describe "Memo" $ do
+
+ it "concurrent memo same key: action runs at most a few times" $ do
+ store <- newMemoStore
+ callCount <- newIORef (0 :: Int)
+ barrier <- newEmptyMVar
+ let n = 100
+ resultVars <- mapM (\_ -> newEmptyMVar) [1 :: Int .. n]
+ mapM_ (\(_, rv) -> forkIO $ do
+ readMVar barrier
+ v <- memo store id (ComputeKey 1) $ do
+ atomicModifyIORef' callCount (\c -> (c + 1, ()))
+ pure "computed"
+ putMVar rv v
+ ) (zip [1 :: Int .. n] resultVars)
+ putMVar barrier ()
+ results <- mapM takeMVar resultVars
+ mapM_ (\v -> v `shouldBe` "computed") results
+ count <- readIORef callCount
+ count `shouldSatisfy` (< n)
+
+ it "concurrent memoOn same key: action runs at most a few times" $ do
+ store <- newMemoStore
+ callCount <- newIORef (0 :: Int)
+ barrier <- newEmptyMVar
+ let n = 100
+ resultVars <- mapM (\_ -> newEmptyMVar) [1 :: Int .. n]
+ mapM_ (\(_, rv) -> forkIO $ do
+ readMVar barrier
+ v <- memoOn store id ("shared-key" :: String) $ do
+ atomicModifyIORef' callCount (\c -> (c + 1, ()))
+ pure (42 :: Int)
+ putMVar rv v
+ ) (zip [1 :: Int .. n] resultVars)
+ putMVar barrier ()
+ results <- mapM takeMVar resultVars
+ mapM_ (\v -> v `shouldBe` (42 :: Int)) results
+ count <- readIORef callCount
+ count `shouldSatisfy` (< n)
+
+ it "concurrent memo different keys: each runs exactly once" $ do
+ store <- newMemoStore
+ callCount <- newIORef (0 :: Int)
+ let n = 100
+ replicateConcurrently_ n $ do
+ myKey <- atomicModifyIORef' callCount (\c -> (c + 1, c))
+ v <- memo store id (ComputeKey myKey) (pure ("result-" <> show myKey))
+ v `shouldBe` ("result-" <> show myKey)
+ count <- readIORef callCount
+ count `shouldBe` n
+
+ it "memo + error race: no deadlock, valid results or rethrown exceptions" $ do
+ store <- newMemoStore
+ let n = 50
+ resultVars <- mapM (\_ -> newEmptyMVar) [1 :: Int .. n]
+ barrier <- newEmptyMVar
+ callCount <- newIORef (0 :: Int)
+ mapM_ (\(_, rv) -> forkIO $ do
+ readMVar barrier
+ r <- try @SomeException $ memo store id (ComputeKey 1) $ do
+ myCall <- atomicModifyIORef' callCount (\c -> (c + 1, c))
+ if myCall == 0
+ then error "first call fails"
+ else pure "success"
+ putMVar rv r
+ ) (zip [1 :: Int .. n] resultVars)
+ putMVar barrier ()
+ results <- mapM takeMVar resultVars
+ mapM_ (\r -> case r of
+ Left _ -> pure ()
+ Right v -> v `shouldBe` "success"
+ ) results
+
+-- ══════════════════════════════════════════════
+-- Mutation key types
+-- ══════════════════════════════════════════════
+
+data UpdateUser = UpdateUser UserId String
+ deriving stock (Show)
+
+instance MutationKey UpdateUser where
+ type MutationResult UpdateUser = String -- returns updated name
+
+data DeleteUser = DeleteUser UserId
+ deriving stock (Show)
+
+instance MutationKey DeleteUser where
+ type MutationResult DeleteUser = ()
+
+data FailMutation = FailMutation
+ deriving stock (Show)
+
+instance MutationKey FailMutation where
+ type MutationResult FailMutation = ()
+
+-- ══════════════════════════════════════════════
+-- MutationSource instances for TestM
+-- ══════════════════════════════════════════════
+
+instance MutationSource TestM UpdateUser where
+ executeMutation (UpdateUser (UserId n) newName) =
+ pure $ "updated-" <> newName <> "-" <> show n
+
+ reconcileCache (UpdateUser uid _) result cRef =
+ cacheWarm @UserId cRef (HM.singleton uid result)
+
+instance MutationSource TestM DeleteUser where
+ executeMutation (DeleteUser _) = pure ()
+
+ reconcileCache (DeleteUser uid) _ cRef =
+ cacheEvict cRef uid
+
+instance MutationSource TestM FailMutation where
+ executeMutation FailMutation =
+ error "FailMutation always throws"
+
+-- ══════════════════════════════════════════════
+-- Mutate tests
+-- ══════════════════════════════════════════════
+
+-- | Run a Mutate computation over TestM in IO.
+runMutateTest :: TestEnv -> Mutate TestM TestM a -> IO a
+runMutateTest env = runTestM env . runMutate (fetchConfig (runTestM env) testLiftIO)
+
+-- | Run a Mutate computation with an externally-provided cache.
+runMutateTestWithCache :: TestEnv -> CacheRef -> Mutate TestM TestM a -> IO a
+runMutateTestWithCache env cRef = runTestM env . runMutate ((fetchConfig (runTestM env) testLiftIO) { configCache = Just cRef })
+
+mutateSpec :: Spec
+mutateSpec = describe "Fetch.Mutate (Mutate)" $ do
+ mutateBasicSpec
+ mutateFetchInteractionSpec
+ mutateApplicativeSpec
+ mutateMonadicSpec
+ mutateMockSpec
+ mutateCacheReconcileSpec
+
+mutateBasicSpec :: Spec
+mutateBasicSpec = describe "basic mutations" $ do
+
+ it "mutate returns correct result" $ do
+ env <- mkTestEnv
+ result <- runMutateTest env $ mutate (UpdateUser (UserId 1) "NewAlice")
+ result `shouldBe` "updated-NewAlice-1"
+
+ it "tryMutate returns Right on success" $ do
+ env <- mkTestEnv
+ result <- runMutateTest env $ tryMutate (UpdateUser (UserId 1) "NewAlice")
+ case result of
+ Right v -> v `shouldBe` "updated-NewAlice-1"
+ Left _ -> expectationFailure "Expected Right"
+
+ it "tryMutate catches exception" $ do
+ env <- mkTestEnv
+ result <- runMutateTest env $ tryMutate FailMutation
+ case result of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected Left"
+
+ it "mutate throws on exception" $ do
+ env <- mkTestEnv
+ result <- try @SomeException $ runMutateTest env $ mutate FailMutation
+ case result of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected exception"
+
+ it "pure with no mutations completes immediately" $ do
+ env <- mkTestEnv
+ result <- runMutateTest env $ pure (42 :: Int)
+ result `shouldBe` 42
+
+mutateFetchInteractionSpec :: Spec
+mutateFetchInteractionSpec = describe "fetch-mutate-fetch interaction" $ do
+
+ it "fetch works within Mutate" $ do
+ env <- mkTestEnv
+ result <- runMutateTest env $ fetch (UserId 1)
+ result `shouldBe` "Alice"
+
+ it "tryFetch works within Mutate" $ do
+ env <- mkTestEnv
+ result <- runMutateTest env $ tryFetch (UserId 1)
+ case result of
+ Right v -> v `shouldBe` "Alice"
+ Left _ -> expectationFailure "Expected Right"
+
+ it "fetch-mutate-fetch: second fetch sees primed cache from reconcileCache" $ do
+ env <- mkTestEnv
+ (valBefore, valAfter) <- runMutateTest env $ do
+ b <- fetch (UserId 1)
+ _ <- mutate (UpdateUser (UserId 1) "NewAlice")
+ a <- fetch (UserId 1)
+ pure (b, a)
+ valBefore `shouldBe` "Alice"
+ valAfter `shouldBe` "updated-NewAlice-1"
+ batches <- readIORef (envUserLog env)
+ length batches `shouldBe` 1
+
+ it "fetch after delete mutation misses cache" $ do
+ env <- mkTestEnv
+ cRef <- newCacheRef
+ _ <- runMutateTestWithCache env cRef $ do
+ _ <- fetch (UserId 1)
+ _ <- mutate (DeleteUser (UserId 1))
+ tryFetch (UserId 1)
+ batches <- readIORef (envUserLog env)
+ length batches `shouldBe` 2
+
+ it "multiple fetches batch in a single round within Mutate" $ do
+ env <- mkTestEnv
+ (a, b) <- runMutateTest env $
+ (,) <$> fetch (UserId 1) <*> fetch (UserId 2)
+ a `shouldBe` "Alice"
+ b `shouldBe` "Bob"
+ batches <- readIORef (envUserLog env)
+ length batches `shouldBe` 1
+
+ it "primeCache works within Mutate" $ do
+ env <- mkTestEnv
+ result <- runMutateTest env $ do
+ primeCache (UserId 1) "Primed"
+ fetch (UserId 1)
+ result `shouldBe` "Primed"
+ batches <- readIORef (envUserLog env)
+ length batches `shouldBe` 0
+
+mutateApplicativeSpec :: Spec
+mutateApplicativeSpec = describe "applicative behavior" $ do
+
+ it "fetches batch, mutation fires only after all fetches" $ do
+ env <- mkTestEnv
+ (user, updated, post) <- runMutateTest env $
+ (,,)
+ <$> fetch (UserId 1)
+ <*> mutate (UpdateUser (UserId 2) "NewBob")
+ <*> fetch (PostId 10)
+ user `shouldBe` "Alice"
+ updated `shouldBe` "updated-NewBob-2"
+ post `shouldBe` "Hello World"
+ userBatches <- readIORef (envUserLog env)
+ postBatches <- readIORef (envPostLog env)
+ length userBatches `shouldBe` 1
+ length postBatches `shouldBe` 1
+
+ it "two mutations in <*>: both execute sequentially (left then right)" $ do
+ env <- mkTestEnv
+ (r1, r2) <- runMutateTest env $
+ (,) <$> mutate (UpdateUser (UserId 1) "First")
+ <*> mutate (UpdateUser (UserId 2) "Second")
+ r1 `shouldBe` "updated-First-1"
+ r2 `shouldBe` "updated-Second-2"
+
+ it "fmap over mutation result transforms it" $ do
+ env <- mkTestEnv
+ result <- runMutateTest env $
+ fmap (++ "!") (mutate (UpdateUser (UserId 1) "Bang"))
+ result `shouldBe` "updated-Bang-1!"
+
+ it "three-way applicative: fetch + mutation + fetch" $ do
+ env <- mkTestEnv
+ (a, b, c) <- runMutateTest env $
+ (,,) <$> fetch (UserId 1)
+ <*> mutate (UpdateUser (UserId 2) "M")
+ <*> fetch (UserId 3)
+ a `shouldBe` "Alice"
+ b `shouldBe` "updated-M-2"
+ c `shouldBe` "Carol"
+
+mutateMonadicSpec :: Spec
+mutateMonadicSpec = describe "monadic behavior" $ do
+
+ it "fetch >>= mutate >>= fetch: correct sequencing" $ do
+ env <- mkTestEnv
+ (valBefore, result, valAfter) <- runMutateTest env $ do
+ b <- fetch (UserId 1)
+ r <- mutate (UpdateUser (UserId 1) "Updated")
+ a <- fetch (UserId 1)
+ pure (b, r, a)
+ valBefore `shouldBe` "Alice"
+ result `shouldBe` "updated-Updated-1"
+ valAfter `shouldBe` "updated-Updated-1"
+
+ it "mutation result used in subsequent fetch key" $ do
+ env <- mkTestEnv
+ result <- runMutateTest env $ do
+ _ <- mutate (UpdateUser (UserId 1) "Dynamic")
+ fetch (UserId 2)
+ result `shouldBe` "Bob"
+
+ it "two sequential mutations" $ do
+ env <- mkTestEnv
+ (r1, r2) <- runMutateTest env $ do
+ a <- mutate (UpdateUser (UserId 1) "First")
+ b <- mutate (UpdateUser (UserId 2) "Second")
+ pure (a, b)
+ r1 `shouldBe` "updated-First-1"
+ r2 `shouldBe` "updated-Second-2"
+
+ it "conditional mutation based on fetch result" $ do
+ env <- mkTestEnv
+ result <- runMutateTest env $ do
+ name <- fetch (UserId 1)
+ if name == "Alice"
+ then mutate (UpdateUser (UserId 1) "ConditionalUpdate")
+ else pure name
+ result `shouldBe` "updated-ConditionalUpdate-1"
+
+ it "tryMutate failure doesn't prevent subsequent operations" $ do
+ env <- mkTestEnv
+ (err, val) <- runMutateTest env $ do
+ e <- tryMutate FailMutation
+ v <- fetch (UserId 1)
+ pure (e, v)
+ case err of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected Left"
+ val `shouldBe` "Alice"
+
+mutateMockSpec :: Spec
+mutateMockSpec = describe "MockMutate" $ do
+
+ it "mock mutation returns handler result" $ do
+ let mocks = mockData @UserId [(UserId 1, "Alice")]
+ handlers = mockMutation @UpdateUser (\(UpdateUser _ n) -> "mock-" <> n)
+ (result, _) <- runMockMutate @TestM mocks handlers $ mutate (UpdateUser (UserId 1) "Test")
+ result `shouldBe` "mock-Test"
+
+ it "mock mutation records the mutation" $ do
+ let mocks = emptyMockData
+ handlers = mockMutation @UpdateUser (\(UpdateUser _ n) -> "mock-" <> n)
+ (_, mutations) <- runMockMutate @TestM mocks handlers $
+ mutate (UpdateUser (UserId 1) "Recorded")
+ length mutations `shouldBe` 1
+
+ it "mock fetch works alongside mock mutations" $ do
+ let mocks = mockData @UserId [(UserId 1, "Alice")]
+ handlers = mockMutation @UpdateUser (\(UpdateUser _ n) -> "mock-" <> n)
+ ((user, updated), mutations) <- runMockMutate @TestM mocks handlers $ do
+ u <- fetch (UserId 1)
+ r <- mutate (UpdateUser (UserId 1) "NewName")
+ pure (u, r)
+ user `shouldBe` "Alice"
+ updated `shouldBe` "mock-NewName"
+ length mutations `shouldBe` 1
+
+ it "mock tryMutate with no handler returns Left" $ do
+ let mocks = emptyMockData
+ handlers = emptyMutationHandlers
+ (result, _) <- runMockMutate @TestM mocks handlers $
+ tryMutate (UpdateUser (UserId 1) "NoHandler")
+ case result of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected Left for missing handler"
+
+ it "multiple mock mutations recorded in order" $ do
+ let mocks = emptyMockData
+ handlers = mockMutation @UpdateUser (\(UpdateUser _ n) -> "mock-" <> n)
+ <> mockMutation @DeleteUser (\_ -> ())
+ (_, mutations) <- runMockMutate @TestM mocks handlers $ do
+ _ <- mutate (UpdateUser (UserId 1) "First")
+ _ <- mutate (DeleteUser (UserId 2))
+ _ <- mutate (UpdateUser (UserId 3) "Third")
+ pure ()
+ length mutations `shouldBe` 3
+
+mutateCacheReconcileSpec :: Spec
+mutateCacheReconcileSpec = describe "cache reconciliation" $ do
+
+ it "reconcileCache evicts stale keys after DeleteUser" $ do
+ env <- mkTestEnv
+ cRef <- newCacheRef
+ _ <- runMutateTestWithCache env cRef $ do
+ _ <- fetch (UserId 1)
+ mutate (DeleteUser (UserId 1))
+ hit <- cacheLookup cRef (UserId 1)
+ case hit of
+ CacheMiss -> pure ()
+ _ -> expectationFailure "Expected CacheMiss after DeleteUser"
+
+ it "reconcileCache primes fresh values after UpdateUser" $ do
+ env <- mkTestEnv
+ cRef <- newCacheRef
+ _ <- runMutateTestWithCache env cRef $
+ mutate (UpdateUser (UserId 1) "Fresh")
+ hit <- cacheLookup cRef (UserId 1)
+ case hit of
+ CacheHitReady v -> v `shouldBe` "updated-Fresh-1"
+ _ -> expectationFailure "Expected CacheHitReady with fresh value"
+
+ it "cache shared across runMutateWithCache: mutation effects persist" $ do
+ env <- mkTestEnv
+ cRef <- newCacheRef
+ _ <- runMutateTestWithCache env cRef $
+ mutate (UpdateUser (UserId 1) "Shared")
+ result <- runMutateTestWithCache env cRef $
+ fetch (UserId 1)
+ result `shouldBe` "updated-Shared-1"
+ batches <- readIORef (envUserLog env)
+ length batches `shouldBe` 0
+
+-- ══════════════════════════════════════════════
+-- Applicative error propagation
+-- ══════════════════════════════════════════════
+
+applicativeErrorSpec :: Spec
+applicativeErrorSpec = describe "Applicative error propagation" $ do
+
+ it "<*> left fails, right succeeds: whole expression throws" $ do
+ env <- mkTestEnv
+ result <- try @SomeException $ runTest env $
+ (,) <$> fetch (FailKey 1) <*> fetch (UserId 1)
+ case result of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected exception"
+ -- UserId source was still dispatched
+ userBatches <- readIORef (envUserLog env)
+ length userBatches `shouldBe` 1
+
+ it "<*> right fails, left succeeds: whole expression throws" $ do
+ env <- mkTestEnv
+ result <- try @SomeException $ runTest env $
+ (,) <$> fetch (UserId 1) <*> fetch (FailKey 1)
+ case result of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected exception"
+ userBatches <- readIORef (envUserLog env)
+ length userBatches `shouldBe` 1
+
+ it "<*> both sides fail: whole expression throws" $ do
+ env <- mkTestEnv
+ result <- try @SomeException $ runTest env $
+ (,) <$> fetch (FailKey 1) <*> fetch (FailKey 2)
+ case result of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected exception"
+
+ it "tryFetch <*> tryFetch: left Left, right Right" $ do
+ env <- mkTestEnv
+ (left', right') <- runTest env $
+ (,) <$> tryFetch (FailKey 1) <*> tryFetch (UserId 1)
+ case left' of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected Left for FailKey"
+ case right' of
+ Right v -> v `shouldBe` "Alice"
+ Left _ -> expectationFailure "Expected Right for UserId"
+
+ it "tryFetch <*> tryFetch: both Left" $ do
+ env <- mkTestEnv
+ (left', right') <- runTest env $
+ (,) <$> tryFetch (FailKey 1) <*> tryFetch (FailKey 2)
+ case left' of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected Left"
+ case right' of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected Left"
+
+ it "mixed: tryFetch (fail) <*> fetch (ok) succeeds overall" $ do
+ env <- mkTestEnv
+ (left', right') <- runTest env $
+ (,) <$> tryFetch (FailKey 1) <*> fetch (UserId 1)
+ case left' of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected Left for FailKey"
+ right' `shouldBe` "Alice"
+
+ it "mixed: fetch (fail) <*> tryFetch (ok) throws overall" $ do
+ env <- mkTestEnv
+ result <- try @SomeException $ runTest env $
+ (,) <$> fetch (FailKey 1) <*> tryFetch (UserId 1)
+ case result of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected exception from fetch side"
+
+ it "three-way: middle fails, all three sources dispatched" $ do
+ env <- mkTestEnv
+ result <- try @SomeException $ runTest env $
+ (,,) <$> fetch (UserId 1) <*> fetch (FailKey 1) <*> fetch (PostId 10)
+ case result of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected exception"
+ userBatches <- readIORef (envUserLog env)
+ postBatches <- readIORef (envPostLog env)
+ length userBatches `shouldBe` 1
+ length postBatches `shouldBe` 1
+
+ it "fmap over failing fetch throws" $ do
+ env <- mkTestEnv
+ result <- try @SomeException $ runTest env $
+ fmap (++ "!") (fetch (FailKey 1))
+ case result of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected exception"
+
+ it "successful sources still dispatched when co-batched source fails" $ do
+ env <- mkTestEnv
+ _ <- runTest env $
+ (,) <$> fetch (UserId 1) <*> tryFetch (FailKey 1)
+ userBatches <- readIORef (envUserLog env)
+ length userBatches `shouldBe` 1
+ dispatched <- readIORef (envDispatchLog env)
+ dispatched `shouldSatisfy` elem "UserId"
+ dispatched `shouldSatisfy` elem "FailKey"
+
+-- ══════════════════════════════════════════════
+-- Multi-source failure isolation
+-- ══════════════════════════════════════════════
+
+sourceIsolationSpec :: Spec
+sourceIsolationSpec = describe "Multi-source failure isolation" $ do
+
+ it "UserId succeeds while FailKey throws in same round" $ do
+ env <- mkTestEnv
+ (user, failResult) <- runTest env $
+ (,) <$> fetch (UserId 1) <*> tryFetch (FailKey 1)
+ user `shouldBe` "Alice"
+ case failResult of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected Left for FailKey"
+
+ it "three sources, middle fails, first and third succeed" $ do
+ env <- mkTestEnv
+ (user, failResult, post) <- runTest env $
+ (,,) <$> fetch (UserId 1) <*> tryFetch (FailKey 1) <*> fetch (PostId 10)
+ user `shouldBe` "Alice"
+ post `shouldBe` "Hello World"
+ case failResult of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected Left for FailKey"
+
+ it "source-level vs key-level failures: both Left with different errors" $ do
+ env <- mkTestEnv
+ (failResult, missingResult) <- runTest env $
+ (,) <$> tryFetch (FailKey 1) <*> tryFetch (UserId 999)
+ case failResult of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected Left for FailKey"
+ case missingResult of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected Left for missing UserId"
+
+ it "source B results cached despite source A failure in same round" $ do
+ env <- mkTestEnv
+ cRef <- newCacheRef
+ _ <- runTestWithCache env cRef $
+ (,) <$> tryFetch (FailKey 1) <*> fetch (UserId 1)
+ -- Second run: UserId should be cached
+ _ <- runTestWithCache env cRef $ fetch (UserId 1)
+ userBatches <- readIORef (envUserLog env)
+ length userBatches `shouldBe` 1 -- only one batch, second run hit cache
+
+ it "round 1 mixed success/failure, round 2 uses successful results" $ do
+ env <- mkTestEnv
+ cRef <- newCacheRef
+ (_, _, user2) <- runTestWithCache env cRef $ do
+ (failResult, user) <- (,) <$> tryFetch (FailKey 1) <*> fetch (UserId 1)
+ user2 <- fetch (UserId 1) -- round 2: should hit cache
+ pure (failResult, user, user2)
+ user2 `shouldBe` "Alice"
+ userBatches <- readIORef (envUserLog env)
+ length userBatches `shouldBe` 1
+
+ it "all sources dispatched even when one throws (via dispatch log)" $ do
+ env <- mkTestEnv
+ _ <- runTest env $
+ (,,) <$> tryFetch (FailKey 1) <*> fetch (UserId 1) <*> fetch (PostId 10)
+ dispatched <- readIORef (envDispatchLog env)
+ dispatched `shouldSatisfy` elem "FailKey"
+ dispatched `shouldSatisfy` elem "UserId"
+ dispatched `shouldSatisfy` elem "PostId"
+
+-- ══════════════════════════════════════════════
+-- Partial batch failures
+-- ══════════════════════════════════════════════
+
+partialBatchSpec :: Spec
+partialBatchSpec = describe "Partial batch failures" $ do
+
+ it "even key succeeds, odd key fails with FetchError" $ do
+ env <- mkTestEnv
+ (evenResult, oddResult) <- runTest env $
+ (,) <$> tryFetch (PartialKey 2) <*> tryFetch (PartialKey 3)
+ case evenResult of
+ Right v -> v `shouldBe` "partial-2"
+ Left _ -> expectationFailure "Expected Right for even key"
+ case oddResult of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected Left for odd key"
+
+ it "fetch on missing partial key throws FetchError" $ do
+ env <- mkTestEnv
+ result <- try @SomeException $ runTest env $ fetch (PartialKey 3)
+ case result of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected exception for odd PartialKey"
+
+ it "even-key results cached despite odd-key failures" $ do
+ env <- mkTestEnv
+ cRef <- newCacheRef
+ _ <- runTestWithCache env cRef $
+ (,) <$> tryFetch (PartialKey 2) <*> tryFetch (PartialKey 3)
+ -- Even key should be in cache
+ hit <- cacheLookup cRef (PartialKey 2)
+ case hit of
+ CacheHitReady v -> v `shouldBe` "partial-2"
+ _ -> expectationFailure "Expected CacheHitReady for even key"
+
+ it "mixed partial and full sources in same round" $ do
+ env <- mkTestEnv
+ (user, partialResult) <- runTest env $
+ (,) <$> fetch (UserId 1) <*> tryFetch (PartialKey 3)
+ user `shouldBe` "Alice"
+ case partialResult of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected Left for odd PartialKey"
+
+ it "multiple partial keys: some succeed, some fail" $ do
+ env <- mkTestEnv
+ results <- runTest env $
+ mapM tryFetch [PartialKey 1, PartialKey 2, PartialKey 3, PartialKey 4]
+ case results of
+ [r1, r2, r3, r4] -> do
+ case r1 of { Left _ -> pure (); Right _ -> expectationFailure "Expected Left for 1" }
+ case r2 of { Right v -> v `shouldBe` "partial-2"; Left _ -> expectationFailure "Expected Right for 2" }
+ case r3 of { Left _ -> pure (); Right _ -> expectationFailure "Expected Left for 3" }
+ case r4 of { Right v -> v `shouldBe` "partial-4"; Left _ -> expectationFailure "Expected Right for 4" }
+ _ -> expectationFailure "Expected 4 results"
+
+-- ══════════════════════════════════════════════
+-- Strategy failure isolation
+-- ══════════════════════════════════════════════
+
+strategyIsolationSpec :: Spec
+strategyIsolationSpec = describe "Strategy failure isolation" $ do
+
+ it "eager fails, sequential and concurrent succeed" $ do
+ env <- mkTestEnv
+ (eagerResult, seqVal, userVal) <- runTest env $
+ (,,) <$> tryFetch (FailEagerKey 1) <*> fetch (SeqKey 1) <*> fetch (UserId 1)
+ case eagerResult of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected Left for FailEagerKey"
+ seqVal `shouldBe` "seq-1"
+ userVal `shouldBe` "Alice"
+
+ it "sequential fails, concurrent still succeeds" $ do
+ env <- mkTestEnv
+ (seqResult, userVal) <- runTest env $
+ (,) <$> tryFetch (FailSeqKey 1) <*> fetch (UserId 1)
+ case seqResult of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected Left for FailSeqKey"
+ userVal `shouldBe` "Alice"
+
+ it "first sequential fails, second sequential still runs" $ do
+ env <- mkTestEnv
+ (failResult, seqVal) <- runTest env $
+ (,) <$> tryFetch (FailSeqKey 1) <*> fetch (SeqKey 1)
+ case failResult of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected Left for FailSeqKey"
+ seqVal `shouldBe` "seq-1"
+
+ it "all three strategies succeed: correct results" $ do
+ env <- mkTestEnv
+ (eager, seq', user) <- runTest env $
+ (,,) <$> fetch (EagerKey 1) <*> fetch (SeqKey 1) <*> fetch (UserId 1)
+ eager `shouldBe` "eager-1"
+ seq' `shouldBe` "seq-1"
+ user `shouldBe` "Alice"
+ dispatched <- readIORef (envDispatchLog env)
+ dispatched `shouldSatisfy` elem "EagerKey"
+ dispatched `shouldSatisfy` elem "SeqKey"
+ dispatched `shouldSatisfy` elem "UserId"
+
+ it "sequential sources dispatched even if eager failed" $ do
+ env <- mkTestEnv
+ _ <- runTest env $
+ (,) <$> tryFetch (FailEagerKey 1) <*> fetch (SeqKey 1)
+ dispatched <- readIORef (envDispatchLog env)
+ dispatched `shouldSatisfy` elem "FailEagerKey"
+ dispatched `shouldSatisfy` elem "SeqKey"
+
+ it "two sequential sources both produce correct results" $ do
+ env <- mkTestEnv
+ (s1, s2) <- runTest env $
+ (,) <$> fetch (SeqKey 1) <*> fetch (SeqKey2 1)
+ s1 `shouldBe` "seq-1"
+ s2 `shouldBe` "seq2-1"
+ dispatched <- readIORef (envDispatchLog env)
+ dispatched `shouldSatisfy` elem "SeqKey"
+ dispatched `shouldSatisfy` elem "SeqKey2"
+
+-- ══════════════════════════════════════════════
+-- Complex dependency patterns
+-- ══════════════════════════════════════════════
+
+complexPatternSpec :: Spec
+complexPatternSpec = describe "Complex dependency patterns" $ do
+
+ it "deep chain: 4 rounds, 1 key each" $ do
+ env <- mkTestEnv
+ (_, roundLog) <- runTestWithRoundLog env $ do
+ _ <- fetch (RangeKey 1)
+ _ <- fetch (RangeKey 2)
+ _ <- fetch (RangeKey 3)
+ fetch (RangeKey 4)
+ length roundLog `shouldBe` 4
+ mapM_ (\(_, keys, _) -> keys `shouldBe` 1) roundLog
+
+ it "diamond: 3 rounds (1 key, 2 keys, 1 key)" $ do
+ env <- mkTestEnv
+ (_, roundLog) <- runTestWithRoundLog env $ do
+ _ <- fetch (RangeKey 1)
+ _ <- (,) <$> fetch (RangeKey 2) <*> fetch (RangeKey 3)
+ fetch (RangeKey 4)
+ length roundLog `shouldBe` 3
+ case roundLog of
+ [(_, k1, _), (_, k2, _), (_, k3, _)] -> do
+ k1 `shouldBe` 1
+ k2 `shouldBe` 2
+ k3 `shouldBe` 1
+ _ -> expectationFailure "Expected 3 rounds"
+
+ it "fan-out-fan-in: 2 rounds (10 keys, 1 key)" $ do
+ env <- mkTestEnv
+ (_, roundLog) <- runTestWithRoundLog env $ do
+ _ <- fetchAll (map RangeKey [1..10])
+ fetch (RangeKey 99)
+ length roundLog `shouldBe` 2
+ case roundLog of
+ [(_, k1, _), (_, k2, _)] -> do
+ k1 `shouldBe` 10
+ k2 `shouldBe` 1
+ _ -> expectationFailure "Expected 2 rounds"
+
+ it "monadic-applicative-monadic: 3 rounds" $ do
+ env <- mkTestEnv
+ (_, roundLog) <- runTestWithRoundLog env $ do
+ _ <- fetch (RangeKey 1) -- round 1
+ _ <- (,) <$> fetch (RangeKey 2) -- round 2 (applicative)
+ <*> fetch (RangeKey 3)
+ fetch (RangeKey 4) -- round 3
+ length roundLog `shouldBe` 3
+
+ it "nested applicative: all keys in one round" $ do
+ env <- mkTestEnv
+ (_, roundLog) <- runTestWithRoundLog env $
+ (,) <$> ((,) <$> fetch (RangeKey 1) <*> fetch (RangeKey 2))
+ <*> fetch (RangeKey 3)
+ length roundLog `shouldBe` 1
+ case roundLog of
+ [(_, keys, _)] -> keys `shouldBe` 3
+ _ -> expectationFailure "Expected 1 round"
+
+ it "applicative with pure: fetch happens, pure doesn't create round" $ do
+ env <- mkTestEnv
+ (result, roundLog) <- runTestWithRoundLog env $
+ (,) <$> fetch (RangeKey 1) <*> pure (42 :: Int)
+ fst result `shouldBe` "range-1"
+ snd result `shouldBe` 42
+ length roundLog `shouldBe` 1
+
+ it "pure >>= fetch: single round" $ do
+ env <- mkTestEnv
+ (_, roundLog) <- runTestWithRoundLog env $
+ pure 1 >>= \x -> fetch (RangeKey x)
+ length roundLog `shouldBe` 1
+
+ it "round content matches expected key sets" $ do
+ env <- mkTestEnv
+ roundKeysRef <- newIORef ([] :: [[UserId]])
+ cRef <- newCacheRef
+ let e = FetchEnv
+ { fetchCache = cRef
+ , fetchLower = runTestM env
+ , fetchLift = testLiftIO
+ }
+ _ <- runTestM env $ runLoopWith e (\_ batches exec -> do
+ let ks = batchKeys @UserId batches
+ testLiftIO $ modifyIORef' roundKeysRef (\l -> l ++ [ks])
+ _ <- exec
+ pure ()
+ ) $ do
+ _ <- fetch (UserId 1)
+ (,) <$> fetch (UserId 2) <*> fetch (UserId 3)
+ rounds <- readIORef roundKeysRef
+ length rounds `shouldBe` 2
+ case rounds of
+ [r1, r2] -> do
+ r1 `shouldSatisfy` elem (UserId 1)
+ length r1 `shouldBe` 1
+ r2 `shouldSatisfy` elem (UserId 2)
+ r2 `shouldSatisfy` elem (UserId 3)
+ length r2 `shouldBe` 2
+ _ -> expectationFailure "Expected 2 rounds"
+
+-- ══════════════════════════════════════════════
+-- liftSource tests
+-- ══════════════════════════════════════════════
+
+liftSourceSpec :: Spec
+liftSourceSpec = describe "liftSource" $ do
+
+ it "liftSource (pure 42) returns 42 with zero rounds" $ do
+ env <- mkTestEnv
+ (result, roundLog) <- runTestWithRoundLog env $
+ liftSource (pure (42 :: Int))
+ result `shouldBe` 42
+ length roundLog `shouldBe` 0
+
+ it "liftSource combined applicatively with fetch: fetch still batches" $ do
+ env <- mkTestEnv
+ (result, roundLog) <- runTestWithRoundLog env $
+ (,) <$> liftSource (pure (42 :: Int)) <*> fetch (UserId 1)
+ fst result `shouldBe` 42
+ snd result `shouldBe` "Alice"
+ length roundLog `shouldBe` 1
+
+ it "liftSource in monadic bind does NOT create a round boundary" $ do
+ env <- mkTestEnv
+ (_, roundLog) <- runTestWithRoundLog env $ do
+ x <- liftSource (pure (1 :: Int))
+ fetch (RangeKey x)
+ -- liftSource returns Done immediately, so bind proceeds to fetch.
+ -- Only 1 round for the fetch.
+ length roundLog `shouldBe` 1
+
+ it "liftSource performs IO side effects" $ do
+ env <- mkTestEnv
+ ref <- newIORef False
+ _ <- runTest env $ liftSource $ TestM $ \_ -> do
+ writeIORef ref True
+ pure ()
+ val <- readIORef ref
+ val `shouldBe` True
+
+ it "liftSource interleaved with fetches in applicative doesn't disrupt batching" $ do
+ env <- mkTestEnv
+ (_, roundLog) <- runTestWithRoundLog env $
+ (,,) <$> fetch (UserId 1)
+ <*> liftSource (pure ("static" :: String))
+ <*> fetch (UserId 2)
+ length roundLog `shouldBe` 1
+ userBatches <- readIORef (envUserLog env)
+ length userBatches `shouldBe` 1
+
+-- ══════════════════════════════════════════════
+-- NoCaching detailed behavior
+-- ══════════════════════════════════════════════
+
+noCachingSpec :: Spec
+noCachingSpec = describe "NoCaching detailed behavior" $ do
+
+ it "same NoCaching key in two sequential rounds dispatches twice" $ do
+ env <- mkTestEnv
+ (a, b) <- runTest env $ do
+ x <- fetch (MutKey 1)
+ y <- fetch (MutKey 1)
+ pure (x, y)
+ mutBatches <- readIORef (envMutLog env)
+ -- Must dispatch exactly twice, once per round
+ length mutBatches `shouldBe` 2
+ -- Counter-based source returns different values across rounds
+ a `shouldSatisfy` (/= b)
+
+ it "NoCaching key in applicative with CacheResults key: both dispatched" $ do
+ env <- mkTestEnv
+ (mutVal, userVal) <- runTest env $
+ (,) <$> fetch (MutKey 1) <*> fetch (UserId 1)
+ userVal `shouldBe` "Alice"
+ mutVal `shouldSatisfy` const True
+ mutBatches <- readIORef (envMutLog env)
+ length mutBatches `shouldBe` 1
+
+ it "NoCaching key twice in same applicative: deduplicated within round" $ do
+ env <- mkTestEnv
+ (a, b) <- runTest env $
+ (,) <$> fetch (MutKey 1) <*> fetch (MutKey 1)
+ -- Same value from same round
+ a `shouldBe` b
+ mutBatches <- readIORef (envMutLog env)
+ -- Only one batch call for the round
+ length mutBatches `shouldBe` 1
+
+ it "counter-based MutKey source increments across rounds" $ do
+ env <- mkTestEnv
+ (a, b) <- runTest env $ do
+ x <- fetch (MutKey 1)
+ y <- fetch (MutKey 2)
+ pure (x, y)
+ -- Each round gets a different counter value
+ a `shouldSatisfy` (/= b)
+ mutCount <- readIORef (envMutCount env)
+ mutCount `shouldBe` 2
+
+ it "NoCaching: same key across >>= rounds dispatches fresh batch each time" $ do
+ env <- mkTestEnv
+ (a, b) <- runTest env $ do
+ x <- fetch (MutKey 1)
+ y <- fetch (MutKey 1)
+ pure (x, y)
+ mutBatches <- readIORef (envMutLog env)
+ -- Must dispatch exactly twice, once per round
+ length mutBatches `shouldBe` 2
+ -- Counter-based source returns different values across rounds
+ a `shouldSatisfy` (/= b)
+
+-- ══════════════════════════════════════════════
+-- Round stats and probe assertions
+-- ══════════════════════════════════════════════
+
+roundStatsSpec :: Spec
+roundStatsSpec = describe "Round stats and probe" $ do
+
+ it "RoundStats.roundSources counts distinct sources" $ do
+ env <- mkTestEnv
+ cRef <- newCacheRef
+ let batches = singletonBatch @TestM (UserId 1)
+ <> singletonBatch @TestM (PostId 10)
+ <> singletonBatch @TestM (UserId 2)
+ stats <- executeBatches (runTestM env) testLiftIO cRef batches
+ roundSources stats `shouldBe` 2 -- UserId and PostId
+
+ it "RoundStats.roundKeys counts deduplicated keys" $ do
+ env <- mkTestEnv
+ cRef <- newCacheRef
+ let batches = singletonBatch @TestM (UserId 1)
+ <> singletonBatch @TestM (UserId 1) -- duplicate
+ <> singletonBatch @TestM (PostId 10)
+ stats <- executeBatches (runTestM env) testLiftIO cRef batches
+ roundKeys stats `shouldBe` 2 -- UserId 1 (deduped) + PostId 10
+
+ it "RoundStats.roundCacheHits counts already-cached keys" $ do
+ env <- mkTestEnv
+ cRef <- newCacheRef
+ cacheWarm @UserId cRef (HM.singleton (UserId 1) "Alice")
+ let batches = singletonBatch @TestM (UserId 1)
+ <> singletonBatch @TestM (UserId 2)
+ stats <- executeBatches (runTestM env) testLiftIO cRef batches
+ roundCacheHits stats `shouldBe` 1 -- UserId 1 was cached
+ roundKeys stats `shouldBe` 2 -- total keys in batch
+
+ it "probe on blocked computation returns Blocked with correct batch info" $ do
+ env <- mkTestEnv
+ cRef <- newCacheRef
+ let e = FetchEnv
+ { fetchCache = cRef
+ , fetchLower = runTestM env
+ , fetchLift = testLiftIO
+ }
+ status <- runTestM env $ unFetch
+ ((,) <$> fetch (UserId 1) <*> fetch (PostId 10)) e
+ case status of
+ Done _ -> expectationFailure "Expected Blocked"
+ Blocked bs _ -> do
+ batchSize bs `shouldBe` 2
+ batchSourceCount bs `shouldBe` 2
+
+-- ══════════════════════════════════════════════
+-- MonadThrow / MonadCatch tests
+-- ══════════════════════════════════════════════
+
+-- | A custom test exception for MonadThrow/MonadCatch tests.
+newtype TestException = TestException String
+ deriving stock (Show, Eq)
+
+instance MC.Exception TestException
+
+throwCatchSpec :: Spec
+throwCatchSpec = describe "MonadThrow / MonadCatch" $ do
+
+ it "throwM in Fetch produces exception catchable at IO level" $ do
+ env <- mkTestEnv
+ result <- try @SomeException $ runTest env $
+ MC.throwM (TestException "boom")
+ case result of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected exception"
+
+ it "catch in Fetch catches throwM" $ do
+ env <- mkTestEnv
+ result <- runTest env $
+ MC.catch
+ (MC.throwM (TestException "caught") :: Fetch TestM String)
+ (\(TestException msg) -> pure ("recovered: " <> msg))
+ result `shouldBe` "recovered: caught"
+
+ it "catch in Fetch across round boundary catches later-round exception" $ do
+ env <- mkTestEnv
+ result <- runTest env $
+ MC.catch
+ (do _ <- fetch (UserId 1) -- round 1
+ MC.throwM (TestException "round2") :: Fetch TestM String)
+ (\(TestException msg) -> pure ("caught: " <> msg))
+ result `shouldBe` "caught: round2"
+
+ it "catch wrapping fetch of missing key catches FetchError" $ do
+ env <- mkTestEnv
+ result <- runTest env $
+ MC.catch
+ (fetch (UserId 999))
+ (\(_ :: SomeException) -> pure "fallback")
+ result `shouldBe` "fallback"
+
+ it "throwM/catch in Mutate works" $ do
+ env <- mkTestEnv
+ result <- runMutateTest env $
+ MC.catch
+ (MC.throwM (TestException "mut") :: Mutate TestM TestM String)
+ (\(TestException msg) -> pure ("caught: " <> msg))
+ result `shouldBe` "caught: mut"
+
+ it "throwM/catch in MockFetch works via delegation" $ do
+ let mocks = mockData @UserId [(UserId 1, "Alice")]
+ result <- runMockFetch @TestM mocks $
+ MC.catch
+ (MC.throwM (TestException "mock") :: MockFetch TestM IO String)
+ (\(TestException msg) -> pure ("caught: " <> msg))
+ result `shouldBe` "caught: mock"
+
+-- ══════════════════════════════════════════════
+-- Async exception safety tests
+-- ══════════════════════════════════════════════
+
+asyncExceptionSpec :: Spec
+asyncExceptionSpec = describe "Async exception safety" $ do
+ asyncIVarSpec
+ asyncFetchSpec
+ asyncMutateSpec
+
+asyncIVarSpec :: Spec
+asyncIVarSpec = describe "IVar" $ do
+
+ it "awaitIVar is interruptible by throwTo" $ do
+ iv <- newIVar @Int
+ started <- newEmptyMVar
+ resultVar <- newEmptyMVar
+ tid <- forkIO $ do
+ putMVar started ()
+ r <- try @SomeException (awaitIVar iv)
+ putMVar resultVar r
+ -- Wait for the thread to be ready (about to enter readMVar)
+ takeMVar started
+ -- Deliver async exception; throwTo blocks until delivered
+ throwTo tid (toException (TestException "killed"))
+ result <- takeMVar resultVar
+ case result of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected async exception from throwTo"
+
+ it "IVar writable after reader is killed; new reader sees value" $ do
+ iv <- newIVar @Int
+ started <- newEmptyMVar
+ done <- newEmptyMVar
+ tid <- forkIO $ do
+ putMVar started ()
+ _ <- try @SomeException (awaitIVar iv)
+ putMVar done ()
+ takeMVar started
+ throwTo tid (toException (TestException "killed"))
+ -- Wait for the killed thread to finish its exception handler
+ takeMVar done
+ -- IVar should still be writable
+ writeIVar iv 42
+ result <- awaitIVar iv
+ case result of
+ Right v -> v `shouldBe` 42
+ Left _ -> expectationFailure "Expected Right after writeIVar"
+
+ it "multiple readers: kill one, others still see value when written" $ do
+ iv <- newIVar @Int
+ started1 <- newEmptyMVar
+ started2 <- newEmptyMVar
+ resultVar <- newEmptyMVar
+ tid1 <- forkIO $ do
+ putMVar started1 ()
+ _ <- try @SomeException (awaitIVar iv)
+ pure ()
+ _ <- forkIO $ do
+ putMVar started2 ()
+ r <- awaitIVar iv
+ putMVar resultVar r
+ takeMVar started1
+ takeMVar started2
+ -- Kill reader 1
+ throwTo tid1 (toException (TestException "killed"))
+ -- Write value; reader 2 should see it
+ writeIVar iv 99
+ result <- takeMVar resultVar
+ case result of
+ Right v -> v `shouldBe` 99
+ Left _ -> expectationFailure "Expected Right from surviving reader"
+
+asyncFetchSpec :: Spec
+asyncFetchSpec = describe "Fetch" $ do
+
+ it "cancel during batch execution propagates to caller" $ do
+ env <- mkTestEnv
+ handle <- async $ runTest env $ fetch (BlockingKey 1)
+ -- Wait until the batch is in flight
+ takeMVar (envAsyncStarted env)
+ cancel handle
+ result <- waitCatch handle
+ case result of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected async exception"
+ -- Cleanup: release the blocking batch thread so it doesn't leak
+ _ <- tryPutMVar (envAsyncProceed env) ()
+ pure ()
+
+ it "completed results remain cached after later round is cancelled" $ do
+ env <- mkTestEnv
+ cRef <- newCacheRef
+ handle <- async $ runTestWithCache env cRef $ do
+ _ <- fetch (UserId 1) -- round 1: succeeds
+ fetch (BlockingKey 1) -- round 2: blocks
+ -- Round 2's batch is in flight
+ takeMVar (envAsyncStarted env)
+ cancel handle
+ _ <- tryPutMVar (envAsyncProceed env) ()
+ -- UserId 1 was cached in round 1 and should still be valid
+ hit <- cacheLookup cRef (UserId 1)
+ case hit of
+ CacheHitReady v -> v `shouldBe` "Alice"
+ _ -> expectationFailure "Expected CacheHitReady for UserId 1"
+
+ it "concurrent threads sharing cache: cancel one, other completes" $ do
+ env <- mkTestEnv
+ cRef <- newCacheRef
+ -- Thread A: fetches UserId 1, then blocks on BlockingKey
+ handleA <- async $ runTestWithCache env cRef $ do
+ _ <- fetch (UserId 1)
+ fetch (BlockingKey 1)
+ -- Wait for A to reach the blocking batch
+ takeMVar (envAsyncStarted env)
+ -- Thread B: uses the same cache, fetches UserId 2
+ resultB <- runTestWithCache env cRef $ fetch (UserId 2)
+ resultB `shouldBe` "Bob"
+ -- Cancel A and cleanup
+ cancel handleA
+ _ <- tryPutMVar (envAsyncProceed env) ()
+ pure ()
+
+ it "background batch thread fills IVars after parent is cancelled" $ do
+ env <- mkTestEnv
+ cRef <- newCacheRef
+ handle <- async $ runTestWithCache env cRef $ do
+ _ <- fetch (UserId 1)
+ fetch (BlockingKey 1)
+ takeMVar (envAsyncStarted env)
+ cancel handle
+ -- Release the batch thread; it should complete and fill the IVar
+ putMVar (envAsyncProceed env) ()
+ -- The batch thread is an orphaned `async` child; it will fill the IVar
+ hit <- cacheLookup cRef (BlockingKey 1)
+ case hit of
+ CacheHitPending iv -> do
+ result <- awaitIVar iv
+ case result of
+ Right v -> v `shouldBe` "blocking-1"
+ Left _ -> expectationFailure "Expected Right from background batch"
+ CacheHitReady v -> v `shouldBe` "blocking-1"
+ CacheMiss -> expectationFailure "Expected cache entry for BlockingKey 1"
+
+ it "MonadCatch handler is NOT invoked for async exceptions during batch execution" $ do
+ -- Fetch's catch wraps the probe phase, not batch execution.
+ -- Async exceptions during executeBatches bypass MonadCatch.
+ env <- mkTestEnv
+ handlerCalled <- newIORef False
+ handle <- async $ runTest env $
+ MC.catch
+ (do _ <- fetch (UserId 1)
+ fetch (BlockingKey 1))
+ (\(_ :: SomeException) -> do
+ liftSource $ testLiftIO $ writeIORef handlerCalled True
+ pure "caught")
+ takeMVar (envAsyncStarted env)
+ cancel handle
+ _ <- tryPutMVar (envAsyncProceed env) ()
+ result <- waitCatch handle
+ case result of
+ Left _ -> pure () -- exception propagated, not caught by handler
+ Right "caught" -> expectationFailure
+ "MonadCatch handler should not catch async exceptions during batch execution"
+ Right _ -> expectationFailure "Unexpected success"
+ called <- readIORef handlerCalled
+ called `shouldBe` False
+
+ it "throwTo with custom exception reaches caller via try" $ do
+ env <- mkTestEnv
+ started <- newEmptyMVar
+ resultVar <- newEmptyMVar
+ tid <- forkIO $ do
+ putMVar started ()
+ r <- try @SomeException $ runTest env $ fetch (BlockingKey 1)
+ putMVar resultVar r
+ takeMVar started
+ -- Wait for the batch to start so we know the thread is deep in execution
+ takeMVar (envAsyncStarted env)
+ throwTo tid (toException (TestException "async-kill"))
+ result <- takeMVar resultVar
+ case result of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected exception from throwTo"
+ _ <- tryPutMVar (envAsyncProceed env) ()
+ pure ()
+
+ it "cache not corrupted by cancelled computation; fresh run succeeds" $ do
+ env <- mkTestEnv
+ cRef <- newCacheRef
+ -- First run: fetch user, then block and get cancelled
+ handle <- async $ runTestWithCache env cRef $ do
+ _ <- fetch (UserId 1)
+ fetch (BlockingKey 1)
+ takeMVar (envAsyncStarted env)
+ cancel handle
+ _ <- tryPutMVar (envAsyncProceed env) ()
+ -- Second run: fresh computation on the same cache
+ -- UserId 1 should be cached; UserId 2 should be fetchable
+ env2 <- mkTestEnv -- fresh env so BlockingKey barriers are reset
+ result <- runTestWithCache env2 cRef $
+ (,) <$> fetch (UserId 1) <*> fetch (UserId 2)
+ result `shouldBe` ("Alice", "Bob")
+ -- Verify UserId 1 came from cache (no second batchFetch for it)
+ userLog <- readIORef (envUserLog env2)
+ let allFetchedUsers = concat userLog
+ allFetchedUsers `shouldNotContain` [UserId 1]
+
+asyncMutateSpec :: Spec
+asyncMutateSpec = describe "Mutate" $ do
+
+ it "cancel before mutation: mutation never executes" $ do
+ env <- mkTestEnv
+ cRef <- newCacheRef
+ handle <- async $ runMutateTestWithCache env cRef $ do
+ _ <- fetch (UserId 1) -- round 1: succeeds
+ _ <- fetch (BlockingKey 1) -- round 2: blocks, gets cancelled
+ mutate (UpdateUser (UserId 1) "ShouldNotHappen")
+ takeMVar (envAsyncStarted env)
+ cancel handle
+ _ <- tryPutMVar (envAsyncProceed env) ()
+ -- If the mutation had run, reconcileCache would have overwritten
+ -- UserId 1 with "updated-ShouldNotHappen-1". Check it's still "Alice".
+ hit <- cacheLookup cRef (UserId 1)
+ case hit of
+ CacheHitReady v -> v `shouldBe` "Alice"
+ _ -> expectationFailure "Expected CacheHitReady for UserId 1"
+
+ it "cancel during fetch phase of Mutate propagates exception" $ do
+ env <- mkTestEnv
+ handle <- async $ runMutateTest env $ do
+ fetch (BlockingKey 1) -- blocks, gets cancelled
+ takeMVar (envAsyncStarted env)
+ cancel handle
+ result <- waitCatch handle
+ case result of
+ Left _ -> pure ()
+ Right _ -> expectationFailure "Expected async exception"
+ _ <- tryPutMVar (envAsyncProceed env) ()
+ pure ()