sofetch (empty) → 0.1.0.0

raw patch · 20 files changed

+7864/−0 lines, 20 filesdep +aesondep +asyncdep +basesetup-changed

Dependencies added: aeson, async, base, bytestring, containers, exceptions, hashable, hspec, http-client, http-client-tls, http-types, semigroupoids, sofetch, sqlite-simple, text, time, transformers, unliftio-core, unordered-containers

Files

• CHANGELOG.md +11/−0
• LICENSE +26/−0
• README.md +404/−0
• Setup.hs +2/−0
• examples/GitHubExplorer.hs +340/−0
• examples/SqliteBlog.hs +827/−0
• sofetch.cabal +141/−0
• src/Fetch.hs +456/−0
• src/Fetch/Batched.hs +456/−0
• src/Fetch/Cache.hs +247/−0
• src/Fetch/Class.hs +344/−0
• src/Fetch/Combinators.hs +309/−0
• src/Fetch/Deriving.hs +120/−0
• src/Fetch/Engine.hs +172/−0
• src/Fetch/IVar.hs +56/−0
• src/Fetch/Memo.hs +103/−0
• src/Fetch/Mock.hs +264/−0
• src/Fetch/Mutate.hs +253/−0
• src/Fetch/Traced.hs +118/−0
• test/Spec.hs +3215/−0

@@ -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

@@ -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.

@@ -0,0 +1,404 @@+<p align="center">+  <img src="logo.svg" alt="sofetch" width="400">+</p>++<p align="center">+  <img src="fetch.gif" alt="That's so fetch" width="300">+</p>++<p align="center">+  <a href="LICENSE"><img src="https://img.shields.io/badge/license-BSD--3--Clause-blue.svg" alt="License: BSD-3-Clause"></a>+  <img src="https://img.shields.io/badge/language-Haskell-purple.svg" alt="Haskell">+  <img src="https://img.shields.io/badge/GHC-9.2_%7C_9.4_%7C_9.6_%7C_9.8-informational.svg" alt="GHC versions">+</p>++---++## 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.++<p align="center">+  <img src="docs/n-plus-one-vs-batched.svg" alt="N+1 queries vs 1 batched query with sofetch" width="720">+</p>++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<br/>[UserById 1, 2]"]+  f2["fetch (UserById 2)"] --> b1+  f3["fetch (PostsByAuthor 1)"] --> b2["batchFetch<br/>[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<br/>production"]+  B --> D["MockFetch<br/>testing"]+  B --> E["TracedFetch<br/>instrumentation"]+  C --> F["DataSource instances<br/>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.++---++<sub>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.</sub>

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -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!"

@@ -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!"

@@ -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 <https://github.com/githubuser/sofetch#readme>+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

@@ -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(..))

@@ -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 ()

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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"

@@ -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)

@@ -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

@@ -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)

@@ -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

@@ -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)

@@ -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 ()