fractal-layer (empty) → 0.1.0.0

raw patch · 12 files changed

+4947/−0 lines, 12 filesdep +QuickCheckdep +aesondep +base

Dependencies added: QuickCheck, aeson, base, bytestring, containers, fractal-layer, hashable, hspec, mtl, profunctors, resourcet, selective, text, time, transformers, unliftio, unordered-containers

Files

• CHANGELOG.md +11/−0
• LICENSE +27/−0
• README.md +76/−0
• fractal-layer.cabal +91/−0
• src/Fractal/Layer.hs +1087/−0
• src/Fractal/Layer/Diagnostics.hs +583/−0
• src/Fractal/Layer/Interceptor.hs +162/−0
• src/Fractal/Layer/Internal.hs +168/−0
• test/Fractal/Layer/DiagnosticsSpec.hs +962/−0
• test/Fractal/Layer/InterceptorSpec.hs +169/−0
• test/Fractal/Layer/LayerSpec.hs +1610/−0
• test/Spec.hs +1/−0

@@ -0,0 +1,11 @@+# Changelog++## 0.1.0.0 — 2026-03-18++* Initial release.+* Core `Layer` type with `Monad`, `Arrow`, `Category`, `ArrowChoice`,+  `Profunctor`, `Traversing`, `Alternative`, and `Selective` instances.+* Three construction primitives: `effect`, `resource`, `bracketed`.+* `Service` for singleton caching with thread-safe initialisation.+* `LayerInterceptor` for observability hooks.+* `Fractal.Layer.Diagnostics` for tree-structured initialisation tracing.

@@ -0,0 +1,27 @@+Copyright (c) 2024-2026, Ian Duncan++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,76 @@+# fractal-layer++Composable, type-safe resource management and dependency injection for+Haskell, inspired by [ZIO's ZLayer](https://zio.dev/reference/contextual/zlayer).++## The idea++A `Layer m deps env` is a recipe for building a value of type `env` from+dependencies `deps`, with automatic resource cleanup. Think of it as+`deps -> m env` plus a finaliser that runs when the scope ends.++```haskell+configLayer :: Layer IO () Config+dbLayer     :: Layer IO Config Database+cacheLayer  :: Layer IO Config Cache+```++Each layer declares exactly what it needs and what it produces. The+compiler enforces correct wiring at every composition site.++## Composition++Layers compose via standard Haskell typeclasses:++```haskell+-- sequential: config feeds into db and web+appLayer :: Layer IO () (Config, (Database, WebServer))+appLayer = configLayer >>> (dbLayer &&& webLayer)++-- fallback: try remote, fall back to local+dbLayer :: Layer IO Config Database+dbLayer = remotePostgres <|> localSQLite+```++`(&&&)` runs both sides concurrently. `(<|>)` cleans up the failed+branch before trying the fallback.++## Services (shared singletons)++When two layers need the same expensive resource, `Service` gives you+at-most-once initialisation with automatic sharing:++```haskell+poolService :: Service IO Config ConnectionPool+poolService = mkService $ do+  cfg <- ask+  resource (createPool cfg) drainPool++webLayer :: Layer IO Config WebServer+webLayer = do+  pool <- service poolService   -- creates the pool+  resource (startWeb pool) stopWeb++apiLayer :: Layer IO Config ApiServer+apiLayer = do+  pool <- service poolService   -- reuses the same pool+  resource (startApi pool) stopApi+```++## Running++```haskell+main :: IO ()+main = withLayer () appLayer $ \(cfg, (db, ws)) ->+  serveRequests ws+  -- all resources released here, in reverse acquisition order+```++## Documentation++See the Haddock docs on `Fractal.Layer` for a full walkthrough with+examples.++## License++BSD-3-Clause

@@ -0,0 +1,91 @@+cabal-version:      3.0+name:               fractal-layer+version:            0.1.0.0+synopsis:           Composable resource management and dependency injection+description:+    Composable, type-safe resource management and dependency injection+    for Haskell, inspired by ZIO's ZLayer.+    .+    Break your application's god record into independent layers, each+    declaring exactly what it needs and what it produces. Layers compose+    via Arrow, Category, and Alternative, with automatic resource cleanup,+    concurrent initialisation, and singleton service caching.++license:            BSD-3-Clause+license-file:       LICENSE+author:             Ian Duncan+maintainer:         ian@mercury.com+category:           Control+build-type:         Simple+tested-with:        GHC == 9.10.3+extra-doc-files:    README.md+                  , CHANGELOG.md++source-repository head+  type:     git+  location: https://github.com/iand675/fractal+  subdir:   fractal-layer++common warnings+    ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates+                 -Wincomplete-uni-patterns -Wmissing-home-modules+                 -Wpartial-fields -Wredundant-constraints++common extensions+    default-extensions: OverloadedStrings+                      , OverloadedRecordDot+                      , RecordWildCards+                      , DeriveGeneric+                      , DerivingStrategies+                      , LambdaCase+                      , GeneralizedNewtypeDeriving+                      , RankNTypes+                      , ScopedTypeVariables+                      , BlockArguments++library+    import:           warnings, extensions+    exposed-modules:  Fractal.Layer+                    , Fractal.Layer.Diagnostics+                    , Fractal.Layer.Interceptor+                    , Fractal.Layer.Internal+    build-depends:    base >= 4.17.0.0 && < 5+                    , resourcet >= 1.2 && < 2+                    , unliftio >= 0.2 && < 1+                    , transformers >= 0.5 && < 0.7+                    , mtl >= 2.2 && < 3+                    , containers >= 0.6 && < 1+                    , hashable >= 1.4 && < 2+                    , unordered-containers >= 0.2 && < 1+                    , profunctors >= 5.6 && < 6+                    , selective >= 0.5 && < 1+                    , aeson >= 2.0 && < 3+                    , text >= 2.0 && < 3+                    , time >= 1.12 && < 2+    hs-source-dirs:   src+    default-language: Haskell2010++test-suite fractal-layer-test+    import:           warnings, extensions+    default-language: Haskell2010+    type:             exitcode-stdio-1.0+    hs-source-dirs:   test+    main-is:          Spec.hs+    other-modules:    Fractal.Layer.DiagnosticsSpec+                    , Fractal.Layer.InterceptorSpec+                    , Fractal.Layer.LayerSpec+    build-tool-depends: hspec-discover:hspec-discover >= 2.10 && < 3+    build-depends:    base >= 4.17.0.0 && < 5+                    , fractal-layer+                    , hspec >= 2.10 && < 3+                    , mtl >= 2.2 && < 3+                    , profunctors >= 5.6 && < 6+                    , QuickCheck >= 2.14 && < 3+                    , unliftio >= 0.2 && < 1+                    , text >= 2.0 && < 3+                    , aeson >= 2.0 && < 3+                    , bytestring >= 0.11 && < 1+                    , resourcet >= 1.2 && < 2+                    , time >= 1.12 && < 2+                    , unordered-containers >= 0.2 && < 1+                    , selective >= 0.5 && < 1

@@ -0,0 +1,1087 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- |+-- Module      : Fractal.Layer+-- Description : Composable, type-safe resource management and dependency injection+-- Stability   : experimental+--+-- = What is a Layer?+--+-- A @'Layer' m deps env@ describes one layer of an application: it+-- requires some services as input (@deps@) and produces some services+-- as output (@env@).  You can think of it as an effectful function+-- with managed resource lifetimes:+--+-- @+-- type Layer m deps env  ≈  deps -> m env   (+ automatic cleanup)+-- @+--+-- For example, a @Layer IO (Socket, Config) Database@ says: "give me a+-- @Socket@ and a @Config@, and I will build you a @Database@, cleaning+-- it up when you're done."+--+-- A layer with no dependencies uses @()@ for @deps@:+--+-- @+-- configLayer :: Layer IO () Config+-- @+--+-- This means @configLayer@ is a self-contained recipe for producing a+-- @Config@ value. It doesn't need anything from the outside world+-- other than @IO@.+--+-- = Why Layers?+--+-- == The Problem: God Records+--+-- Most Haskell applications centralise their dependencies in a single+-- record:+--+-- @+-- data App = App+--   { appConfig  :: Config+--   , appDB      :: Database+--   , appCache   :: Cache+--   , appWeb     :: WebServer+--   , appMetrics :: MetricsCollector+--   }+--+-- initApp :: IO App+-- initApp = do+--   cfg     <- loadConfig+--   db      <- connectDB cfg        -- what if this throws?+--   cache   <- connectCache cfg     -- do we close db?+--   web     <- startServer cfg db   -- what about cache?+--   metrics <- startMetrics cfg     -- cleanup order?+--   pure App {..}+-- @+--+-- This works for small programs. As the application grows, three+-- problems compound:+--+-- 1. __No local reasoning.__  Every function that accepts @App@ can+--    touch every field. Changing the cache implementation forces you+--    to audit every consumer of @App@, even those that never use the+--    cache, because the type doesn't tell you what is actually needed.+--+-- 2. __Fragile resource safety.__  If @connectCache@ throws, is @db@+--    closed?  If @startServer@ throws, is @cache@ released?  The+--    compiler gives you no help. Maintaining the cleanup order by hand,+--    and keeping it correct as the application evolves, is tedious and+--    error-prone. Mistakes show up as leaked connections and file+--    handles in production.+--+-- 3. __Hidden sharing.__  Two subsystems that both need a connection+--    pool either get two independent pools (wasteful, and potentially+--    incorrect if they need to share a transaction context) or share+--    one via convention. Nothing in the type system enforces or even+--    documents the sharing.+--+-- == The Solution+--+-- With layers, you break the god record into independent pieces, each+-- declaring exactly what it needs:+--+-- @+-- configLayer :: Layer IO () Config+-- dbLayer     :: Layer IO Config Database+-- cacheLayer  :: Layer IO Config Cache+-- webLayer    :: Layer IO (Config, Database) WebServer+-- @+--+-- Each layer is self-contained. You can read, test, and refactor+-- @dbLayer@ without looking at @cacheLayer@ or @webLayer@. The type+-- checker enforces that dependencies are satisfied at every+-- composition site. If you change the signature of @dbLayer@, every+-- composition that uses it produces a type error until it is updated.+--+-- = Properties of Layers+--+-- == Recipes for Creating Services+--+-- A layer describes /how/ to build a service from its dependencies.+-- @Layer IO Config Database@ is a recipe that says: "given a @Config@,+-- I know how to create a @Database@." The recipe includes both the+-- initialisation logic and any associated cleanup.+--+-- == An Alternative to Manual Initialisation+--+-- A layer plays the same role as a hand-written @initFoo :: Config -> IO Foo@+-- function, but with important extras: it tracks resource lifetimes, composes+-- with other layers via standard typeclasses, and participates in parallel+-- startup and fallback. You get the same "build a value from its inputs"+-- workflow, without any of the manual plumbing.+--+-- == Effectful and Resourceful+--+-- Layer construction is fully effectful. Layers can acquire resources+-- (open connections, start threads) and register finalisers that are+-- __guaranteed__ to run when the layer's scope ends, even under+-- exceptions or cancellation. You never write a manual cleanup chain.+--+-- For example, a @Database@ layer can open a connection pool during+-- construction and drain it on shutdown:+--+-- @+-- dbLayer :: Layer IO Config Database+-- dbLayer = do+--   cfg <- ask+--   resource (createPool cfg) drainPool+-- @+--+-- == Asynchronous+--+-- Layer construction is fully asynchronous and non-blocking. This+-- matters when initialisation involves network calls, waiting for+-- readiness checks, or other long-running work. You can construct+-- an entire application's dependency graph without blocking the main+-- thread on any single subsystem.+--+-- == Parallel+--+-- Independent layers are acquired in parallel automatically. When you+-- compose two layers with @&&&@, both sides are started concurrently+-- via @async@. For applications with many independent subsystems, this+-- can significantly reduce startup time compared to sequential+-- initialisation.+--+-- @+-- -- db and cache start concurrently, both using the same config+-- backend :: Layer IO Config (Database, Cache)+-- backend = dbLayer &&& cacheLayer+-- @+--+-- == Composable+--+-- Layers compose through standard Haskell typeclasses. You don't need+-- to learn a new composition API; if you know 'Category', 'Arrow',+-- and 'Alternative', you already know how to wire layers together:+--+-- [@>>>@]  __Sequential__: pipe the output of one layer as the input+--    to the next.+--+--    @configLayer >>> dbLayer  ::  Layer IO () Database@+--+-- [@&&&@]  __Parallel__: run two layers concurrently on the same+--    input, returning both results as a tuple.+--+--    @dbLayer &&& cacheLayer  ::  Layer IO Config (Database, Cache)@+--+-- [@***@]  __Split__: run two layers concurrently on different inputs.+--+-- [@\<|\>@]  __Fallback__: try the first layer; if it fails, clean up+--    its resources and try the second.+--+--    @remoteDB \<|\> localDB  ::  Layer IO Config Database@+--+-- [@+++@, @|||@]  __Choice__: route @Either@ inputs through different+--    layers.+--+-- A complete example wiring up an application:+--+-- @+-- appLayer :: Layer IO () (Config, (Database, WebServer))+-- appLayer = configLayer >>> (dbLayer &&& webLayer)+-- @+--+-- This reads as: "build a @Config@ from nothing, then use it to build+-- a @Database@ and a @WebServer@ in parallel." The compiler verifies+-- that the output type of @configLayer@ (@Config@) matches the input+-- type expected by @dbLayer@ and @webLayer@.+--+-- == Resilient via Fallback+--+-- Layer construction can be made resilient using 'Alternative'. If+-- the primary layer fails, @\<|\>@ cleans up any resources the failed+-- attempt acquired and tries an alternative:+--+-- @+-- databaseLayer :: Layer IO Config Database+-- databaseLayer = remotePostgres \<|\> localSQLite+-- @+--+-- The failed branch's resources (partially-opened connections, temp+-- files) are released before the fallback begins. This is safe by+-- construction; you do not need to write any cleanup code for the+-- failure path.+--+-- = Running Layers+--+-- Once you have composed your layer graph, you run it with 'withLayer':+--+-- @+-- main :: IO ()+-- main = withLayer () appLayer $ \\(cfg, (db, ws)) -> do+--   putStrLn "All services ready."+--   serveRequests ws+--   -- when this callback returns (or throws), all resources+--   -- are released in reverse acquisition order+-- @+--+-- 'withLayer' acquires every resource in the composition, passes the+-- resulting environment to your callback, and releases everything when+-- the callback finishes. This guarantee holds even if the callback+-- throws an exception.+--+-- For tests and REPL experiments where you don't need the resources to+-- outlive construction, 'runLayer' is a simpler alternative:+--+-- @+-- cfg <- runLayer () configLayer+-- @+--+-- = Services: Shared Singletons+--+-- Real applications have diamond dependencies. Both @webLayer@ and+-- @apiLayer@ need a connection pool, but you want exactly one pool,+-- not two.+--+-- 'Service' solves this. Wrap any layer with 'mkService' to mark it+-- as shared, and consume it with 'service':+--+-- @+-- poolService :: Service IO Config ConnectionPool+-- poolService = mkService $ do+--   cfg <- ask+--   resource (createPool cfg) drainPool+-- @+--+-- Now every consumer gets the same instance:+--+-- @+-- webLayer :: Layer IO Config WebServer+-- webLayer = do+--   pool <- service poolService   -- first call creates the pool+--   resource (startWeb pool) stopWeb+--+-- apiLayer :: Layer IO Config ApiServer+-- apiLayer = do+--   pool <- service poolService   -- second call reuses the same pool+--   resource (startApi pool) stopApi+--+-- -- one pool, two consumers, automatic cleanup+-- app :: Layer IO Config (WebServer, ApiServer)+-- app = webLayer &&& apiLayer+-- @+--+-- Key properties of services:+--+-- * __At-most-once initialisation.__ The first call to 'service'+--   within a composition creates the instance. Every subsequent call+--   returns the same value.+--+-- * __Thread-safe.__ If @webLayer@ and @apiLayer@ race to create the+--   pool (as they will under @&&&@), only one thread performs the+--   initialisation and the other blocks until it completes.+--+-- * __Failure caching.__ If initialisation fails, the failure is+--   cached. Later calls to 'service' will re-throw the same exception+--   rather than retrying.+--+-- * __Automatic cleanup.__ The service's finaliser runs when the+--   enclosing 'withLayer' scope ends, just like any other resource.+--+-- = Observability+--+-- Every resource acquisition, effect, service lookup, and composition+-- step fires callbacks on a 'LayerInterceptor'. You can plug in+-- logging, metrics, or distributed tracing without modifying any layer+-- code. The companion module "Fractal.Layer.Diagnostics" turns these+-- callbacks into a tree you can render to the terminal or export as+-- JSON.+--+-- @+-- main :: IO ()+-- main = withLayerAndInterceptor loggingInterceptor () appLayer $ \\env ->+--   runApp env+-- @+--+-- = Creating Layers+--+-- There are three ways to create a layer, depending on the lifecycle+-- of the value it produces:+--+-- ['effect']  For values that don't need cleanup: configuration,+--   computed values, or any action whose result can be garbage+--   collected normally.+--+-- ['resource']  For values with an acquire\/release lifecycle:+--   database connections, file handles, thread pools. The release+--   action is guaranteed to run.+--+-- ['bracketed']  For adapting existing @with@-style functions from+--   third-party libraries, e.g. @withSocketsDo@, @withConnection@.+--+-- In all three cases, dependencies are accessed via 'ask' from+-- 'MonadReader', not through function arguments:+--+-- @+-- configLayer :: Layer IO () Config+-- configLayer = effect loadConfig+--+-- dbLayer :: Layer IO Config Database+-- dbLayer = do+--   cfg <- ask+--   resource (connectDB cfg) closeDB+--+-- poolLayer :: Layer IO () ConnectionPool+-- poolLayer = bracketed withConnectionPool+-- @+--+-- = Design Influences+--+-- The layer model is inspired by ZIO's @ZLayer@+-- (<https://zio.dev/reference/contextual/zlayer>), adapted to+-- idiomatic Haskell using 'Arrow', 'Category', and 'Alternative'.+module Fractal.Layer+  ( -- * Core type+    Layer,++    -- * Building layers+    -- $building+    effect,+    resource,+    bracketed,++    -- * Running layers+    -- $running+    withLayer,+    runLayer,++    -- * Services (shared singletons)+    -- $services+    Service,+    mkService,+    service,+    uncached,++    -- * Composition helpers+    -- $composition+    composeLayer,+    zipLayer,+    mapLayer,++    -- * Interceptor-aware runners+    runLayerWithInterceptor,+    withLayerAndInterceptor,++    -- * Interceptors (re-exported from "Fractal.Layer.Interceptor")+    LayerInterceptor (..),+    nullInterceptor,+    combineInterceptors,++    -- * Exceptions+    EmptyLayer (..),++    -- * Re-exports+    MonadResource,+  )+where++import Control.Applicative+import Control.Arrow+import Control.Category+import Control.Monad+import Control.Monad.Reader.Class+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Resource (createInternalState, runInternalState, withInternalState)+import Control.Monad.Trans.Resource.Internal (ReleaseMap (..), stateCleanupChecked)+import Control.Selective+import Data.List.NonEmpty (NonEmpty(..))+import Data.Semigroup (Semigroup(..))+import Data.IntMap.Strict (mapKeysMonotonic)+import Data.Profunctor+import Data.Profunctor.Traversing+import qualified Data.Text as T+import Data.Time.Clock (getCurrentTime, diffUTCTime)+import Data.Typeable+import Fractal.Layer.Interceptor+import Fractal.Layer.Internal+import UnliftIO+import UnliftIO.Resource+import Prelude hiding ((.))++-- $building+--+-- Three primitives cover the full spectrum of resource lifecycles:+--+-- * 'effect': for values that don't need cleanup (config, computed+--   values). Analogous to @ZLayer.fromZIO@ or @ZLayer.succeed@ in ZIO.+-- * 'resource': for values with an explicit acquire\/release pair.+--   The finaliser is guaranteed to run even under exceptions.+--   Analogous to @ZLayer.scoped@ with @acquireRelease@.+-- * 'bracketed': for adapting existing @withFoo@-style bracket+--   functions from third-party libraries.+--+-- In all three cases, dependencies come from 'ask'+-- ('Control.Monad.Reader.Class.MonadReader'), not through the+-- primitive's function arguments. This keeps the creation API uniform+-- and lets you compose layers via 'Monad' @do@-notation.++-- $running+--+-- 'withLayer' is the primary entry point for production code. It+-- acquires every resource in the layer graph, passes the resulting+-- environment to your callback, and releases everything when the+-- callback returns or throws. Resources are released in reverse+-- acquisition order.+--+-- 'runLayer' is a simpler alternative for tests and REPL sessions. It+-- builds the layer, returns the output, and immediately releases all+-- resources. Any handles or connections in the output will be invalid+-- after 'runLayer' returns.++-- $services+--+-- Services solve the diamond-dependency problem: when two independent+-- layers both need the same expensive resource (a connection pool, a+-- thread manager), you want exactly one instance, not two.+--+-- Wrap any layer with 'mkService' to declare it as shared, then+-- consume it with 'service'. The first call initialises the service+-- and caches the result. Every subsequent call returns the cached+-- instance. Initialisation is thread-safe and failure is cached.+--+-- See the module introduction for a complete worked example.++-- $composition+--+-- Most of the time you compose layers via their typeclass instances+-- ('Category' for @>>>@, 'Arrow' for @&&&@/@***@, 'ArrowChoice' for+-- @+++@/@|||@, 'Alternative' for @\<|\>@). The functions below are the+-- named equivalents that implement those instances. They are exported+-- for cases where you need to pass them as first-class values or where+-- the operator syntax is ambiguous.+++getOrCreateCachedService :: forall m deps env. (MonadUnliftIO m, Typeable env) => Service m deps env -> Layer m deps env+getOrCreateCachedService (Service m) = Layer $ \lenv deps -> do+  let rep = typeRep (Proxy @env)+      serviceName = T.pack (show rep)++  -- Fast path: check without write lock+  snapshot <- liftIO $ readMVar lenv.serviceStates+  case lookupTypeMap @env snapshot of+    Just (Initialized x) -> do+      lift $ onServiceReuse (interceptor lenv) serviceName rep+      pure x+    Just (Failed e) -> throwIO e+    _ -> join $ modifyMVar lenv.serviceStates $ \currentStates -> do+      case lookupTypeMap @env currentStates of+        Just (Initialized x) -> do+          lift $ onServiceReuse (interceptor lenv) serviceName rep+          pure (currentStates, pure x)+        Just (Failed e) -> pure (currentStates, throwIO e)+        Nothing -> do+          let ctx = OperationContext+                { operationName = serviceName+                , operationType = Just rep+                , operationMetadata = []+                }+          lift $ onServiceCreate (interceptor lenv) ctx++          eRes <- try $ build m lenv deps+          case eRes of+            Left e -> do+              let states' = insertTypeMap @env (Failed e) currentStates+              pure (states', throwIO e)+            Right x -> do+              let states' = insertTypeMap @env (Initialized x) currentStates+              pure (states', pure x)++-------------------------------------------------------------------------------+-- Construction helpers+-------------------------------------------------------------------------------++-- | Acquire a resource and register its finaliser.+--+-- Use 'resource' when you have a matching acquire\/release pair.  The+-- release action runs when the enclosing 'withLayer' scope ends,+-- whether normally or via exception, so you never need to write+-- manual cleanup code.+--+-- __Database connection:__+--+-- @+-- dbLayer :: Layer IO Config Database+-- dbLayer = do+--   cfg <- ask+--   resource (connectDB cfg) closeDB+-- @+--+-- __Thread pool:__+--+-- @+-- workerPool :: Layer IO PoolConfig ThreadPool+-- workerPool = do+--   cfg <- ask+--   resource (newThreadPool cfg.numWorkers) shutdownPool+-- @+--+-- __File handle (release guaranteed even on exception):__+--+-- @+-- logFile :: Layer IO FilePath Handle+-- logFile = do+--   path <- ask+--   resource (openFile path AppendMode) hClose+-- @+--+-- The acquire action runs inside 'ResourceT', so any exception during+-- acquisition prevents the finaliser from being registered (there is+-- nothing to clean up). Once acquisition succeeds, the finaliser is+-- registered and will run no matter what happens later.+resource ::+  forall m deps env. (MonadUnliftIO m, Typeable env) =>+  -- | Acquire resource+  m env ->+  -- | Release resource+  (env -> m ()) ->+  Layer m deps env+resource acq rel = Layer $ \lenv _deps -> do+  let rep = typeRep (Proxy @env)+      ctx = OperationContext+        { operationName = T.pack (show rep)+        , operationType = Just rep+        , operationMetadata = []+        }+  lift $ onResourceAcquire (interceptor lenv) ctx+  startTime <- liftIO getCurrentTime++  (_, env) <- allocateU+    (lift acq)+    (\x -> do+      lift $ onResourceRelease (interceptor lenv) (operationName ctx)+      lift $ rel x)++  endTime <- liftIO getCurrentTime+  let duration = diffUTCTime endTime startTime+  lift $ onResourceAcquireComplete (interceptor lenv) (operationName ctx) duration++  pure env+{-# INLINABLE resource #-}++-- | Lift a monadic action into a layer.  No finaliser is registered,+-- so this is the right choice for values that can be garbage collected+-- normally: configuration, computed values, or one-shot effects whose+-- result doesn't hold on to external resources.+--+-- __Loading configuration:__+--+-- @+-- configLayer :: Layer IO () Config+-- configLayer = effect $+--   Config \<$\> readEnvVar \"PORT\"+--          \<*\> readEnvVar \"HOST\"+-- @+--+-- __Pure computation (no IO needed):__+--+-- @+-- seedLayer :: Layer IO () Seed+-- seedLayer = effect (pure (Seed 42))+-- @+--+-- __Reading a file at startup:__+--+-- @+-- templatesLayer :: Layer IO Config Templates+-- templatesLayer = do+--   cfg <- ask+--   effect $ loadTemplates cfg.templateDir+-- @+--+-- If the value you are producing holds on to an external resource+-- (a file handle, a socket, a connection), use 'resource' instead+-- so the resource is cleaned up automatically.+effect ::+  forall m deps env. (MonadUnliftIO m, Typeable env) =>+  -- | Run effect to produce environment+  m env ->+  Layer m deps env+effect f = Layer $ \lenv _deps -> do+  let rep = typeRep (Proxy @env)+      ctx = OperationContext+        { operationName = T.pack (show rep)+        , operationType = Just rep+        , operationMetadata = []+        }+  lift $ onEffectRun (interceptor lenv) ctx+  startTime <- liftIO getCurrentTime++  result <- lift f++  endTime <- liftIO getCurrentTime+  let duration = diffUTCTime endTime startTime+  lift $ onEffectComplete (interceptor lenv) (operationName ctx) duration++  pure result+{-# INLINABLE effect #-}++-- | Adapt a @with@-style bracket function into a layer.+--+-- Many Haskell libraries expose resource management in continuation-+-- passing style: @withFoo :: (Foo -> m a) -> m a@. The library+-- handles acquisition and cleanup internally, and you use the+-- resource within the continuation.+--+-- 'bracketed' captures the resource from this pattern and extends its+-- lifetime to match the enclosing 'withLayer' scope, so it+-- participates in the same cleanup guarantees as 'resource'.+--+-- __Connection pool from a library:__+--+-- @+-- poolLayer :: Layer IO () ConnectionPool+-- poolLayer = bracketed withConnectionPool+-- @+--+-- __TLS manager:__+--+-- @+-- tlsLayer :: Layer IO TlsConfig TlsManager+-- tlsLayer = do+--   cfg <- ask+--   bracketed (withTlsManager cfg)+-- @+--+-- __Network socket:__+--+-- @+-- socketLayer :: Layer IO SocketConfig Socket+-- socketLayer = do+--   cfg <- ask+--   bracketed (withBoundSocket cfg.host cfg.port)+-- @+--+-- Prefer 'resource' when you have separate acquire and release+-- functions; 'bracketed' is specifically for libraries that only+-- expose the @with@ pattern.+bracketed ::+  forall m deps env. MonadUnliftIO m =>+  (forall a. (env -> m a) -> m a) ->+  Layer m deps env+bracketed f = Layer $ \_ _deps -> do+  (resourceVar :: MVar (Either SomeException env)) <- newEmptyMVar+  cleanupVar <- newEmptyMVar+  void $ allocateU+    ( async do+      lift $ f (\env -> putMVar resourceVar (Right env) >> takeMVar cleanupVar)+        `catch` (\(e :: SomeException) -> putMVar resourceVar (Left e) >> throwIO e)+    )+    (\h -> do+      putMVar cleanupVar ()+      wait h+    )+  takeMVar resourceVar >>= either throwIO pure++-- | Wrap a layer so it can be shared via 'service'.+--+-- 'mkService' does not change the layer's behaviour. It simply tags+-- the layer so that 'service' knows to cache its result. Define your+-- service once at the top level, and reference it from every consumer:+--+-- @+-- poolService :: Service IO Config ConnectionPool+-- poolService = mkService $ do+--   cfg <- ask+--   resource (createPool cfg) drainPool+-- @+mkService :: Layer m deps env -> Service m deps env+mkService = Service++-- | Obtain a shared instance of a 'Service'.+--+-- The first call within a composition initialises the service and+-- caches the result, keyed by the output 'TypeRep'. Subsequent calls+-- return the cached instance. Initialisation is thread-safe:+-- concurrent requests block until the first completes.+--+-- __Two consumers sharing one pool:__+--+-- @+-- webLayer :: Layer IO Config WebServer+-- webLayer = do+--   pool <- service poolService  -- first call creates the pool+--   resource (startWeb pool) stopWeb+--+-- apiLayer :: Layer IO Config ApiServer+-- apiLayer = do+--   pool <- service poolService  -- reuses the same pool+--   resource (startApi pool) stopApi+--+-- app :: Layer IO Config (WebServer, ApiServer)+-- app = webLayer &&& apiLayer   -- one pool, two consumers+-- @+--+-- __Using a service in a sequential pipeline:__+--+-- @+-- appLayer :: Layer IO () App+-- appLayer = configLayer >>> do+--   pool <- service poolService+--   db   <- service dbService+--   effect $ pure (App pool db)+-- @+--+-- __Caveat__: caching is keyed by output type. Two @Service@ values+-- that produce the same type will share a cache entry. Use a newtype+-- wrapper if you need distinct instances of the same underlying type.+service :: forall m deps env. (MonadUnliftIO m, Typeable env) => Service m deps env -> Layer m deps env+service = getOrCreateCachedService++-------------------------------------------------------------------------------+-- Typeclass instances --------------------------------------------------------+-------------------------------------------------------------------------------++instance Functor m => Functor (Layer m deps) where+  fmap f (Layer l) = Layer $ \lenv deps -> fmap f (l lenv deps)++instance MonadUnliftIO m => Applicative (Layer m deps) where+  pure = pureLayer+  lf <*> la = dimap (\d -> (d, d)) (uncurry ($)) (zipLayer lf la)++instance MonadUnliftIO m => Selective (Layer m deps) where+  select = selectM++instance MonadUnliftIO m => Monad (Layer m deps) where+  return = pure+  (Layer l) >>= f = Layer $ \lenv deps -> do+    a <- l lenv deps+    let Layer l' = f a+    l' lenv deps++instance (MonadUnliftIO m, Semigroup env) => Semigroup (Layer m deps env) where+  lf <> la = liftA2 (<>) lf la+  sconcat (h :| t) = foldl (<>) h t+  stimes n x+    | n <= 0 = error "stimes: positive multiplier expected"+    | n == 1 = x+    | otherwise = x <> stimes (n - 1) x++instance (MonadUnliftIO m, Monoid env) => Monoid (Layer m deps env) where+  mempty = pure mempty+  mappend = (<>)+  mconcat = foldl (<>) mempty++-- | Contravariantly map over the input. Named form of 'lmap'.+--+-- Useful when a layer expects a different input type than you have,+-- and you can project from one to the other:+--+-- @+-- -- dbLayer needs Config, but we have AppEnv+-- dbFromAppEnv :: Layer IO AppEnv Database+-- dbFromAppEnv = mapLayer (.config) dbLayer+-- @+mapLayer :: (b -> a) -> Layer m a c -> Layer m b c+mapLayer f (Layer l) = Layer $ \lenv env -> l lenv (f env)++instance (MonadUnliftIO m) => MonadReader deps (Layer m deps) where+  ask = Layer $ \_ deps -> pure deps+  local f (Layer l) = Layer $ \lenv deps -> l lenv (f deps)++-- | Sequential (vertical) composition. Named form of @>>>@.+--+-- Feeds the output of the upstream layer as dependencies to the+-- downstream layer. This is how you express "build A, then use A to+-- build B":+--+-- @+-- -- using the operator:+-- appLayer = configLayer >>> dbLayer+--+-- -- equivalent named version:+-- appLayer = composeLayer configLayer dbLayer+-- @+composeLayer ::+  MonadUnliftIO m =>+  -- | "Upstream" layer+  Layer m a b ->+  -- | "Downstream" layer+  Layer m b c ->+  Layer m a c+composeLayer (Layer upper) (Layer lower) = Layer $ \lenv deps -> do+  lift $ onCompositionStart (interceptor lenv) Sequential+  startTime <- liftIO getCurrentTime+  b <- upper lenv deps+  c <- lower lenv b+  endTime <- liftIO getCurrentTime+  lift $ onCompositionEnd (interceptor lenv) Sequential (diffUTCTime endTime startTime)+  pure c++instance MonadUnliftIO m => Category (Layer m) where+  id = Layer $ \_ deps -> pure deps+  (.) = flip composeLayer++instance MonadUnliftIO m => Profunctor (Layer m) where+  dimap f g (Layer l) = Layer $ \lenv a -> fmap g (l lenv (f a))+  lmap  = mapLayer+  rmap = fmap++instance MonadUnliftIO m => Strong (Layer m) where+  first' :: Layer m a b -> Layer m (a, c) (b, c)+  first' (Layer l) = Layer $ \lenv (a, c) -> do+    b <- l lenv a+    pure (b, c)++  second' :: Layer m a b -> Layer m (c, a) (c, b)+  second' (Layer l) = Layer $ \lenv (c, a) -> do+    b <- l lenv a+    pure (c, b)++instance MonadUnliftIO m => Choice (Layer m) where+  left' :: Layer m a b -> Layer m (Either a c) (Either b c)+  left' (Layer l) = Layer $ \lenv -> \case+    Left a -> Left <$> l lenv a+    Right c -> pure (Right c)++  right' :: Layer m a b -> Layer m (Either c a) (Either c b)+  right' (Layer l) = Layer $ \lenv -> \case+    Right a -> Right <$> l lenv a+    Left c -> pure (Left c)++instance MonadUnliftIO m => Traversing (Layer m) where+  traverse' :: Traversable f => Layer m a b -> Layer m (f a) (f b)+  traverse' (Layer l) = Layer $ \lenv fa -> traverse (l lenv) fa++instance MonadUnliftIO m => Arrow (Layer m) where+  arr f = Layer $ \_ a -> pure (f a)+  first = first'+  second = second'++instance MonadUnliftIO m => ArrowChoice (Layer m) where+  left = left'+  right = right'++-------------------------------------------------------------------------------++-- | Thrown by 'empty' \/ 'zeroArrow'.  Caught internally by @\<|\>@ and+-- @\<+\>@ to implement fallback behavior. You should not need to catch+-- this yourself; it is an implementation detail of the 'Alternative'+-- instance.+data EmptyLayer = EmptyLayer+  deriving stock (Show)++instance Exception EmptyLayer++instance MonadUnliftIO m => Alternative (Layer m deps) where+  empty = Layer $ \_ _ -> throwIO EmptyLayer+  Layer l1 <|> Layer l2 = Layer $ \lenv deps ->+    tryWithCleanup (l1 lenv deps) (l2 lenv deps)++instance MonadUnliftIO m => MonadPlus (Layer m deps) where+  mzero = empty+  mplus = (<|>)++instance MonadUnliftIO m => ArrowZero (Layer m) where+  zeroArrow = Layer $ \_ _ -> throwIO EmptyLayer++instance MonadUnliftIO m => ArrowPlus (Layer m) where+  (Layer l1) <+> (Layer l2) = Layer $ \lenv deps ->+    tryWithCleanup (l1 lenv deps) (l2 lenv deps)++instance MonadUnliftIO m => ArrowApply (Layer m) where+  app = Layer $ \lenv (Layer l, b) -> l lenv b++tryWithCleanup :: MonadUnliftIO m => ResourceT m a -> ResourceT m a -> ResourceT m a+tryWithCleanup l r = mask $ \restore -> do+  tmpState <- liftIO createInternalState+  try (restore $ runInternalState (lift l) tmpState) >>= \case+    Left e -> do+      liftIO $ stateCleanupChecked (Just (e :: SomeException)) tmpState+      restore r+    Right result -> withInternalState $ \stateMain -> do+      tmpState' <- liftIO $ readIORef tmpState+      atomicModifyIORef' stateMain $ \state -> (unsafelyMergeReleaseMap state tmpState', ())+      pure result++-------------------------------------------------------------------------------+-- Composition+-------------------------------------------------------------------------------++-- | Parallel (horizontal) composition. Powers @&&&@ and @\<*\>@.+--+-- Both layers run concurrently via @async@ in isolated resource+-- scopes. On success, the scopes merge into the parent. On failure,+-- the surviving branch is cleaned up before the exception propagates.+--+-- This means @&&&@ is not just a convenience operator; it actually+-- reduces startup time by running independent layers in parallel.+--+-- @+-- -- named form:+-- fullSystem :: Layer IO Config (Database, WebServer)+-- fullSystem = zipLayer dbLayer webLayer+--+-- -- operator form (more common):+-- fullSystem :: Layer IO Config (Database, WebServer)+-- fullSystem = dbLayer &&& webLayer+-- @+--+-- If one branch throws, the other is cancelled and its resources are+-- released before the exception propagates to the caller.+zipLayer ::+  (MonadUnliftIO m) =>+  Layer m d1 o1 ->+  Layer m d2 o2 ->+  Layer m (d1, d2) (o1, o2)+zipLayer (Layer l1) (Layer l2) = Layer $ \lenv (d1, d2) -> do+  -- For concurrent execution, we need to:+  -- 1. Run each layer in isolation to prevent cross-contamination if one fails+  -- 2. Capture their resources and transfer to parent context if successful++  -- Create isolated states for each branch+  stateA <- liftIO createInternalState+  stateB <- liftIO createInternalState++  mask $ \restore -> do+    asyncA <- async $ restore $ runInternalState (lift $ l1 lenv d1) stateA+    asyncB <- async $ restore $ runInternalState (lift $ l2 lenv d2) stateB+    eRes <- try (restore (atomically $ (,) <$> waitCatchSTM asyncA <*> waitCatchSTM asyncB))+    stateA' <- liftIO $ readIORef stateA+    stateB' <- liftIO $ readIORef stateB+    case eRes of+      Left e -> do+        uninterruptibleCancel asyncA+        uninterruptibleCancel asyncB+        liftIO (stateCleanupChecked (Just e) stateA `finally` stateCleanupChecked (Just e) stateB)+        throwIO e+      Right res -> case res of+        (Left eA, Left eB) -> do+          liftIO (stateCleanupChecked (Just eA) stateA `finally` stateCleanupChecked (Just eB) stateB)+          throwIO eA+        (Left eA, Right _) -> do+          liftIO (stateCleanupChecked (Just eA) stateA `finally` stateCleanupChecked Nothing stateB)+          throwIO eA+        (Right _envA, Left eB) -> do+          liftIO (stateCleanupChecked (Just eB) stateB `finally` stateCleanupChecked Nothing stateA)+          throwIO eB+        (Right envA, Right envB) -> withInternalState $ \stateMain -> do+          let mergedStates = unsafelyMergeReleaseMap stateA' stateB'+          atomicModifyIORef' stateMain $ \state -> (unsafelyMergeReleaseMap state mergedStates, ())+          pure (envA, envB)++-- The first map is the one that is being merged into. Its refcount is not affected.+unsafelyMergeReleaseMap :: ReleaseMap -> ReleaseMap -> ReleaseMap+unsafelyMergeReleaseMap (ReleaseMap nextKey refCount stateA) (ReleaseMap nextKey' _ stateB) = ReleaseMap (nextKey + nextKey') refCount (stateA <> mapKeysMonotonic (+ nextKey) stateB)+unsafelyMergeReleaseMap l ReleaseMapClosed = l+unsafelyMergeReleaseMap ReleaseMapClosed r = r++-------------------------------------------------------------------------------+-- Running layers+-------------------------------------------------------------------------------++-- | Build a layer and return its output, releasing resources immediately.+--+-- This is useful in tests and REPL sessions where you want a quick+-- result without managing a callback scope:+--+-- @+-- -- in a test:+-- cfg <- runLayer () configLayer+-- cfg.port \`shouldBe\` 8080+--+-- -- in GHCi:+-- >>> runLayer () configLayer+-- Config {port = 8080, host = "localhost"}+-- @+--+-- __Warning__: any handles or connections in the output will be+-- invalid after this returns, because resources are released as+-- soon as the layer finishes building.  Use 'withLayer' for real+-- applications.+runLayer :: MonadUnliftIO m => deps -> Layer m deps env -> m env+runLayer deps (Layer l) = do+  lenv <- LayerEnv <$> newMVar emptyTypeMap <*> pure nullInterceptor+  runResourceT (l lenv deps)++-- | Build a layer, use its environment, and guarantee cleanup.+--+-- This is the primary way to run a layer in production code.+-- Resources are released in reverse acquisition order when the+-- callback returns or throws.+--+-- __Typical main:__+--+-- @+-- main :: IO ()+-- main = withLayer () appLayer $ \\(cfg, (db, ws)) ->+--   serveRequests ws+-- @+--+-- __Nested scopes:__+--+-- @+-- main :: IO ()+-- main = withLayer () configLayer $ \\cfg ->+--   withLayer cfg dbLayer $ \\db -> do+--     rows <- query db "SELECT 1"+--     print rows+-- @+--+-- Prefer the composed form (@configLayer >>> dbLayer@) over nesting+-- when possible, since it is both more concise and enables parallel+-- composition.+withLayer ::+  MonadUnliftIO m =>+  -- | Dependencies+  deps ->+  -- | Layer to run+  Layer m deps env ->+  -- | Action that needs the env+  (env -> m r) ->+  m r+withLayer deps (Layer l) useEnv = runResourceT $ do+  lenv <- LayerEnv <$> newMVar emptyTypeMap <*> pure nullInterceptor+  env <- l lenv deps+  lift $ useEnv env++-- | Like 'runLayer', but with a custom 'LayerInterceptor' for+-- observing construction events.+--+-- @+-- diags <- runLayerWithInterceptor loggingInterceptor () appLayer+-- @+runLayerWithInterceptor ::+  MonadUnliftIO m =>+  -- | Custom interceptor+  LayerInterceptor m ->+  -- | Dependencies+  deps ->+  -- | Layer to run+  Layer m deps env ->+  m env+runLayerWithInterceptor i deps (Layer l) = do+  lenv <- LayerEnv <$> newMVar emptyTypeMap <*> pure i+  runResourceT (l lenv deps)++-- | Like 'withLayer', but with a custom 'LayerInterceptor'.+--+-- @+-- main :: IO ()+-- main = withLayerAndInterceptor loggingInterceptor () appLayer $ \\env ->+--   runApp env+-- @+withLayerAndInterceptor ::+  MonadUnliftIO m =>+  -- | Custom interceptor+  LayerInterceptor m ->+  -- | Dependencies+  deps ->+  -- | Layer to run+  Layer m deps env ->+  -- | Action that needs the env+  (env -> m r) ->+  m r+withLayerAndInterceptor i deps (Layer l) useEnv = runResourceT $ do+  lenv <- LayerEnv <$> newMVar emptyTypeMap <*> pure i+  env <- l lenv deps+  lift $ useEnv env

@@ -0,0 +1,583 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module      : Fractal.Layer.Diagnostics+-- Description : Diagnostics and visualization for layer initialization+-- Stability   : experimental+-- Portability : Portable+--+-- This module provides tools for visualizing and debugging layer initialization.+-- It can track how layers are composed, which services are shared, and render+-- the dependency tree in various formats.+--+-- == Example Usage+--+-- @+-- appLayer :: Layer IO () (Config, Database, WebServer)+-- appLayer = configLayer >>> (dbLayer &&& webLayer)+--+-- main :: IO ()+-- main = withLayerDiagnostics appLayer () $ \(env, diags) -> do+--   -- Print ASCII tree+--   putStrLn $ renderLayerTree diags+--+--   -- Or export as JSON+--   BSL.writeFile "layer-tree.json" (encode diags)+--+--   -- Use the environment+--   let (cfg, db, ws) = env+--   serveRequests ws+-- @+module Fractal.Layer.Diagnostics+  ( -- * Diagnostics Types+    LayerDiagnostics (..),+    LayerNode (..),+    LayerNodeType (..),+    ResourceStatus (..),++    -- * Diagnostics Interceptor+    createDiagnosticsInterceptor,+    DiagnosticsCollector,+    newDiagnosticsCollector,+    finalizeDiagnostics,++    -- * Running with Diagnostics+    withLayerDiagnostics,+    buildLayerDiagnostics,++    -- * Rendering+    renderLayerTree,+    renderLayerTreeDetailed,++    -- * Snapshots+    snapshotDiagnostics,++    -- * JSON Export+    diagnosticsToJSON,+  )+where++import Control.Monad.IO.Class+import Data.Aeson (ToJSON (..), FromJSON (..), object, (.=), (.:), Value, withObject, withText)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Control.Concurrent.MVar+import Data.Text (Text)+import qualified Data.Text as T+import Data.Time.Clock (NominalDiffTime, getCurrentTime, diffUTCTime, UTCTime)+import Data.Typeable+import Fractal.Layer.Interceptor+import UnliftIO (MonadUnliftIO)++-- Import Layer types and functions (defined later in dependency order)+import Fractal.Layer (Layer, runLayerWithInterceptor, withLayerAndInterceptor)++-------------------------------------------------------------------------------+-- Types+-------------------------------------------------------------------------------++-- | Complete diagnostics for a layer initialization+data LayerDiagnostics = LayerDiagnostics+  { rootNode :: LayerNode+  -- ^ The root of the initialization tree+  , totalDuration :: Double+  -- ^ Total time taken to initialize (seconds)+  , totalResources :: Int+  -- ^ Total number of resources allocated+  , sharedResources :: Int+  -- ^ Number of resources that were shared/cached+  }+  deriving (Show)++-- | A node in the layer initialization tree+data LayerNode = LayerNode+  { nodeId :: Text+  -- ^ Unique identifier for this node+  , nodeName :: Text+  -- ^ Human-readable name (e.g., "DatabaseLayer", "ConfigService")+  , nodeType :: LayerNodeType+  -- ^ Type of layer node+  , resourceType :: Maybe TypeRep+  -- ^ The type of resource produced (if available)+  , status :: ResourceStatus+  -- ^ Status of this resource+  , duration :: Maybe Double+  -- ^ Time taken to initialize this layer (seconds)+  , children :: [LayerNode]+  -- ^ Child layers+  , metadata :: HashMap Text Text+  -- ^ Additional metadata+  }+  deriving (Show)++-- | The type of layer node+data LayerNodeType+  = ResourceNode+  -- ^ A resource that was allocated+  | EffectNode+  -- ^ An effect that was run+  | ServiceNode+  -- ^ A cached service+  | ComposedNode+  -- ^ A composed layer (>>> or &&&)+  | ParallelNode+  -- ^ Parallel composition (&&&)+  | SequentialNode+  -- ^ Sequential composition (>>>)+  deriving (Show, Eq)++-- | Status of a resource+data ResourceStatus+  = Initializing+  -- ^ Currently being initialized+  | Initialized+  -- ^ Successfully initialized+  | Failed String+  -- ^ Failed to initialize with error+  | SharedReference Text+  -- ^ Reference to a shared resource (with node ID)+  deriving (Show, Eq)++-------------------------------------------------------------------------------+-- JSON Instances+-------------------------------------------------------------------------------++instance ToJSON LayerDiagnostics where+  toJSON LayerDiagnostics{..} =+    object+      [ "root" .= rootNode+      , "totalDuration" .= totalDuration+      , "totalResources" .= totalResources+      , "sharedResources" .= sharedResources+      ]++instance ToJSON LayerNode where+  toJSON LayerNode{..} =+    object+      [ "id" .= nodeId+      , "name" .= nodeName+      , "type" .= nodeType+      , "resourceType" .= (show <$> resourceType)+      , "status" .= status+      , "duration" .= duration+      , "children" .= children+      , "metadata" .= metadata+      ]++instance ToJSON LayerNodeType where+  toJSON = \case+    ResourceNode -> "resource"+    EffectNode -> "effect"+    ServiceNode -> "service"+    ComposedNode -> "composed"+    ParallelNode -> "parallel"+    SequentialNode -> "sequential"++instance ToJSON ResourceStatus where+  toJSON = \case+    Initializing -> object ["status" .= ("initializing" :: Text)]+    Initialized -> object ["status" .= ("initialized" :: Text)]+    Failed err -> object ["status" .= ("failed" :: Text), "error" .= err]+    SharedReference nodeId -> object ["status" .= ("shared" :: Text), "reference" .= nodeId]++-- FromJSON instances for deserialization+instance FromJSON LayerDiagnostics where+  parseJSON = withObject "LayerDiagnostics" $ \v -> LayerDiagnostics+    <$> v .: "root"+    <*> v .: "totalDuration"+    <*> v .: "totalResources"+    <*> v .: "sharedResources"++instance FromJSON LayerNode where+  parseJSON = withObject "LayerNode" $ \v -> LayerNode+    <$> v .: "id"+    <*> v .: "name"+    <*> v .: "type"+    <*> pure Nothing  -- resourceType is serialized as String, skip for now+    <*> v .: "status"+    <*> v .: "duration"+    <*> v .: "children"+    <*> v .: "metadata"++instance FromJSON LayerNodeType where+  parseJSON = withText "LayerNodeType" $ \case+    "resource" -> pure ResourceNode+    "effect" -> pure EffectNode+    "service" -> pure ServiceNode+    "composed" -> pure ComposedNode+    "parallel" -> pure ParallelNode+    "sequential" -> pure SequentialNode+    _ -> fail "Unknown layer node type"++instance FromJSON ResourceStatus where+  parseJSON = withObject "ResourceStatus" $ \v -> do+    status <- v .: "status"+    case status :: Text of+      "initializing" -> pure Initializing+      "initialized" -> pure Initialized+      "failed" -> Failed <$> v .: "error"+      "shared" -> SharedReference <$> v .: "reference"+      _ -> fail "Unknown status"++-------------------------------------------------------------------------------+-- Diagnostics Collector (Interceptor-based)+-------------------------------------------------------------------------------++-- | Mutable state for collecting diagnostics during layer initialization+data DiagnosticsCollectorState = DiagnosticsCollectorState+  { collectorNodeStack :: ![LayerNode]+  -- ^ Stack of nodes being built (top = current)+  , collectorNextId :: !Int+  -- ^ Next available node ID+  , collectorStartTime :: !UTCTime+  -- ^ When collection started+  , collectorServiceMap :: !(HashMap TypeRep Text)+  -- ^ Map of service types to their node IDs (for tracking sharing)+  , collectorTotalResources :: !Int+  -- ^ Total number of resources allocated+  , collectorSharedResources :: !Int+  -- ^ Number of shared/reused resources+  }++-- | Opaque handle to a diagnostics collector+newtype DiagnosticsCollector = DiagnosticsCollector (MVar DiagnosticsCollectorState)++-- | Create a new diagnostics collector+newDiagnosticsCollector :: MonadIO m => m DiagnosticsCollector+newDiagnosticsCollector = liftIO $ do+  start <- getCurrentTime+  ref <- newMVar DiagnosticsCollectorState+    { collectorNodeStack = [rootNode]+    , collectorNextId = 1+    , collectorStartTime = start+    , collectorServiceMap = HashMap.empty+    , collectorTotalResources = 0+    , collectorSharedResources = 0+    }+  pure $ DiagnosticsCollector ref+  where+    rootNode = LayerNode+      { nodeId = "root"+      , nodeName = "Root"+      , nodeType = ComposedNode+      , resourceType = Nothing+      , status = Initializing+      , duration = Nothing+      , children = []+      , metadata = HashMap.empty+      }++-- | Finalize diagnostics and get the complete tree+finalizeDiagnostics :: MonadIO m => DiagnosticsCollector -> m LayerDiagnostics+finalizeDiagnostics (DiagnosticsCollector ref) = liftIO $ do+  state <- readMVar ref+  endTime <- getCurrentTime+  let totalDur = realToFrac (diffUTCTime endTime (collectorStartTime state))+      rootNode = case collectorNodeStack state of+        [] -> error "Diagnostics collector has empty stack"+        (node:_) -> node { status = Initialized, duration = Just totalDur }+  pure $ LayerDiagnostics+    { rootNode = rootNode+    , totalDuration = totalDur+    , totalResources = collectorTotalResources state+    , sharedResources = collectorSharedResources state+    }++-- | Create a LayerInterceptor that collects diagnostics+createDiagnosticsInterceptor :: MonadIO m => DiagnosticsCollector -> LayerInterceptor m+createDiagnosticsInterceptor collector = LayerInterceptor+  { onResourceAcquire = \ctx -> liftIO $+      diagStartNode collector ctx ResourceNode+  , onResourceAcquireComplete = \_ dur -> liftIO $+      diagEndNode collector dur Initialized+  , onResourceRelease = \_ -> pure ()+  , onEffectRun = \ctx -> liftIO $+      diagStartNode collector ctx EffectNode+  , onEffectComplete = \_ dur -> liftIO $+      diagEndNode collector dur Initialized+  , onServiceCreate = \ctx -> liftIO $ do+      diagStartNode collector ctx ServiceNode+      diagRegisterService collector ctx+  , onServiceReuse = \name tr -> liftIO $+      diagAddSharedRef collector name tr+  , onCompositionStart = \typ -> liftIO $ do+      let nt = case typ of+            Sequential -> SequentialNode+            Parallel -> ParallelNode+          ctx = OperationContext (T.pack (show typ)) Nothing []+      diagStartNode collector ctx nt+  , onCompositionEnd = \_ dur -> liftIO $+      diagEndNode collector dur Initialized+  }++diagStartNode :: DiagnosticsCollector -> OperationContext -> LayerNodeType -> IO ()+diagStartNode (DiagnosticsCollector ref) ctx nt =+  modifyMVar_ ref $ \state -> do+    let newNode = LayerNode+          { nodeId = T.pack ("node-" <> show (collectorNextId state))+          , nodeName = operationName ctx+          , nodeType = nt+          , resourceType = operationType ctx+          , status = Initializing+          , duration = Nothing+          , children = []+          , metadata = HashMap.fromList (operationMetadata ctx)+          }+    pure state+      { collectorNodeStack = newNode : collectorNodeStack state+      , collectorNextId = collectorNextId state + 1+      }++diagEndNode :: DiagnosticsCollector -> NominalDiffTime -> ResourceStatus -> IO ()+diagEndNode (DiagnosticsCollector ref) dur st =+  modifyMVar_ ref $ \state ->+    pure $ case collectorNodeStack state of+      [] -> state+      [root] ->+        state { collectorNodeStack =+            [root { status = st, duration = Just (realToFrac dur) }]+        }+      (current:parent:rest) ->+        let completed = current { status = st, duration = Just (realToFrac dur) }+        in state { collectorNodeStack =+            parent { children = children parent ++ [completed] } : rest+        }++diagRegisterService :: DiagnosticsCollector -> OperationContext -> IO ()+diagRegisterService (DiagnosticsCollector ref) ctx =+  modifyMVar_ ref $ \s -> pure $ case operationType ctx of+    Just tr -> s+      { collectorServiceMap = HashMap.insert tr (operationName ctx) (collectorServiceMap s)+      , collectorTotalResources = collectorTotalResources s + 1+      }+    Nothing -> s+      { collectorTotalResources = collectorTotalResources s + 1+      }++diagAddSharedRef :: DiagnosticsCollector -> Text -> TypeRep -> IO ()+diagAddSharedRef (DiagnosticsCollector ref) name tr =+  modifyMVar_ ref $ \state ->+    case HashMap.lookup tr (collectorServiceMap state) of+      Just originalNodeId -> do+        let sn = LayerNode+              { nodeId = T.pack ("shared-" <> show (collectorNextId state))+              , nodeName = name+              , nodeType = ServiceNode+              , resourceType = Just tr+              , status = SharedReference originalNodeId+              , duration = Nothing+              , children = []+              , metadata = HashMap.empty+              }+        pure $ case collectorNodeStack state of+          [] -> state+          (top:rest) ->+            state+              { collectorNodeStack = top { children = children top ++ [sn] } : rest+              , collectorNextId = collectorNextId state + 1+              , collectorSharedResources = collectorSharedResources state + 1+              }+      Nothing -> pure state++-------------------------------------------------------------------------------+-- Running with Diagnostics+-------------------------------------------------------------------------------++-- | Build a layer with diagnostics tracking and return only the diagnostics.+--+-- The environment is discarded and resources are released immediately.+-- Useful for inspecting layer structure without keeping resources alive.+-- Use 'withLayerDiagnostics' when you need both the environment and diagnostics.+buildLayerDiagnostics ::+  MonadUnliftIO m =>+  -- | Layer to build+  Layer m deps env ->+  -- | Dependencies+  deps ->+  m LayerDiagnostics+buildLayerDiagnostics layer deps = do+  collector <- newDiagnosticsCollector+  let interceptor = createDiagnosticsInterceptor collector+  _ <- runLayerWithInterceptor interceptor deps layer+  finalizeDiagnostics collector++-- | Run a layer with diagnostics enabled.+-- Returns both the environment and the diagnostics information.+--+-- This function runs the layer with diagnostics collection enabled, then provides+-- both the initialized environment and collected diagnostics to your continuation.+--+-- Example:+-- @+-- withLayerDiagnostics myLayer config $ \(env, diags) -> do+--   putStrLn $ renderLayerTree diags+--   -- Use the environment...+-- @+withLayerDiagnostics ::+  MonadUnliftIO m =>+  -- | Layer to run+  Layer m deps env ->+  -- | Dependencies+  deps ->+  -- | Action with environment and diagnostics+  ((env, LayerDiagnostics) -> m r) ->+  m r+withLayerDiagnostics layer deps action = do+  collector <- newDiagnosticsCollector+  let interceptor = createDiagnosticsInterceptor collector+  withLayerAndInterceptor interceptor deps layer $ \env -> do+    diags <- finalizeDiagnostics collector+    action (env, diags)++-------------------------------------------------------------------------------+-- Rendering to Terminal+-------------------------------------------------------------------------------++-- | Render the layer tree as ASCII art (compact version)+--+-- Example output:+-- @+-- Root+-- ├── ConfigLayer (0.05s)+-- └── ParallelComposition (0.3s)+--     ├── DatabaseLayer (0.2s)+--     │   └── ConnectionPool [SHARED: svc-001]+--     └── WebServerLayer (0.1s)+--         └── MetricsCollector [SHARED: svc-001]+-- @+renderLayerTree :: LayerDiagnostics -> String+renderLayerTree diags =+  unlines $+    [ "Layer Initialization Tree"+    , "═════════════════════════"+    , ""+    , "⧗ Duration: " ++ show (totalDuration diags) ++ "s"+    , "◆ Resources: " ++ show (totalResources diags)+    , "↻ Shared: " ++ show (sharedResources diags)+    , ""+    ] ++ renderNode "" True (rootNode diags)++-- | Detailed rendering with metadata+renderLayerTreeDetailed :: LayerDiagnostics -> String+renderLayerTreeDetailed diags =+  unlines $+    [ "Layer Initialization Tree (Detailed)"+    , "═════════════════════════════════════"+    , ""+    , "⧗ Duration: " ++ show (totalDuration diags) ++ "s"+    , "◆ Resources: " ++ show (totalResources diags)+    , "↻ Shared: " ++ show (sharedResources diags)+    , ""+    ] ++ renderNodeDetailed "" True (rootNode diags)++-- | Render a single node in the tree+renderNode :: String -> Bool -> LayerNode -> [String]+renderNode prefix isLast node =+  let connector = if isLast then "└── " else "├── "+      extension = if isLast then "    " else "│   "+      typeSymbol = nodeTypeSymbol (nodeType node)+      nodeInfo = typeSymbol ++ " " ++ T.unpack (nodeName node) ++ formatDuration (duration node) ++ formatStatus (status node)+      header = prefix ++ connector ++ nodeInfo+      childPrefix = prefix ++ extension+      childCount = length (children node)+      childLines = concat $ zipWith (\i child -> renderNode childPrefix (i == childCount - 1) child) [1..] (children node)+  in header : childLines++-- | Render a node with detailed metadata+renderNodeDetailed :: String -> Bool -> LayerNode -> [String]+renderNodeDetailed prefix isLast node =+  let connector = if isLast then "└── " else "├── "+      extension = if isLast then "    " else "│   "+      typeSymbol = nodeTypeSymbol (nodeType node)+      nodeInfo = typeSymbol ++ " " ++ T.unpack (nodeName node) ++ " [" ++ show (nodeType node) ++ "]"+      header = prefix ++ connector ++ nodeInfo+      childPrefix = prefix ++ extension++      -- Add metadata lines+      metaLines = if HashMap.null (metadata node)+        then []+        else map (\(k, v) -> childPrefix ++ "  ▸ " ++ T.unpack k ++ ": " ++ T.unpack v) (HashMap.toList $ metadata node)++      -- Add type info if available+      typeLines = case resourceType node of+        Nothing -> []+        Just tr -> [childPrefix ++ "  ▸ Type: " ++ show tr]++      -- Add duration+      durationLines = case duration node of+        Nothing -> []+        Just d -> [childPrefix ++ "  ⧗ " ++ show d ++ "s"]++      -- Add status+      statusLines = [childPrefix ++ "  " ++ formatStatusDetailed (status node)]++      detailLines = typeLines ++ durationLines ++ statusLines ++ metaLines++      childCount = length (children node)+      childLines = concat $ zipWith (\i child -> renderNodeDetailed childPrefix (i == childCount - 1) child) [1..] (children node)+  in (header : detailLines) ++ childLines++-- | Symbol for each node type+nodeTypeSymbol :: LayerNodeType -> String+nodeTypeSymbol ResourceNode = "◆"+nodeTypeSymbol EffectNode = "⚡"+nodeTypeSymbol ServiceNode = "◉"+nodeTypeSymbol ComposedNode = "⊕"+nodeTypeSymbol ParallelNode = "⋈"+nodeTypeSymbol SequentialNode = "⇒"++formatDuration :: Maybe Double -> String+formatDuration Nothing = ""+formatDuration (Just d) = " ⧗" ++ show d ++ "s"++formatStatus :: ResourceStatus -> String+formatStatus Initializing = " ⟳"+formatStatus Initialized = " ✓"+formatStatus (Failed err) = " ✗ [" ++ err ++ "]"+formatStatus (SharedReference refId) = " ↻ " ++ T.unpack refId++formatStatusDetailed :: ResourceStatus -> String+formatStatusDetailed Initializing = "⟳ Initializing"+formatStatusDetailed Initialized = "✓ Initialized"+formatStatusDetailed (Failed err) = "✗ Failed - " ++ err+formatStatusDetailed (SharedReference refId) = "↻ Shared reference to " ++ T.unpack refId++-- | Get a snapshot of current diagnostics without finalizing+--+-- This is useful for live rendering while initialization is still in progress.+-- Unlike 'finalizeDiagnostics', this doesn't mark the collector as finished.+snapshotDiagnostics :: MonadIO m => DiagnosticsCollector -> m LayerDiagnostics+snapshotDiagnostics (DiagnosticsCollector ref) = liftIO $ do+  state <- readMVar ref+  endTime <- getCurrentTime+  let totalDur = realToFrac (diffUTCTime endTime (collectorStartTime state))+      root = case collectorNodeStack state of+        [] -> LayerNode+          { nodeId = "empty"+          , nodeName = "Empty"+          , nodeType = ComposedNode+          , resourceType = Nothing+          , status = Initialized+          , duration = Nothing+          , children = []+          , metadata = HashMap.empty+          }+        (n:_) -> n+  pure LayerDiagnostics+    { rootNode = root+    , totalDuration = totalDur+    , totalResources = collectorTotalResources state+    , sharedResources = collectorSharedResources state+    }++-------------------------------------------------------------------------------+-- JSON Export+-------------------------------------------------------------------------------++-- | Convert diagnostics to a JSON Value+diagnosticsToJSON :: LayerDiagnostics -> Value+diagnosticsToJSON = toJSON+

@@ -0,0 +1,162 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module      : Fractal.Layer.Interceptor+-- Description : Observable hooks for layer construction events+-- Stability   : experimental+--+-- Every 'Fractal.Layer.Layer' fires lifecycle callbacks as it acquires+-- resources, runs effects, creates services, and composes sub-layers.+-- A 'LayerInterceptor' is a record of those callbacks. Plug in your+-- own to add logging, metrics, tracing, or diagnostics without+-- modifying layer code.+--+-- The default 'nullInterceptor' is a no-op with zero overhead.+-- Combine multiple interceptors with 'combineInterceptors'.+--+-- == Example: simple logging+--+-- @+-- loggingInterceptor :: LayerInterceptor IO+-- loggingInterceptor = nullInterceptor+--   { onResourceAcquire = \\ctx ->+--       putStrLn $ \"Acquiring: \" <> show (operationName ctx)+--   , onResourceRelease = \\name ->+--       putStrLn $ \"Released: \" <> show name+--   }+-- @+module Fractal.Layer.Interceptor+  ( -- * Core Interface+    LayerInterceptor (..),+    CompositionType (..),+    OperationContext (..),++    -- * Built-in Interceptors+    nullInterceptor,+    combineInterceptors,++    -- * Helper Functions+    simpleContext,+    withType,+    withMetadata,+  )+where++import Data.Text (Text)+import Data.Time.Clock (NominalDiffTime)+import Data.Typeable (TypeRep)++-------------------------------------------------------------------------------+-- Types+-------------------------------------------------------------------------------++-- | Type of layer composition+data CompositionType+  = Sequential+  -- ^ Sequential composition (>>>)+  | Parallel+  -- ^ Parallel composition (&&&)+  deriving (Show, Eq)++-- | Context information about an operation+data OperationContext = OperationContext+  { operationName :: !Text+  -- ^ Human-readable name of the operation+  , operationType :: !(Maybe TypeRep)+  -- ^ Type representation if available+  , operationMetadata :: ![(Text, Text)]+  -- ^ Additional metadata as key-value pairs+  }+  deriving (Show)++-- | Callbacks fired at each stage of layer construction.+--+-- Override individual fields from 'nullInterceptor' to observe only+-- the events you care about.  Lifecycle for a 'Fractal.Layer.resource'+-- layer:+--+-- @+-- onResourceAcquire  →  (acquire action)  →  onResourceAcquireComplete+--    ⋮                                            ⋮+--    ⋮   ... layer is used ...                    ⋮+--    ⋮                                            ⋮+-- onResourceRelease  ←  (release action runs during cleanup)+-- @+data LayerInterceptor m = LayerInterceptor+  { onResourceAcquire :: OperationContext -> m ()+  -- ^ Called before acquiring a resource+  , onResourceAcquireComplete :: Text -> NominalDiffTime -> m ()+  -- ^ Called after a resource is successfully acquired (with operation name and duration)+  , onResourceRelease :: Text -> m ()+  -- ^ Called when a resource finalizer actually runs during cleanup+  , onEffectRun :: OperationContext -> m ()+  -- ^ Called before running an effect+  , onEffectComplete :: Text -> NominalDiffTime -> m ()+  -- ^ Called after an effect completes+  , onServiceCreate :: OperationContext -> m ()+  -- ^ Called when creating a new service+  , onServiceReuse :: Text -> TypeRep -> m ()+  -- ^ Called when reusing a cached service+  , onCompositionStart :: CompositionType -> m ()+  -- ^ Called when starting a composition+  , onCompositionEnd :: CompositionType -> NominalDiffTime -> m ()+  -- ^ Called when completing a composition+  }++-------------------------------------------------------------------------------+-- Built-in Interceptors+-------------------------------------------------------------------------------++-- | All-no-op interceptor.  This is the default when no interceptor is+-- specified; all callbacks immediately return @pure ()@.+nullInterceptor :: Applicative m => LayerInterceptor m+nullInterceptor =+  LayerInterceptor+    { onResourceAcquire = \_ -> pure ()+    , onResourceAcquireComplete = \_ _ -> pure ()+    , onResourceRelease = \_ -> pure ()+    , onEffectRun = \_ -> pure ()+    , onEffectComplete = \_ _ -> pure ()+    , onServiceCreate = \_ -> pure ()+    , onServiceReuse = \_ _ -> pure ()+    , onCompositionStart = \_ -> pure ()+    , onCompositionEnd = \_ _ -> pure ()+    }++-- | Fan out each event to every interceptor in order.+-- If a callback throws, later interceptors for that event are skipped.+combineInterceptors :: Monad m => [LayerInterceptor m] -> LayerInterceptor m+combineInterceptors interceptors =+  LayerInterceptor+    { onResourceAcquire = \ctx -> mapM_ (\i -> onResourceAcquire i ctx) interceptors+    , onResourceAcquireComplete = \name dur -> mapM_ (\i -> onResourceAcquireComplete i name dur) interceptors+    , onResourceRelease = \name -> mapM_ (\i -> onResourceRelease i name) interceptors+    , onEffectRun = \ctx -> mapM_ (\i -> onEffectRun i ctx) interceptors+    , onEffectComplete = \name dur -> mapM_ (\i -> onEffectComplete i name dur) interceptors+    , onServiceCreate = \ctx -> mapM_ (\i -> onServiceCreate i ctx) interceptors+    , onServiceReuse = \name tr -> mapM_ (\i -> onServiceReuse i name tr) interceptors+    , onCompositionStart = \typ -> mapM_ (\i -> onCompositionStart i typ) interceptors+    , onCompositionEnd = \typ dur -> mapM_ (\i -> onCompositionEnd i typ dur) interceptors+    }++-------------------------------------------------------------------------------+-- Helper Functions+-------------------------------------------------------------------------------++-- | Create a simple operation context with just a name+simpleContext :: Text -> OperationContext+simpleContext name =+  OperationContext+    { operationName = name+    , operationType = Nothing+    , operationMetadata = []+    }++-- | Add type information to a context+withType :: TypeRep -> OperationContext -> OperationContext+withType tr ctx = ctx {operationType = Just tr}++-- | Add metadata to a context+withMetadata :: [(Text, Text)] -> OperationContext -> OperationContext+withMetadata meta ctx = ctx {operationMetadata = operationMetadata ctx ++ meta}

@@ -0,0 +1,168 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- Module      : Fractal.Layer.Internal+-- Description : Internal implementation details for Fractal.Layer+-- Stability   : unstable+--+-- This module exposes the full internals of 'Layer', including the+-- @Layer@ constructor and @build@ record field. Import this only if+-- you are extending the library itself or building custom runners.+-- The API here may change between minor versions without notice.+--+-- For normal usage, import "Fractal.Layer" instead.+module Fractal.Layer.Internal+  ( -- * Core types+    Layer (..),+    LayerEnv (..),+    Service (..),++    -- * Type-safe map keyed by types+    TypeMap,+    DynF,+    emptyTypeMap,+    lookupTypeMap,+    insertTypeMap,++    -- * Service state+    ServiceState (..),++    -- * Low-level construction+    pureLayer,+    unsafeMkLayer,+  )+where++import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Typeable+import qualified Type.Reflection as TR+import Control.Monad.Trans.Resource (ResourceT)+import Fractal.Layer.Interceptor (LayerInterceptor)+import UnliftIO (MVar, SomeException)++-------------------------------------------------------------------------------+-- Type-safe map keyed by types+--+-- Uses SomeTypeRep's Ord instance (fingerprint comparison) for O(log n)+-- lookups. Existential GADT witness eliminates unsafeCoerce.+-------------------------------------------------------------------------------++data DynF f where+  MkDynF :: !(TR.TypeRep a) -> f a -> DynF f++newtype TypeMap f = TypeMap (Map TR.SomeTypeRep (DynF f))++instance Semigroup (TypeMap f) where+  TypeMap a <> TypeMap b = TypeMap (a <> b)++instance Monoid (TypeMap f) where+  mempty = TypeMap Map.empty++emptyTypeMap :: TypeMap f+emptyTypeMap = TypeMap Map.empty++lookupTypeMap :: forall a f. Typeable a => TypeMap f -> Maybe (f a)+lookupTypeMap (TypeMap m) = do+  MkDynF rep v <- Map.lookup (TR.SomeTypeRep (TR.typeRep @a)) m+  TR.HRefl <- TR.eqTypeRep (TR.typeRep @a) rep+  pure v++insertTypeMap :: forall a f. Typeable a => f a -> TypeMap f -> TypeMap f+insertTypeMap v (TypeMap m) =+  TypeMap (Map.insert (TR.SomeTypeRep (TR.typeRep @a)) (MkDynF (TR.typeRep @a) v) m)++-------------------------------------------------------------------------------+-- Service state+-------------------------------------------------------------------------------++data ServiceState a+  = Initialized a+  | Failed SomeException++-------------------------------------------------------------------------------+-- Layer environment+-------------------------------------------------------------------------------++-- | Internal environment threaded through layer construction.+-- Carries the service cache and the active interceptor.+data LayerEnv m = LayerEnv+  { serviceStates :: !(MVar (TypeMap ServiceState))+  -- MVar rather than IORef because zipLayer runs sub-layers+  -- concurrently via async.  Two parallel layers calling `service`+  -- on the same Service must serialise the check-then-initialise+  -- sequence so only one thread performs initialisation and the+  -- other blocks until it completes.+  , interceptor :: !(LayerInterceptor m)+  }++-------------------------------------------------------------------------------+-- Layer+-------------------------------------------------------------------------------++-- | A recipe for producing an @env@ from @deps@, with managed+-- resource lifetimes.+--+-- Conceptually, @Layer m deps env ≈ deps -> m env@, but with+-- automatic resource tracking: every resource acquired during+-- construction is released when the layer's scope ends.+--+-- The @deps@ parameter makes dependencies explicit in the type. You+-- can inspect a layer's signature and know exactly what it needs+-- without reading the implementation. The compiler enforces that the+-- wiring is correct at every composition site.+--+-- @Layer@ implements many standard typeclasses, giving you a rich+-- vocabulary for composition:+--+-- * 'Monad': sequential resource threading via @do@-notation.+-- * 'Category': sequential composition via @>>>@.+-- * 'Arrow': parallel composition via @&&&@ and @***@.+-- * 'ArrowChoice': branching via @+++@ and @|||@.+-- * 'Profunctor': contramap inputs with 'lmap', map outputs with 'fmap'.+-- * 'Alternative': fallback with resource cleanup via @\<|\>@.+--+-- Construct layers with 'effect', 'resource', or 'bracketed'.+-- Run them with 'withLayer' or 'runLayer'.+newtype Layer m deps env = Layer+  { build :: LayerEnv m -> deps -> ResourceT m env+  -- ^ Build the layer inside 'ResourceT', acquiring any required+  --   resources and registering their corresponding finalizers.+  }++-------------------------------------------------------------------------------+-- Service+-------------------------------------------------------------------------------++-- | A layer tagged for singleton caching.  Create with 'mkService',+-- consume with 'service'.  The 'uncached' accessor retrieves the+-- original layer without caching behaviour.+newtype Service m deps env = Service+  { uncached :: Layer m deps env+  -- ^ The underlying layer, without caching.+  }++-------------------------------------------------------------------------------+-- Low-level construction+-------------------------------------------------------------------------------++-- | Construct a pure layer from a plain value. No effects, no cleanup.+--+-- Primarily used to implement 'pure' for the 'Applicative' instance.+-- In application code, 'effect' with a pure action is usually clearer:+--+-- @+-- -- these are equivalent:+-- pureLayer defaultConfig+-- effect (pure defaultConfig)+-- @+pureLayer :: Applicative m => env -> Layer m deps env+pureLayer env = Layer $ \_ -> const (pure env)++-- | Lowest-level smart constructor for effectful layers. Bypasses the+-- interceptor machinery, so operations built this way are invisible to+-- diagnostics and tracing. Prefer 'effect' or 'resource' when possible.+unsafeMkLayer :: (deps -> ResourceT m env) -> Layer m deps env+unsafeMkLayer f = Layer $ \_ -> f

@@ -0,0 +1,962 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Fractal.Layer.DiagnosticsSpec (spec) where++import Control.Category ((>>>))+import Control.Monad (void)+import Control.Monad.Reader.Class (ask)+import Data.Aeson (encode, decode, toJSON, toEncoding)+import Data.Aeson.Encoding (encodingToLazyByteString)+import qualified Data.ByteString.Lazy as BSL+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Text as T+import Data.Typeable (Proxy(..), typeRep)+import Fractal.Layer+import Fractal.Layer.Diagnostics+import Fractal.Layer.Interceptor+import Test.Hspec+import UnliftIO+import Prelude hiding ((.), id)++-- Test data types+newtype Config = Config { configPort :: Int }+  deriving (Show, Eq)++newtype Database = Database { dbConnection :: String }+  deriving (Show, Eq)++newtype WebServer = WebServer { serverPort :: Int }+  deriving (Show, Eq)++newtype CacheService = CacheService { cacheSize :: Int }+  deriving (Show, Eq)++spec :: Spec+spec = do+  describe "LayerInterceptor" $ do+    it "nullInterceptor has no effect" $ do+      ref <- newIORef ([] :: [String])+      let layer = effect @IO @() @Config $ do+            modifyIORef ref (++ ["effect"])+            pure (Config 8080)+      result <- runLayer () layer+      configPort result `shouldBe` 8080+      logs <- readIORef ref+      logs `shouldBe` ["effect"]++    it "custom interceptor captures operations" $ do+      ref <- newIORef ([] :: [String])+      let customInterceptor = LayerInterceptor+            { onResourceAcquire = \ctx -> liftIO $ modifyIORef ref (++ ["resource-acquire:" <> T.unpack (operationName ctx)])+            , onResourceAcquireComplete = \name _ -> liftIO $ modifyIORef ref (++ ["resource-acquire-complete:" <> T.unpack name])+            , onResourceRelease = \name -> liftIO $ modifyIORef ref (++ ["resource-release:" <> T.unpack name])+            , onEffectRun = \ctx -> liftIO $ modifyIORef ref (++ ["effect-run:" <> T.unpack (operationName ctx)])+            , onEffectComplete = \name _ -> liftIO $ modifyIORef ref (++ ["effect-complete:" <> T.unpack name])+            , onServiceCreate = \ctx -> liftIO $ modifyIORef ref (++ ["service-create:" <> T.unpack (operationName ctx)])+            , onServiceReuse = \name _ -> liftIO $ modifyIORef ref (++ ["service-reuse:" <> T.unpack name])+            , onCompositionStart = \_ -> liftIO $ modifyIORef ref (++ ["composition-start"])+            , onCompositionEnd = \_ _ -> liftIO $ modifyIORef ref (++ ["composition-end"])+            }++      let layer = effect @IO @() @Config $ pure (Config 8080)+      void $ runLayerWithInterceptor customInterceptor () layer++      logs <- readIORef ref+      logs `shouldContain` ["effect-run:Config"]+      logs `shouldContain` ["effect-complete:Config"]++    it "combines multiple interceptors" $ do+      ref1 <- newIORef ([] :: [String])+      ref2 <- newIORef ([] :: [String])++      let interceptor1 = LayerInterceptor+            { onResourceAcquire = \_ -> liftIO $ modifyIORef ref1 (++ ["i1-resource"])+            , onResourceAcquireComplete = \_ _ -> pure ()+            , onResourceRelease = \_ -> liftIO $ modifyIORef ref1 (++ ["i1-release"])+            , onEffectRun = \_ -> liftIO $ modifyIORef ref1 (++ ["i1-effect"])+            , onEffectComplete = \_ _ -> pure ()+            , onServiceCreate = \_ -> pure ()+            , onServiceReuse = \_ _ -> pure ()+            , onCompositionStart = \_ -> pure ()+            , onCompositionEnd = \_ _ -> pure ()+            }++      let interceptor2 = LayerInterceptor+            { onResourceAcquire = \_ -> liftIO $ modifyIORef ref2 (++ ["i2-resource"])+            , onResourceAcquireComplete = \_ _ -> pure ()+            , onResourceRelease = \_ -> liftIO $ modifyIORef ref2 (++ ["i2-release"])+            , onEffectRun = \_ -> liftIO $ modifyIORef ref2 (++ ["i2-effect"])+            , onEffectComplete = \_ _ -> pure ()+            , onServiceCreate = \_ -> pure ()+            , onServiceReuse = \_ _ -> pure ()+            , onCompositionStart = \_ -> pure ()+            , onCompositionEnd = \_ _ -> pure ()+            }++      let combined = combineInterceptors [interceptor1, interceptor2]+      let layer = effect @IO @() @Config $ pure (Config 8080)+      void $ runLayerWithInterceptor combined () layer++      logs1 <- readIORef ref1+      logs2 <- readIORef ref2+      logs1 `shouldContain` ["i1-effect"]+      logs2 `shouldContain` ["i2-effect"]++  describe "Diagnostics Collection" $ do+    it "collects effect operations" $ do+      collector <- newDiagnosticsCollector+      let interceptor = createDiagnosticsInterceptor collector++      let layer = effect @IO @() @Config $ pure (Config 8080)+      result <- runLayerWithInterceptor interceptor () layer++      configPort result `shouldBe` 8080++      diags <- finalizeDiagnostics collector+      totalResources diags `shouldBe` 0+      length (children $ rootNode diags) `shouldSatisfy` (>= 0)++    it "collects resource operations" $ do+      collector <- newDiagnosticsCollector+      let interceptor = createDiagnosticsInterceptor collector++      let layer = resource @IO @() @Database+            (pure $ Database "connected")+            (\_ -> pure ())+      result <- runLayerWithInterceptor interceptor () layer++      dbConnection result `shouldBe` "connected"++      diags <- finalizeDiagnostics collector+      let root = rootNode diags+      nodeName root `shouldBe` "Root"++    it "tracks service creation and reuse" $ do+      collector <- newDiagnosticsCollector+      let interceptor = createDiagnosticsInterceptor collector++      let cacheLayer = effect @IO @() @CacheService $ pure (CacheService 100)+      let cacheService = mkService cacheLayer++      let useServiceTwice = do+            cache1 <- service cacheService+            cache2 <- service cacheService+            pure (cache1, cache2)++      (cache1, cache2) <- runLayerWithInterceptor interceptor () useServiceTwice++      cacheSize cache1 `shouldBe` 100+      cacheSize cache2 `shouldBe` 100++      diags <- finalizeDiagnostics collector+      totalResources diags `shouldSatisfy` (>= 1)+      sharedResources diags `shouldSatisfy` (>= 1)++    it "tracks multiple resources" $ do+      collector <- newDiagnosticsCollector+      let interceptor = createDiagnosticsInterceptor collector++      let layer = do+            _ <- resource @IO @() @Config (pure (Config 1)) (\_ -> pure ())+            _ <- resource @IO @() @Database (pure (Database "db")) (\_ -> pure ())+            _ <- resource @IO @() @WebServer (pure (WebServer 80)) (\_ -> pure ())+            pure ()++      void $ runLayerWithInterceptor interceptor () layer++      diags <- finalizeDiagnostics collector+      let root = rootNode diags+      length (children root) `shouldSatisfy` (>= 3)++  describe "Diagnostics Rendering" $ do+    it "renders a tree structure" $ do+      collector <- newDiagnosticsCollector+      let interceptor = createDiagnosticsInterceptor collector++      let layer = effect @IO @() @Config $ pure (Config 8080)+      void $ runLayerWithInterceptor interceptor () layer++      diags <- finalizeDiagnostics collector+      let rendered = renderLayerTree diags+      rendered `shouldContain` "Layer Initialization Tree"+      rendered `shouldContain` "Duration:"++    it "renders detailed tree with metadata" $ do+      collector <- newDiagnosticsCollector+      let interceptor = createDiagnosticsInterceptor collector++      let layer = effect @IO @() @Config $ pure (Config 8080)+      void $ runLayerWithInterceptor interceptor () layer++      diags <- finalizeDiagnostics collector+      let rendered = renderLayerTreeDetailed diags+      rendered `shouldContain` "Layer Initialization Tree (Detailed)"+      rendered `shouldContain` "Initialized"++    it "renders tree with children" $ do+      collector <- newDiagnosticsCollector+      let interceptor = createDiagnosticsInterceptor collector++      let layer = do+            _ <- resource @IO @() @Config (pure (Config 1)) (\_ -> pure ())+            _ <- effect @IO @() @Database $ pure (Database "db")+            pure ()++      void $ runLayerWithInterceptor interceptor () layer++      diags <- finalizeDiagnostics collector+      let rendered = renderLayerTree diags+      rendered `shouldContain` "Root"++    it "detailed rendering includes type information" $ do+      collector <- newDiagnosticsCollector+      let interceptor = createDiagnosticsInterceptor collector++      let svc = mkService $ resource @IO @() @Config (pure (Config 1)) (\_ -> pure ())+      let layer = do+            _ <- service svc+            _ <- service svc+            pure ()++      void $ runLayerWithInterceptor interceptor () layer++      diags <- finalizeDiagnostics collector+      let rendered = renderLayerTreeDetailed diags+      rendered `shouldContain` "Detailed"+      totalResources diags `shouldSatisfy` (>= 1)+      sharedResources diags `shouldSatisfy` (>= 1)++    it "exports to JSON" $ do+      collector <- newDiagnosticsCollector+      let interceptor = createDiagnosticsInterceptor collector++      let layer = effect @IO @() @Config $ pure (Config 8080)+      void $ runLayerWithInterceptor interceptor () layer++      diags <- finalizeDiagnostics collector+      let json = encode diags+      BSL.length json `shouldSatisfy` (> 0)++      let decoded = decode json :: Maybe LayerDiagnostics+      case decoded of+        Nothing -> expectationFailure "Failed to decode diagnostics JSON"+        Just diags' -> do+          totalDuration diags' `shouldBe` totalDuration diags+          totalResources diags' `shouldBe` totalResources diags++    it "diagnosticsToJSON produces valid JSON" $ do+      collector <- newDiagnosticsCollector+      let interceptor = createDiagnosticsInterceptor collector++      let layer = effect @IO @() @Int $ pure 42+      _ <- runLayerWithInterceptor interceptor () layer++      diags <- finalizeDiagnostics collector+      let json = diagnosticsToJSON diags+      let encoded = encode json+      BSL.length encoded `shouldSatisfy` (> 0)++  describe "LayerNodeType JSON roundtrip" $ do+    it "ResourceNode roundtrips" $ do+      let encoded = encode ResourceNode+      decode encoded `shouldBe` Just ResourceNode++    it "EffectNode roundtrips" $ do+      let encoded = encode EffectNode+      decode encoded `shouldBe` Just EffectNode++    it "ServiceNode roundtrips" $ do+      let encoded = encode ServiceNode+      decode encoded `shouldBe` Just ServiceNode++    it "ComposedNode roundtrips" $ do+      let encoded = encode ComposedNode+      decode encoded `shouldBe` Just ComposedNode++    it "ParallelNode roundtrips" $ do+      let encoded = encode ParallelNode+      decode encoded `shouldBe` Just ParallelNode++    it "SequentialNode roundtrips" $ do+      let encoded = encode SequentialNode+      decode encoded `shouldBe` Just SequentialNode++    it "unknown node type fails" $ do+      let decoded = decode "\"unknown\"" :: Maybe LayerNodeType+      decoded `shouldBe` Nothing++  describe "LayerNodeType equality" $ do+    it "same types are equal" $ do+      ResourceNode `shouldBe` ResourceNode+      EffectNode `shouldBe` EffectNode+      ServiceNode `shouldBe` ServiceNode+      ComposedNode `shouldBe` ComposedNode+      ParallelNode `shouldBe` ParallelNode+      SequentialNode `shouldBe` SequentialNode++    it "different types are not equal" $ do+      ResourceNode `shouldNotBe` EffectNode+      EffectNode `shouldNotBe` ServiceNode+      ComposedNode `shouldNotBe` ParallelNode++  describe "LayerNodeType show" $ do+    it "shows all types" $ do+      show ResourceNode `shouldBe` "ResourceNode"+      show EffectNode `shouldBe` "EffectNode"+      show ServiceNode `shouldBe` "ServiceNode"+      show ComposedNode `shouldBe` "ComposedNode"+      show ParallelNode `shouldBe` "ParallelNode"+      show SequentialNode `shouldBe` "SequentialNode"++  describe "ResourceStatus JSON roundtrip" $ do+    it "Initializing roundtrips" $ do+      let encoded = encode Initializing+      decode encoded `shouldBe` Just Initializing++    it "Initialized roundtrips" $ do+      let encoded = encode Initialized+      decode encoded `shouldBe` Just Initialized++    it "Failed roundtrips" $ do+      let encoded = encode (Failed "some error")+      decode encoded `shouldBe` Just (Failed "some error")++    it "SharedReference roundtrips" $ do+      let encoded = encode (SharedReference "node-42")+      decode encoded `shouldBe` Just (SharedReference "node-42")++    it "unknown status fails" $ do+      let decoded = decode "{\"status\":\"bogus\"}" :: Maybe ResourceStatus+      decoded `shouldBe` Nothing++  describe "ResourceStatus equality" $ do+    it "same statuses are equal" $ do+      Initializing `shouldBe` Initializing+      Initialized `shouldBe` Initialized+      Failed "x" `shouldBe` Failed "x"+      SharedReference "a" `shouldBe` SharedReference "a"++    it "different statuses are not equal" $ do+      Initializing `shouldNotBe` Initialized+      Failed "x" `shouldNotBe` Failed "y"+      SharedReference "a" `shouldNotBe` SharedReference "b"++  describe "ResourceStatus show" $ do+    it "shows all variants" $ do+      show Initializing `shouldContain` "Initializing"+      show Initialized `shouldContain` "Initialized"+      show (Failed "err") `shouldContain` "err"+      show (SharedReference "ref") `shouldContain` "ref"++  describe "LayerDiagnostics show" $ do+    it "shows the diagnostics" $ do+      collector <- newDiagnosticsCollector+      diags <- finalizeDiagnostics collector+      let s = show diags+      s `shouldContain` "LayerDiagnostics"++  describe "LayerNode show" $ do+    it "shows the node" $ do+      let node = LayerNode+            { nodeId = "test"+            , nodeName = "TestNode"+            , nodeType = EffectNode+            , resourceType = Nothing+            , status = Initialized+            , duration = Just 0.1+            , children = []+            , metadata = HashMap.empty+            }+      let s = show node+      s `shouldContain` "TestNode"+      s `shouldContain` "EffectNode"++  describe "LayerNode JSON roundtrip" $ do+    it "basic node roundtrips" $ do+      let node = LayerNode+            { nodeId = "n1"+            , nodeName = "TestNode"+            , nodeType = ResourceNode+            , resourceType = Nothing+            , status = Initialized+            , duration = Just 1.5+            , children = []+            , metadata = HashMap.empty+            }+      let encoded = encode node+      let decoded = decode encoded :: Maybe LayerNode+      case decoded of+        Nothing -> expectationFailure "Failed to decode LayerNode"+        Just n -> do+          nodeId n `shouldBe` "n1"+          nodeName n `shouldBe` "TestNode"+          nodeType n `shouldBe` ResourceNode+          status n `shouldBe` Initialized+          duration n `shouldBe` Just 1.5++    it "node with children roundtrips" $ do+      let child = LayerNode "c1" "Child" EffectNode Nothing Initialized (Just 0.5) [] HashMap.empty+      let parent = LayerNode "p1" "Parent" ComposedNode Nothing Initialized (Just 1.0) [child] HashMap.empty+      let encoded = encode parent+      let decoded = decode encoded :: Maybe LayerNode+      case decoded of+        Nothing -> expectationFailure "Failed to decode parent node"+        Just n -> do+          length (children n) `shouldBe` 1+          case children n of+            [c] -> nodeName c `shouldBe` "Child"+            _ -> expectationFailure "Expected exactly one child"++    it "node with metadata roundtrips" $ do+      let node = LayerNode "m1" "Meta" ServiceNode Nothing+                   (SharedReference "ref-1") Nothing []+                   (HashMap.fromList [("pool", "10"), ("timeout", "30")])+      let encoded = encode node+      let decoded = decode encoded :: Maybe LayerNode+      case decoded of+        Nothing -> expectationFailure "Failed to decode node with metadata"+        Just n -> do+          status n `shouldBe` SharedReference "ref-1"+          HashMap.lookup "pool" (metadata n) `shouldBe` Just "10"+          HashMap.lookup "timeout" (metadata n) `shouldBe` Just "30"++    it "node with Failed status roundtrips" $ do+      let node = LayerNode "f1" "Failing" ResourceNode Nothing (Failed "boom") Nothing [] HashMap.empty+      let encoded = encode node+      let decoded = decode encoded :: Maybe LayerNode+      case decoded of+        Nothing -> expectationFailure "Failed to decode failing node"+        Just n -> status n `shouldBe` Failed "boom"++  describe "LayerDiagnostics JSON roundtrip" $ do+    it "full diagnostics roundtrips" $ do+      let child1 = LayerNode "c1" "ConfigLayer" EffectNode Nothing Initialized (Just 0.05) [] HashMap.empty+      let child2 = LayerNode "c2" "DbLayer" ResourceNode Nothing Initialized (Just 0.2) [] HashMap.empty+      let root = LayerNode "root" "App" SequentialNode Nothing Initialized (Just 0.25)+                   [child1, child2] HashMap.empty+      let diags = LayerDiagnostics+            { rootNode = root+            , totalDuration = 0.25+            , totalResources = 2+            , sharedResources = 0+            }+      let encoded = encode diags+      let decoded = decode encoded :: Maybe LayerDiagnostics+      case decoded of+        Nothing -> expectationFailure "Failed to decode LayerDiagnostics"+        Just d -> do+          totalDuration d `shouldBe` 0.25+          totalResources d `shouldBe` 2+          sharedResources d `shouldBe` 0+          nodeName (rootNode d) `shouldBe` "App"+          length (children (rootNode d)) `shouldBe` 2++  describe "Complex Layer Compositions" $ do+    it "tracks composed layers" $ do+      collector <- newDiagnosticsCollector+      let interceptor = createDiagnosticsInterceptor collector++      let configLayer = effect @IO @() @Config $ pure (Config 8080)+      let dbLayer = do+            cfg <- ask+            effect @IO @Config @Database $ pure $ Database ("localhost:" <> show (configPort cfg))++      let composed = configLayer >>> dbLayer+      result <- runLayerWithInterceptor interceptor () composed++      dbConnection result `shouldBe` "localhost:8080"++      diags <- finalizeDiagnostics collector+      nodeName (rootNode diags) `shouldBe` "Root"++    it "tracks parallel composition" $ do+      collector <- newDiagnosticsCollector+      let interceptor = createDiagnosticsInterceptor collector++      let layer1 = effect @IO @() @Config $ pure (Config 8080)+      let layer2 = effect @IO @() @WebServer $ pure (WebServer 9090)++      let parallelLayers = liftA2 (,) layer1 layer2+      (cfg, ws) <- runLayerWithInterceptor interceptor () parallelLayers++      configPort cfg `shouldBe` 8080+      serverPort ws `shouldBe` 9090++      diags <- finalizeDiagnostics collector+      nodeName (rootNode diags) `shouldBe` "Root"++  describe "Interceptor Edge Cases" $ do+    it "combines interceptors with empty list" $ do+      let combined = combineInterceptors []+      ref <- newIORef ([] :: [String])+      let layer = effect @IO @() @String $ do+            modifyIORef ref (++ ["effect"])+            pure "test"+      result <- runLayerWithInterceptor combined () layer+      result `shouldBe` "test"+      logs <- readIORef ref+      logs `shouldBe` ["effect"]++    it "interceptor captures all operation types" $ do+      ref <- newIORef ([] :: [String])+      let loggingInterceptor = LayerInterceptor+            { onResourceAcquire = \_ -> liftIO $ modifyIORef ref (++ ["acquire"])+            , onResourceAcquireComplete = \_ _ -> pure ()+            , onResourceRelease = \_ -> liftIO $ modifyIORef ref (++ ["release"])+            , onEffectRun = \_ -> liftIO $ modifyIORef ref (++ ["effect"])+            , onEffectComplete = \_ _ -> liftIO $ modifyIORef ref (++ ["effect-done"])+            , onServiceCreate = \_ -> liftIO $ modifyIORef ref (++ ["service-create"])+            , onServiceReuse = \_ _ -> liftIO $ modifyIORef ref (++ ["service-reuse"])+            , onCompositionStart = \_ -> liftIO $ modifyIORef ref (++ ["comp-start"])+            , onCompositionEnd = \_ _ -> liftIO $ modifyIORef ref (++ ["comp-end"])+            }++      let resourceLayer = resource @IO @() @Int (pure 100) (\_ -> pure ())+      let effectLayer = effect @IO @() @String (pure "test")+      let serviceLayer = mkService resourceLayer+      let composed = do+            _ <- resourceLayer+            _ <- effectLayer+            _ <- service serviceLayer+            _ <- service serviceLayer+            pure ()++      void $ runLayerWithInterceptor loggingInterceptor () composed++      logs <- readIORef ref+      "acquire" `elem` logs `shouldBe` True+      "effect" `elem` logs `shouldBe` True+      "service-create" `elem` logs `shouldBe` True+      "service-reuse" `elem` logs `shouldBe` True++    it "helper functions create proper contexts" $ do+      let ctx1 = simpleContext "test"+      operationName ctx1 `shouldBe` "test"+      operationType ctx1 `shouldBe` Nothing++      let ctx2 = withType (typeRep (Proxy @Int)) ctx1+      operationType ctx2 `shouldSatisfy` (/= Nothing)++      let ctx3 = withMetadata [("key", "value")] ctx1+      operationMetadata ctx3 `shouldBe` [("key", "value")]++  describe "Snapshot Diagnostics" $ do+    it "snapshotDiagnostics doesn't finalize collector" $ do+      collector <- newDiagnosticsCollector+      let interceptor = createDiagnosticsInterceptor collector++      snap1 <- snapshotDiagnostics collector+      totalResources snap1 `shouldBe` 0++      let layer = effect @IO @() @Int (pure 42)+      void $ runLayerWithInterceptor interceptor () layer++      snap2 <- snapshotDiagnostics collector+      totalDuration snap2 `shouldSatisfy` (>= 0)++      final <- finalizeDiagnostics collector+      totalDuration final `shouldSatisfy` (>= 0)++    it "live diagnostics rendering with manual control" $ do+      collector <- newDiagnosticsCollector++      snap <- snapshotDiagnostics collector+      nodeName (rootNode snap) `shouldBe` "Root"++      let rendered = renderLayerTree snap+      rendered `shouldContain` "Layer Initialization Tree"++    it "snapshot reflects empty collector" $ do+      collector <- newDiagnosticsCollector+      snap <- snapshotDiagnostics collector+      totalResources snap `shouldBe` 0+      sharedResources snap `shouldBe` 0+      nodeName (rootNode snap) `shouldBe` "Root"+      nodeType (rootNode snap) `shouldBe` ComposedNode++  describe "Complex Diagnostics with withLayerDiagnostics" $ do+    it "withLayerDiagnostics provides both environment and diagnostics" $ do+      let testLayer = effect @IO @() @Int (pure 42)++      withLayerDiagnostics testLayer () $ \(env, diags) -> liftIO $ do+        env `shouldBe` 42+        totalDuration diags `shouldSatisfy` (>= 0)+        nodeName (rootNode diags) `shouldBe` "Root"++    it "buildLayerDiagnostics runs layer and returns diagnostics" $ do+      let testLayer = effect @IO @() @String (pure "test")++      diags <- buildLayerDiagnostics testLayer ()+      totalDuration diags `shouldSatisfy` (>= 0)+      nodeName (rootNode diags) `shouldBe` "Root"++    it "withLayerDiagnostics with resource layers" $ do+      let testLayer = resource @IO @() @String+            (pure "managed-resource")+            (\_ -> pure ())++      withLayerDiagnostics testLayer () $ \(env, diags) -> liftIO $ do+        env `shouldBe` ("managed-resource" :: String)+        totalDuration diags `shouldSatisfy` (>= 0)++    it "buildLayerDiagnostics with service tracking" $ do+      let svc = mkService $ effect @IO @() @Int (pure 99)+      let testLayer = do+            a <- service svc+            b <- service svc+            pure (a + b)++      diags <- buildLayerDiagnostics testLayer ()+      totalResources diags `shouldSatisfy` (>= 1)+      sharedResources diags `shouldSatisfy` (>= 1)++    it "buildLayerDiagnostics with composed layers exercises composition callbacks" $ do+      let configL = effect @IO @() @Config $ pure (Config 8080)+      let dbL = do+            cfg <- ask+            effect @IO @Config @Database $ pure (Database ("db:" <> show (configPort cfg)))+      let composed = configL >>> dbL+      diags <- buildLayerDiagnostics composed ()+      totalDuration diags `shouldSatisfy` (>= 0)+      let root = rootNode diags+      length (children root) `shouldSatisfy` (>= 1)++    it "buildLayerDiagnostics with service reuse through full pipeline" $ do+      let svc = mkService $ resource @IO @() @Config+            (pure (Config 42))+            (\_ -> pure ())+      let testLayer = do+            a <- service svc+            b <- service svc+            pure (configPort a + configPort b)+      diags <- buildLayerDiagnostics testLayer ()+      sharedResources diags `shouldSatisfy` (>= 1)+      totalResources diags `shouldSatisfy` (>= 1)++  describe "Diagnostics - endNode edge cases" $ do+    it "handles completing root node directly" $ do+      collector <- newDiagnosticsCollector+      let interceptor = createDiagnosticsInterceptor collector++      let layer = effect @IO @() @Int $ pure 42+      _ <- runLayerWithInterceptor interceptor () layer++      diags <- finalizeDiagnostics collector+      status (rootNode diags) `shouldBe` Initialized++    it "service without type still tracked" $ do+      collector <- newDiagnosticsCollector+      let interceptor = createDiagnosticsInterceptor collector++      let svc = mkService $ effect @IO @() @Int $ pure 42+      let layer = service svc+      _ <- runLayerWithInterceptor interceptor () layer++      diags <- finalizeDiagnostics collector+      totalResources diags `shouldSatisfy` (>= 1)++  describe "Diagnostics - rendering edge cases" $ do+    it "renders node with no duration" $ do+      let node = LayerNode "n1" "NoDuration" EffectNode Nothing Initializing Nothing [] HashMap.empty+      let diags = LayerDiagnostics+            { rootNode = node+            , totalDuration = 0+            , totalResources = 0+            , sharedResources = 0+            }+      let rendered = renderLayerTree diags+      rendered `shouldContain` "NoDuration"++    it "renders node with Failed status" $ do+      let node = LayerNode "n1" "FailedNode" ResourceNode Nothing (Failed "crash") (Just 0.1) [] HashMap.empty+      let diags = LayerDiagnostics+            { rootNode = node+            , totalDuration = 0.1+            , totalResources = 1+            , sharedResources = 0+            }+      let rendered = renderLayerTree diags+      rendered `shouldContain` "crash"++    it "renders node with SharedReference status" $ do+      let shared = LayerNode "s1" "SharedSvc" ServiceNode Nothing (SharedReference "svc-001") Nothing [] HashMap.empty+      let parent = LayerNode "p1" "Parent" ComposedNode Nothing Initialized (Just 0.5) [shared] HashMap.empty+      let diags = LayerDiagnostics+            { rootNode = parent+            , totalDuration = 0.5+            , totalResources = 1+            , sharedResources = 1+            }+      let rendered = renderLayerTree diags+      rendered `shouldContain` "svc-001"++    it "renders Initializing status" $ do+      let node = LayerNode "n1" "InProgress" EffectNode Nothing Initializing Nothing [] HashMap.empty+      let diags = LayerDiagnostics { rootNode = node, totalDuration = 0, totalResources = 0, sharedResources = 0 }+      let rendered = renderLayerTree diags+      rendered `shouldContain` "InProgress"++    it "renders deeply nested tree" $ do+      let leaf = LayerNode "l1" "Leaf" EffectNode Nothing Initialized (Just 0.01) [] HashMap.empty+      let mid = LayerNode "m1" "Mid" ResourceNode Nothing Initialized (Just 0.05) [leaf] HashMap.empty+      let root = LayerNode "r1" "Root" ComposedNode Nothing Initialized (Just 0.1) [mid] HashMap.empty+      let diags = LayerDiagnostics { rootNode = root, totalDuration = 0.1, totalResources = 2, sharedResources = 0 }+      let rendered = renderLayerTree diags+      rendered `shouldContain` "Leaf"+      rendered `shouldContain` "Mid"++    it "renders multiple children" $ do+      let c1 = LayerNode "c1" "Child1" EffectNode Nothing Initialized (Just 0.01) [] HashMap.empty+      let c2 = LayerNode "c2" "Child2" ResourceNode Nothing Initialized (Just 0.02) [] HashMap.empty+      let c3 = LayerNode "c3" "Child3" ServiceNode Nothing Initialized (Just 0.03) [] HashMap.empty+      let root = LayerNode "r" "Root" ParallelNode Nothing Initialized (Just 0.1) [c1, c2, c3] HashMap.empty+      let diags = LayerDiagnostics { rootNode = root, totalDuration = 0.1, totalResources = 3, sharedResources = 0 }+      let rendered = renderLayerTree diags+      rendered `shouldContain` "Child1"+      rendered `shouldContain` "Child2"+      rendered `shouldContain` "Child3"++    it "detailed rendering shows metadata" $ do+      let node = LayerNode "n1" "WithMeta" ResourceNode (Just (typeRep (Proxy @Int))) Initialized+                   (Just 0.5) [] (HashMap.fromList [("pool", "10")])+      let diags = LayerDiagnostics { rootNode = node, totalDuration = 0.5, totalResources = 1, sharedResources = 0 }+      let rendered = renderLayerTreeDetailed diags+      rendered `shouldContain` "pool"+      rendered `shouldContain` "10"+      rendered `shouldContain` "Int"++    it "detailed rendering shows all status types" $ do+      let mkNode s = LayerNode "n" "N" EffectNode Nothing s Nothing [] HashMap.empty+      let mkDiags n = LayerDiagnostics { rootNode = n, totalDuration = 0, totalResources = 0, sharedResources = 0 }++      let r1 = renderLayerTreeDetailed (mkDiags (mkNode Initializing))+      r1 `shouldContain` "Initializing"++      let r2 = renderLayerTreeDetailed (mkDiags (mkNode Initialized))+      r2 `shouldContain` "Initialized"++      let r3 = renderLayerTreeDetailed (mkDiags (mkNode (Failed "err")))+      r3 `shouldContain` "Failed"+      r3 `shouldContain` "err"++      let r4 = renderLayerTreeDetailed (mkDiags (mkNode (SharedReference "ref-1")))+      r4 `shouldContain` "Shared reference"+      r4 `shouldContain` "ref-1"++    it "detailed rendering with SequentialNode type symbol" $ do+      let node = LayerNode "n1" "Seq" SequentialNode Nothing Initialized Nothing [] HashMap.empty+      let diags = LayerDiagnostics { rootNode = node, totalDuration = 0, totalResources = 0, sharedResources = 0 }+      let rendered = renderLayerTreeDetailed diags+      rendered `shouldContain` "SequentialNode"++    it "detailed rendering with ParallelNode type symbol" $ do+      let node = LayerNode "n1" "Par" ParallelNode Nothing Initialized Nothing [] HashMap.empty+      let diags = LayerDiagnostics { rootNode = node, totalDuration = 0, totalResources = 0, sharedResources = 0 }+      let rendered = renderLayerTreeDetailed diags+      rendered `shouldContain` "ParallelNode"++    it "detailed rendering shows duration" $ do+      let node = LayerNode "n1" "Timed" EffectNode Nothing Initialized (Just 1.234) [] HashMap.empty+      let diags = LayerDiagnostics { rootNode = node, totalDuration = 1.234, totalResources = 0, sharedResources = 0 }+      let rendered = renderLayerTreeDetailed diags+      rendered `shouldContain` "1.234"++    it "detailed rendering with children" $ do+      let child = LayerNode "c1" "Kid" EffectNode Nothing Initialized (Just 0.1) [] HashMap.empty+      let parent = LayerNode "p1" "Dad" ComposedNode Nothing Initialized (Just 0.5) [child] HashMap.empty+      let diags = LayerDiagnostics { rootNode = parent, totalDuration = 0.5, totalResources = 1, sharedResources = 0 }+      let rendered = renderLayerTreeDetailed diags+      rendered `shouldContain` "Kid"+      rendered `shouldContain` "Dad"++  describe "Diagnostics - snapshot support" $ do+    it "snapshotDiagnostics computes totalDuration" $ do+      collector <- newDiagnosticsCollector+      snap <- snapshotDiagnostics collector+      totalDuration snap `shouldSatisfy` (>= 0)+      totalResources snap `shouldBe` 0++  describe "Diagnostics interceptor - composition callbacks" $ do+    it "onCompositionStart creates Sequential node" $ do+      collector <- newDiagnosticsCollector+      let interceptor = createDiagnosticsInterceptor collector+      onCompositionStart interceptor Sequential+      onCompositionEnd interceptor Sequential 0.1+      diags <- finalizeDiagnostics collector+      let root = rootNode diags+      length (children root) `shouldSatisfy` (>= 1)++    it "onCompositionStart creates Parallel node" $ do+      collector <- newDiagnosticsCollector+      let interceptor = createDiagnosticsInterceptor collector+      onCompositionStart interceptor Parallel+      onCompositionEnd interceptor Parallel 0.2+      diags <- finalizeDiagnostics collector+      length (children (rootNode diags)) `shouldSatisfy` (>= 1)++  describe "Diagnostics interceptor - service reuse shared node" $ do+    it "onServiceReuse creates shared reference when service was tracked" $ do+      collector <- newDiagnosticsCollector+      let interceptor = createDiagnosticsInterceptor collector+      let tr = typeRep (Proxy @Int)+      let ctx = OperationContext "IntService" (Just tr) []+      onServiceCreate interceptor ctx+      onServiceReuse interceptor "IntService" tr+      diags <- finalizeDiagnostics collector+      sharedResources diags `shouldBe` 1+      totalResources diags `shouldBe` 1++    it "onServiceReuse with untracked type is a no-op" $ do+      collector <- newDiagnosticsCollector+      let interceptor = createDiagnosticsInterceptor collector+      let tr = typeRep (Proxy @Bool)+      onServiceReuse interceptor "Unknown" tr+      diags <- finalizeDiagnostics collector+      sharedResources diags `shouldBe` 0++  describe "Diagnostics interceptor - endNode edge cases" $ do+    it "endNode on empty stack is a no-op" $ do+      collector <- newDiagnosticsCollector+      let interceptor = createDiagnosticsInterceptor collector+      onEffectComplete interceptor "test" 0.1+      onEffectComplete interceptor "test2" 0.2+      diags <- finalizeDiagnostics collector+      totalDuration diags `shouldSatisfy` (>= 0)++    it "endNode completing root directly" $ do+      collector <- newDiagnosticsCollector+      let interceptor = createDiagnosticsInterceptor collector+      onEffectRun interceptor (OperationContext "root-effect" Nothing [])+      onEffectComplete interceptor "root-effect" 0.5+      diags <- finalizeDiagnostics collector+      let root = rootNode diags+      length (children root) `shouldSatisfy` (>= 1)++  describe "Diagnostics - showList coverage" $ do+    it "showList for LayerNodeType" $ do+      let s = show [ResourceNode, EffectNode, ServiceNode]+      s `shouldContain` "ResourceNode"+      s `shouldContain` "EffectNode"++    it "showList for ResourceStatus" $ do+      let s = show [Initializing, Initialized, Failed "x"]+      s `shouldContain` "Initializing"++    it "showList for LayerDiagnostics" $ do+      let d = LayerDiagnostics+                (LayerNode "r" "R" ComposedNode Nothing Initialized Nothing [] HashMap.empty)+                0 0 0+      let s = show [d]+      s `shouldContain` "LayerDiagnostics"++    it "showList for LayerNode" $ do+      let n = LayerNode "n" "N" EffectNode Nothing Initialized Nothing [] HashMap.empty+      let s = show [n, n]+      s `shouldContain` "LayerNode"++  describe "Diagnostics - JSON list encoding" $ do+    it "toJSON list of LayerNodeType" $ do+      let val = toJSON [ResourceNode, EffectNode, ServiceNode]+      BSL.length (encode val) `shouldSatisfy` (> 0)++    it "toEncoding of LayerNodeType" $ do+      BSL.length (encodingToLazyByteString (toEncoding ResourceNode)) `shouldSatisfy` (> 0)+      BSL.length (encodingToLazyByteString (toEncoding EffectNode)) `shouldSatisfy` (> 0)+      BSL.length (encodingToLazyByteString (toEncoding ServiceNode)) `shouldSatisfy` (> 0)+      BSL.length (encodingToLazyByteString (toEncoding ComposedNode)) `shouldSatisfy` (> 0)+      BSL.length (encodingToLazyByteString (toEncoding ParallelNode)) `shouldSatisfy` (> 0)+      BSL.length (encodingToLazyByteString (toEncoding SequentialNode)) `shouldSatisfy` (> 0)++    it "toEncoding of ResourceStatus" $ do+      BSL.length (encodingToLazyByteString (toEncoding Initializing)) `shouldSatisfy` (> 0)+      BSL.length (encodingToLazyByteString (toEncoding Initialized)) `shouldSatisfy` (> 0)+      BSL.length (encodingToLazyByteString (toEncoding (Failed "e"))) `shouldSatisfy` (> 0)+      BSL.length (encodingToLazyByteString (toEncoding (SharedReference "r"))) `shouldSatisfy` (> 0)++    it "toEncoding of LayerNode" $ do+      let n = LayerNode "n" "N" EffectNode Nothing Initialized (Just 0.1) [] HashMap.empty+      BSL.length (encodingToLazyByteString (toEncoding n)) `shouldSatisfy` (> 0)++    it "toEncoding of LayerDiagnostics" $ do+      let d = LayerDiagnostics+                (LayerNode "r" "R" ComposedNode Nothing Initialized Nothing [] HashMap.empty)+                0.5 2 1+      BSL.length (encodingToLazyByteString (toEncoding d)) `shouldSatisfy` (> 0)++    it "decode JSON list of LayerNodeType" $ do+      let encoded = encode [ResourceNode, EffectNode]+      let decoded = decode encoded :: Maybe [LayerNodeType]+      decoded `shouldBe` Just [ResourceNode, EffectNode]++    it "decode JSON list of ResourceStatus" $ do+      let encoded = encode [Initializing, Initialized]+      let decoded = decode encoded :: Maybe [ResourceStatus]+      decoded `shouldBe` Just [Initializing, Initialized]++    it "decode JSON list of LayerNode" $ do+      let n = LayerNode "n" "N" EffectNode Nothing Initialized (Just 0.1) [] HashMap.empty+      let encoded = encode [n]+      let decoded = decode encoded :: Maybe [LayerNode]+      case decoded of+        Nothing -> expectationFailure "Failed to decode"+        Just ns -> length ns `shouldBe` 1++  describe "Diagnostics - DiagnosticsCollector field" $ do+    it "newDiagnosticsCollector returns usable collector" $ do+      collector <- newDiagnosticsCollector+      diags <- finalizeDiagnostics collector+      nodeName (rootNode diags) `shouldBe` "Root"++  describe "Diagnostics - full pipeline integration" $ do+    it "composed layers produce sequential composition nodes in diagnostics" $ do+      let l1 = effect @IO @() @Config $ pure (Config 1)+      let l2 = do+            c <- ask+            effect @IO @Config @Database $ pure (Database (show (configPort c)))+      diags <- buildLayerDiagnostics (l1 >>> l2) ()+      totalDuration diags `shouldSatisfy` (>= 0)++    it "service create+reuse through full pipeline" $ do+      let svc = mkService $ resource @IO @() @Database+            (pure (Database "svc"))+            (\_ -> pure ())+      let layer = do+            a <- service svc+            b <- service svc+            pure (dbConnection a, dbConnection b)+      diags <- buildLayerDiagnostics layer ()+      totalResources diags `shouldSatisfy` (>= 1)+      sharedResources diags `shouldSatisfy` (>= 1)++    it "resource layer produces resource node in diagnostics" $ do+      let layer = resource @IO @() @Config (pure (Config 1)) (\_ -> pure ())+      diags <- buildLayerDiagnostics layer ()+      let root = rootNode diags+      length (children root) `shouldSatisfy` (>= 1)++  describe "Diagnostics - concurrent safety" $ do+    it "does not lose events under concurrent zipLayer composition" $ do+      (barrier :: MVar ()) <- newEmptyMVar+      let layer1 = resource @IO @() @Config+            (takeMVar barrier >> pure (Config 1))+            (\_ -> pure ())+      let layer2 = resource @IO @() @Database+            (putMVar barrier () >> pure (Database "db"))+            (\_ -> pure ())+      let combined = zipLayer layer1 layer2+      collector <- newDiagnosticsCollector+      let interceptor = createDiagnosticsInterceptor collector+      _ <- runLayerWithInterceptor interceptor ((), ()) combined+      diags <- finalizeDiagnostics collector+      totalDuration diags `shouldSatisfy` (>= 0)++    it "tracks all resources under repeated concurrent composition" $ do+      let mkRes i = resource @IO @() @Int (pure i) (\_ -> pure ())+      let combined = zipLayer (zipLayer (mkRes 1) (mkRes 2)) (zipLayer (mkRes 3) (mkRes 4))+      collector <- newDiagnosticsCollector+      let interceptor = createDiagnosticsInterceptor collector+      _ <- runLayerWithInterceptor interceptor (((),()), ((),())) combined+      diags <- finalizeDiagnostics collector+      nodeName (rootNode diags) `shouldBe` "Root"

@@ -0,0 +1,169 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Fractal.Layer.InterceptorSpec (spec) where++import Test.Hspec+import Data.Typeable (Proxy(..), typeRep)+import Fractal.Layer.Interceptor+import UnliftIO++spec :: Spec+spec = do+  describe "CompositionType" $ do+    it "Sequential show" $+      show Sequential `shouldBe` "Sequential"++    it "Parallel show" $+      show Parallel `shouldBe` "Parallel"++    it "Sequential == Sequential" $+      Sequential `shouldBe` Sequential++    it "Parallel == Parallel" $+      Parallel `shouldBe` Parallel++    it "Sequential /= Parallel" $+      Sequential `shouldNotBe` Parallel++  describe "OperationContext" $ do+    it "show includes all fields" $ do+      let ctx = OperationContext+            { operationName = "test"+            , operationType = Just (typeRep (Proxy @Int))+            , operationMetadata = [("key", "value")]+            }+      let s = show ctx+      s `shouldContain` "test"+      s `shouldContain` "key"+      s `shouldContain` "value"++    it "show with Nothing type" $ do+      let ctx = simpleContext "bare"+      show ctx `shouldContain` "bare"++  describe "nullInterceptor" $ do+    it "all callbacks are no-ops" $ do+      let ni = nullInterceptor :: LayerInterceptor IO+      onResourceAcquire ni (simpleContext "test")+      onResourceAcquireComplete ni "test" 0+      onResourceRelease ni "test"+      onEffectRun ni (simpleContext "test")+      onEffectComplete ni "test" 0+      onServiceCreate ni (simpleContext "test")+      onServiceReuse ni "test" (typeRep (Proxy @Int))+      onCompositionStart ni Sequential+      onCompositionEnd ni Sequential 0++  describe "combineInterceptors" $ do+    it "empty list behaves like nullInterceptor" $ do+      let combined = combineInterceptors ([] :: [LayerInterceptor IO])+      onResourceAcquire combined (simpleContext "test")+      onCompositionStart combined Sequential+      onCompositionEnd combined Parallel 1.0++    it "preserves order of callbacks" $ do+      ref <- newIORef ([] :: [Int])+      let i1 = nullInterceptor { onEffectRun = \_ -> modifyIORef ref (++ [1]) }+      let i2 = nullInterceptor { onEffectRun = \_ -> modifyIORef ref (++ [2]) }+      let i3 = nullInterceptor { onEffectRun = \_ -> modifyIORef ref (++ [3]) }+      let combined = combineInterceptors [i1, i2, i3]+      onEffectRun combined (simpleContext "test")+      readIORef ref >>= (`shouldBe` [1, 2, 3])++    it "combines onCompositionStart callbacks" $ do+      ref <- newIORef ([] :: [String])+      let i1 = nullInterceptor { onCompositionStart = \t -> modifyIORef ref (++ ["i1:" ++ show t]) }+      let i2 = nullInterceptor { onCompositionStart = \t -> modifyIORef ref (++ ["i2:" ++ show t]) }+      let combined = combineInterceptors [i1, i2]++      onCompositionStart combined Sequential+      onCompositionStart combined Parallel++      logs <- readIORef ref+      logs `shouldBe` ["i1:Sequential", "i2:Sequential", "i1:Parallel", "i2:Parallel"]++    it "combines onCompositionEnd callbacks" $ do+      ref <- newIORef ([] :: [String])+      let i1 = nullInterceptor { onCompositionEnd = \t _ -> modifyIORef ref (++ ["i1:" ++ show t]) }+      let i2 = nullInterceptor { onCompositionEnd = \t _ -> modifyIORef ref (++ ["i2:" ++ show t]) }+      let combined = combineInterceptors [i1, i2]++      onCompositionEnd combined Sequential 1.0+      logs <- readIORef ref+      logs `shouldBe` ["i1:Sequential", "i2:Sequential"]++    it "combines all callback types" $ do+      ref <- newIORef ([] :: [String])+      let tracker :: String -> LayerInterceptor IO+          tracker tag = (nullInterceptor :: LayerInterceptor IO)+            { onResourceAcquire = \_ -> modifyIORef ref (++ [tag ++ ":acq"])+            , onResourceAcquireComplete = \_ _ -> modifyIORef ref (++ [tag ++ ":acqd"])+            , onResourceRelease = \_ -> modifyIORef ref (++ [tag ++ ":rel"])+            , onEffectRun = \_ -> modifyIORef ref (++ [tag ++ ":eff"])+            , onEffectComplete = \_ _ -> modifyIORef ref (++ [tag ++ ":done"])+            , onServiceCreate = \_ -> modifyIORef ref (++ [tag ++ ":svc"])+            , onServiceReuse = \_ _ -> modifyIORef ref (++ [tag ++ ":reuse"])+            , onCompositionStart = \_ -> modifyIORef ref (++ [tag ++ ":cstart"])+            , onCompositionEnd = \_ _ -> modifyIORef ref (++ [tag ++ ":cend"])+            }+      let combined = combineInterceptors [tracker "a", tracker "b"]++      onResourceAcquire combined (simpleContext "r")+      onResourceAcquireComplete combined "r" 0+      onResourceRelease combined "r"+      onEffectRun combined (simpleContext "e")+      onEffectComplete combined "e" 0+      onServiceCreate combined (simpleContext "s")+      onServiceReuse combined "s" (typeRep (Proxy @Int))+      onCompositionStart combined Sequential+      onCompositionEnd combined Sequential 0++      logs <- readIORef ref+      logs `shouldBe`+        [ "a:acq", "b:acq"+        , "a:acqd", "b:acqd"+        , "a:rel", "b:rel"+        , "a:eff", "b:eff"+        , "a:done", "b:done"+        , "a:svc", "b:svc"+        , "a:reuse", "b:reuse"+        , "a:cstart", "b:cstart"+        , "a:cend", "b:cend"+        ]++  describe "simpleContext" $ do+    it "creates context with name only" $ do+      let ctx = simpleContext "my-op"+      operationName ctx `shouldBe` "my-op"+      operationType ctx `shouldBe` Nothing+      operationMetadata ctx `shouldBe` []++  describe "withType" $ do+    it "adds type to context" $ do+      let ctx = withType (typeRep (Proxy @Bool)) (simpleContext "op")+      operationType ctx `shouldBe` Just (typeRep (Proxy @Bool))+      operationName ctx `shouldBe` "op"+      operationMetadata ctx `shouldBe` []++  describe "withMetadata" $ do+    it "adds metadata to context" $ do+      let ctx = withMetadata [("k1", "v1"), ("k2", "v2")] (simpleContext "op")+      operationMetadata ctx `shouldBe` [("k1", "v1"), ("k2", "v2")]++    it "appends to existing metadata" $ do+      let ctx0 = OperationContext "op" Nothing [("existing", "data")]+      let ctx1 = withMetadata [("new", "field")] ctx0+      operationMetadata ctx1 `shouldBe` [("existing", "data"), ("new", "field")]++  describe "showList coverage" $ do+    it "showList for CompositionType" $ do+      let s = show [Sequential, Parallel, Sequential]+      s `shouldContain` "Sequential"+      s `shouldContain` "Parallel"++    it "showList for OperationContext" $ do+      let ctx = simpleContext "test"+      let s = show [ctx, ctx]+      s `shouldContain` "test"

@@ -0,0 +1,1610 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}++module Fractal.Layer.LayerSpec (spec) where++import Test.Hspec+import Test.QuickCheck+import Test.QuickCheck.Monadic+import Fractal.Layer+import Fractal.Layer.Internal (unsafeMkLayer)+import Fractal.Layer.Interceptor+import Control.Category ((>>>), id, (.))+import Control.Arrow ((&&&), (***), arr, first, second, ArrowZero(..), ArrowPlus(..), ArrowChoice(..), app)+import Control.Concurrent (myThreadId)+import Control.Exception (AsyncException(ThreadKilled))+import qualified Control.Exception as E+import Control.Monad+import Control.Monad.Reader+import Control.Applicative+import qualified Control.Selective as S+import Data.List.NonEmpty (NonEmpty(..))+import Data.Semigroup (stimes, sconcat)+import Data.Typeable+import Data.Profunctor (lmap, first', second', left', right')+import qualified Data.Profunctor as P+import Data.Profunctor.Traversing (traverse')+import UnliftIO hiding (assert)+import Prelude hiding (id, (.))++-- Test data types+data Config = Config { port :: Int, host :: String } deriving (Eq, Show)+data Database = Database { connId :: Int } deriving (Eq, Show)+data WebServer = WebServer { serverId :: Int } deriving (Eq, Show)+data Cache = Cache { cacheId :: Int } deriving (Eq, Show)++-- Helper to track resource lifecycles+data ResourceTracker = ResourceTracker+  { acquired :: IORef [String]+  , released :: IORef [String]+  }++newResourceTracker :: IO ResourceTracker+newResourceTracker = ResourceTracker <$> newIORef [] <*> newIORef []++trackAcquire :: ResourceTracker -> String -> IO ()+trackAcquire tracker name = atomicModifyIORef' (acquired tracker) $ \xs -> (name : xs, ())++trackRelease :: ResourceTracker -> String -> IO ()+trackRelease tracker name = atomicModifyIORef' (released tracker) $ \xs -> (name : xs, ())++-- Test layers+configLayer :: Layer IO () Config+configLayer = effect $ pure $ Config 8080 "localhost"++trackedResource :: (Typeable a) => ResourceTracker -> String -> a -> Layer IO () a+trackedResource tracker name value = resource+  (trackAcquire tracker name >> pure value)+  (\_ -> trackRelease tracker name)++dbLayer :: ResourceTracker -> Layer IO Config Database+dbLayer tracker = do+  cfg <- ask+  resource+    (do trackAcquire tracker "database"+        pure $ Database (port cfg))+    (\_ -> trackRelease tracker "database")++webLayer :: ResourceTracker -> Layer IO Config WebServer+webLayer tracker = do+  cfg <- ask+  resource+    (do trackAcquire tracker "webserver"+        pure $ WebServer (port cfg + 1000))+    (\_ -> trackRelease tracker "webserver")++cacheLayer :: ResourceTracker -> Layer IO a Cache+cacheLayer tracker = resource+  (do trackAcquire tracker "cache"+      pure $ Cache 42)+  (\_ -> trackRelease tracker "cache")++-- A layer that waits for a signal before failing, for testing concurrent failure+signaledFailingLayer :: MVar () -> Layer IO () ()+signaledFailingLayer signal = resource+  (do takeMVar signal+      throwIO $ userError "Signaled failure")+  (\_ -> pure ())++spec :: Spec+spec = do+  describe "Layer - Basic Construction" $ do+    it "effect creates a simple layer" $ do+      let layer = effect (pure ("test" :: String)) :: Layer IO () String+      result <- runLayer () layer+      result `shouldBe` "test"++    it "resource manages acquisition and release" $ do+      tracker <- newResourceTracker+      let layer = trackedResource tracker "test-resource" ("value" :: String)++      -- Run the layer+      withLayer () layer $ \val -> liftIO do+        val `shouldBe` ("value" :: String)+        acq <- readIORef (acquired tracker)+        acq `shouldBe` ["test-resource"]+        rel <- readIORef (released tracker)+        rel `shouldBe` []++      -- Check cleanup happened+      rel <- readIORef (released tracker)+      rel `shouldBe` ["test-resource"]++    it "pureLayer creates a layer with no effects" $ do+      let layer = pure @(Layer IO ()) ("pure value" :: String)+      result <- runLayer () layer+      result `shouldBe` ("pure value" :: String)++  describe "Layer - Composition" $ do+    it "vertical composition with >>> works correctly" $ do+      tracker <- newResourceTracker+      let composed = configLayer >>> dbLayer tracker++      withLayer () composed $ \db -> liftIO do+        connId db `shouldBe` 8080++      -- Check both acquired and released+      acq <- readIORef (acquired tracker)+      rel <- readIORef (released tracker)+      acq `shouldBe` ["database"]+      rel `shouldBe` ["database"]++    it "horizontal composition with &&& works correctly" $ do+      tracker <- newResourceTracker+      let layer = dbLayer tracker &&& webLayer tracker++      withLayer (Config 3000 "test") layer $ \(db, ws) -> liftIO do+        connId db `shouldBe` 3000+        serverId ws `shouldBe` 4000++      -- Check both are cleaned up (order doesn't matter for parallel composition)+      rel <- readIORef (released tracker)+      length rel `shouldBe` 2+      "database" `elem` rel `shouldBe` True+      "webserver" `elem` rel `shouldBe` True++    it "complex composition maintains proper order" $ do+      tracker <- newResourceTracker+      let layer = configLayer >>> (dbLayer tracker &&& webLayer tracker &&& cacheLayer tracker)++      withLayer () layer $ \(db, (ws, cache)) -> liftIO do+        connId db `shouldBe` 8080+        serverId ws `shouldBe` 9080+        cacheId cache `shouldBe` 42++  describe "Layer - Functor instance" $ do+    it "fmap transforms the output" $ do+      let layer = fmap (*2) (effect $ pure (21 :: Int)) :: Layer IO () Int+      result <- runLayer () layer+      result `shouldBe` (42 :: Int)++    it "preserves resource management with fmap" $ do+      tracker <- newResourceTracker+      let layer = fmap show (trackedResource tracker "mapped" (123 :: Int))++      withLayer () layer $ \val -> liftIO do+        val `shouldBe` ("123" :: String)++      rel <- readIORef (released tracker)+      rel `shouldBe` ["mapped"]++  describe "Layer - Applicative instance" $ do+    it "pure creates a pure layer" $ do+      let layer = pure @(Layer IO ()) (42 :: Int)+      result <- runLayer () layer+      result `shouldBe` (42 :: Int)++    it "<*> combines layers applicatively" $ do+      let funcLayer = pure @(Layer IO ()) ((+10) :: Int -> Int)+      let valueLayer = pure @(Layer IO ()) (32 :: Int)+      let combined = funcLayer <*> valueLayer+      result <- runLayer () combined+      result `shouldBe` (42 :: Int)++    it "liftA2 works correctly" $ do+      tracker <- newResourceTracker+      let layer1 = trackedResource tracker "res1" (10 :: Int)+      let layer2 = trackedResource tracker "res2" (32 :: Int)+      let combined = liftA2 ((+) :: Int -> Int -> Int) layer1 layer2++      result <- runLayer () combined+      result `shouldBe` (42 :: Int)++  describe "Layer - Monad instance" $ do+    it ">>= sequences operations correctly" $ do+      tracker <- newResourceTracker+      let layer = do+            x <- trackedResource tracker "first" (10 :: Int)+            y <- trackedResource tracker "second" (x + 5 :: Int)+            pure (x * y :: Int)++      result <- runLayer () layer+      result `shouldBe` (150 :: Int)++      -- Check acquisition order+      acq <- readIORef (acquired tracker)+      reverse acq `shouldBe` ["first", "second"]++    it ">> discards first result" $ do+      let layer = effect (putStrLn "side effect") >> pure (42 :: Int) :: Layer IO () Int+      result <- runLayer () layer+      result `shouldBe` (42 :: Int)++  describe "Layer - Arrow instance" $ do+    it "arr lifts pure functions" $ do+      let layer = arr @(Layer IO) ((*2) :: Int -> Int)+      result <- runLayer (21 :: Int) layer+      result `shouldBe` (42 :: Int)++    it "first applies to first component" $ do+      let layer = first @(Layer IO) (arr @(Layer IO) @Int @Int ((*2) :: Int -> Int))+      result <- runLayer ((21 :: Int), ("test" :: String)) layer+      result `shouldBe` ((42 :: Int), ("test" :: String))++    it "second applies to second component" $ do+      let layer = second @(Layer IO) (arr @(Layer IO) @Int @Int ((*2) :: Int -> Int))+      result <- runLayer (("test" :: String), (21 :: Int)) layer+      result `shouldBe` (("test" :: String), (42 :: Int))++    it "*** combines two arrows" $ do+      let layer = arr ((*2) :: Int -> Int) *** arr ((++ "!") :: String -> String)+      result <- runLayer ((21 :: Int), ("test" :: String)) layer+      result `shouldBe` ((42 :: Int), ("test!" :: String))++  describe "Layer - Alternative instance" $ do+    it "empty throws EmptyLayer exception" $ do+      let layer = empty :: Layer IO () Int+      runLayer () layer `shouldThrow` anyException++    it "<|> provides fallback behavior" $ do+      let primary = empty :: Layer IO () String+      let fallback = pure ("fallback" :: String) :: Layer IO () String+      let combined = primary <|> fallback++      result <- runLayer () combined+      result `shouldBe` ("fallback" :: String)++    it "<|> cleans up failed branch resources" $ do+      tracker <- newResourceTracker+      let failing = trackedResource tracker "failing" () >> empty :: Layer IO () String+      let success = trackedResource tracker "success" ("ok" :: String)+      let combined = failing <|> success++      result <- runLayer () combined+      result `shouldBe` ("ok" :: String)++      -- Check that failing resource was cleaned up+      acq <- readIORef (acquired tracker)+      rel <- readIORef (released tracker)+      "failing" `elem` acq `shouldBe` True+      "failing" `elem` rel `shouldBe` True+      "success" `elem` acq `shouldBe` True++  describe "Layer - MonadReader instance" $ do+    it "ask returns the dependencies" $ do+      let layer = ask :: Layer IO Config Config+      result <- runLayer (Config 8080 "test") layer+      result `shouldBe` Config 8080 "test"++    it "local modifies dependencies" $ do+      let layer = local (\(Config p h) -> Config (p+1) h) ask+      result <- runLayer (Config 8080 "test") layer+      result `shouldBe` Config 8081 "test"++  describe "Layer - Resource Management" $ do+    -- Note: Resource cleanup order varies based on composition type:+    -- - Monadic bind (>>=): Resources are released in reverse order within each monadic chain+    -- - Parallel composition (&&&): Resources may be released in any order since they're peers+    -- - The important guarantee is that ALL resources are properly cleaned up++    it "releases resources in LIFO order for monadic composition" $ do+      tracker <- newResourceTracker+      let layer = do+            _ <- trackedResource tracker "first" ()+            _ <- trackedResource tracker "second" ()+            _ <- trackedResource tracker "third" ()+            pure ()++      withLayer () layer $ \_ -> pure ()++      -- For monadic composition, check all are released+      rel <- readIORef (released tracker)+      length rel `shouldBe` 3+      "first" `elem` rel `shouldBe` True+      "second" `elem` rel `shouldBe` True+      "third" `elem` rel `shouldBe` True++    it "releases resources on exception" $ do+      tracker <- newResourceTracker+      let layer = do+            _ <- trackedResource tracker "resource" ()+            effect (throwIO $ userError "boom" :: IO ())++      withLayer () layer (\_ -> pure ()) `shouldThrow` anyException++      rel <- readIORef (released tracker)+      rel `shouldBe` ["resource"]++    it "handles nested resource scopes correctly" $ do+      tracker <- newResourceTracker+      let inner = trackedResource tracker "inner" "inner-value"+      let outer = resource+            (do+              trackAcquire tracker "outer"+              withLayer () inner $ \val -> do+                pure $ "outer-" ++ val)+            (\_ -> trackRelease tracker "outer")++      result <- runLayer () outer+      result `shouldBe` "outer-inner-value"++      -- Both should be released, inner first+      rel <- readIORef (released tracker)+      rel `shouldBe` ["outer", "inner"]++    it "demonstrates cleanup order matters for dependent resources" $ do+      -- This test shows a case where order DOES matter+      connectionOpen <- newIORef False+      queryExecuted <- newIORef False++      let dbConnection = resource+            (do+              writeIORef connectionOpen True+              pure ("connection" :: String))+            (\_ -> writeIORef connectionOpen False) :: Layer IO () String++      let dbQuery = resource+            (do+              isOpen <- readIORef connectionOpen+              if isOpen+                then writeIORef queryExecuted True >> pure ("query" :: String)+                else error "Connection closed before query!")+            (\_ -> pure ()) :: Layer IO () String++      let layer = dbConnection >>= \_ -> dbQuery++      -- Run the layer+      result <- runLayer () layer+      result `shouldBe` "query"++      -- Both should have been executed+      readIORef queryExecuted >>= (`shouldBe` True)+      -- And connection should be closed after+      readIORef connectionOpen >>= (`shouldBe` False)++  describe "Layer - Concurrent Composition" $ do+    it "zipLayer runs layers concurrently" $ do+      barrier1 <- newEmptyMVar+      barrier2 <- newEmptyMVar+      let layer1 = effect $ do+            putMVar barrier1 ()+            readMVar barrier2+            pure (1 :: Int)+      let layer2 = effect $ do+            putMVar barrier2 ()+            readMVar barrier1+            pure (2 :: Int)+      let combined = zipLayer layer1 layer2++      (r1, r2) <- runLayer ((), ()) combined+      r1 `shouldBe` 1+      r2 `shouldBe` 2++    it "zipLayer handles concurrent failures correctly" $ do+      tracker <- newResourceTracker+      failSignal <- newEmptyMVar+      let layer1 = trackedResource tracker "res1" () >> signaledFailingLayer failSignal+      let layer2 = trackedResource tracker "res2" ("value" :: String)+      let combined = zipLayer layer1 layer2++      resultVar <- newEmptyMVar+      void $ async $ do+        res <- try $ runLayer ((), ()) combined+        putMVar resultVar (res :: Either SomeException ((), String))++      putMVar failSignal ()+      result <- takeMVar resultVar++      case result of+        Left _ -> pure ()+        Right _ -> expectationFailure "Expected exception"++      rel <- readIORef (released tracker)+      "res1" `elem` rel `shouldBe` True+      "res2" `elem` rel `shouldBe` True++  describe "Layer - Property Tests" $ do+    it "Functor laws" $ property $ \(n :: Int) ->+      monadicIO $ do+        -- fmap id = id+        let layer = pure n :: Layer IO () Int+        r1 <- run $ runLayer () (fmap id layer)+        r2 <- run $ runLayer () layer+        assert $ r1 == r2++    it "Applicative identity law" $ property $ \(n :: Int) ->+      monadicIO $ do+        let layer = pure n :: Layer IO () Int+        r1 <- run $ runLayer () (pure id <*> layer)+        r2 <- run $ runLayer () layer+        assert $ r1 == r2++    it "Category identity laws" $ property $ \(n :: Int) ->+      monadicIO $ do+        let layer = pure n :: Layer IO () Int+        r1 <- run $ runLayer () (id >>> layer)+        r2 <- run $ runLayer () (layer >>> id)+        r3 <- run $ runLayer () layer+        assert $ r1 == r2 && r2 == r3++  describe "Layer - Service" $ do+    it "mkService creates a service from a layer" $ do+      tracker <- newResourceTracker+      let layer = trackedResource tracker "test-service" ("service-value" :: String)+      let svc = mkService layer++      -- Service should behave like a normal layer+      withLayer () (service svc) $ \val -> liftIO do+        val `shouldBe` ("service-value" :: String)++      rel <- readIORef (released tracker)+      rel `shouldBe` ["test-service"]++    it "service caches initialization - single access" $ do+      initCount <- newIORef (0 :: Int)+      let expensiveLayer = resource+            (do+              atomicModifyIORef' initCount $ \n -> (n + 1, ())+              pure ("expensive result" :: String))+            (\_ -> pure ())++      let svc = mkService expensiveLayer++      -- First access should initialize+      result <- runLayer () (service svc)+      result `shouldBe` ("expensive result" :: String)+      count <- readIORef initCount+      count `shouldBe` 1++    it "service caches initialization - multiple sequential accesses" $ do+      initCount <- newIORef (0 :: Int)+      tracker <- newResourceTracker++      let expensiveLayer = resource+            (do+              n <- atomicModifyIORef' initCount $ \n -> (n + 1, n + 1)+              trackAcquire tracker (("init-" ++ show n) :: String)+              pure $ (("result-" ++ show n) :: String))+            (\res -> trackRelease tracker res)++      let svc = mkService expensiveLayer++      -- Multiple accesses should reuse the same instance+      let multiAccessLayer = do+            r1 <- service svc+            r2 <- service svc+            r3 <- service svc+            pure (r1, r2, r3)++      (res1, res2, res3) <- runLayer () multiAccessLayer+      res1 `shouldBe` ("result-1" :: String)+      res2 `shouldBe` ("result-1" :: String)  -- Same instance+      res3 `shouldBe` ("result-1" :: String)  -- Same instance++      count <- readIORef initCount+      count `shouldBe` 1  -- Only initialized once++    it "service caches initialization - concurrent accesses" $ do+      initCount <- newIORef (0 :: Int)+      initStarted <- newEmptyMVar+      initFinish <- newEmptyMVar++      let slowLayer = resource+            (do+              putMVar initStarted ()+              takeMVar initFinish+              n <- atomicModifyIORef' initCount $ \n -> (n + 1, n + 1)+              pure $ (("concurrent-result-" ++ show n) :: String))+            (\_ -> pure ())++      let svc = mkService slowLayer++      let concurrentLayer =+            (,,,) <$> service svc <*> service svc <*> service svc <*> service svc++      resultVar <- newEmptyMVar+      void $ async $ do+        result <- runLayer () concurrentLayer+        putMVar resultVar result++      takeMVar initStarted+      putMVar initFinish ()++      (r1, r2, r3, r4) <- takeMVar resultVar++      r1 `shouldBe` ("concurrent-result-1" :: String)+      r2 `shouldBe` ("concurrent-result-1" :: String)+      r3 `shouldBe` ("concurrent-result-1" :: String)+      r4 `shouldBe` ("concurrent-result-1" :: String)++      count <- readIORef initCount+      count `shouldBe` 1++    it "service propagates initialization errors" $ do+      errorCount <- newIORef (0 :: Int)++      let failingServiceLayer :: Layer IO () Int = resource+            (do+              atomicModifyIORef' errorCount $ \n -> (n + 1, ())+              throwIO $ userError "Service initialization failed")+            (\_ -> pure ())++      let svc = mkService failingServiceLayer++      -- First access should fail+      runLayer () (service svc <|> service svc) `shouldThrow` anyException++      count <- readIORef errorCount+      count `shouldBe` 1  -- Should only try to initialize once++    it "service works with complex layer compositions" $ do+      tracker <- newResourceTracker++      -- Shared service used by multiple layers+      let sharedService = mkService $ trackedResource tracker "shared" (42 :: Int)++      -- Layer that uses the service+      let consumerLayer1 = do+            shared <- service sharedService+            trackedResource tracker (("consumer1-" ++ show shared) :: String) (("c1-" ++ show shared) :: String)++      -- Another layer that uses the same service+      let consumerLayer2 = do+            shared <- service sharedService+            trackedResource tracker (("consumer2-" ++ show shared) :: String) (("c2-" ++ show shared) :: String)++      -- Compose them together+      let composedLayer = liftA2 (,) consumerLayer1 consumerLayer2++      (r1, r2) <- runLayer () composedLayer+      r1 `shouldBe` ("c1-42" :: String)+      r2 `shouldBe` ("c2-42" :: String)++      -- Check that shared service was only initialized once+      acq <- readIORef (acquired tracker)+      length (filter (== "shared") acq) `shouldBe` 1++    it "service respects layer lifecycle" $ do+      tracker <- newResourceTracker++      let svc = mkService $ trackedResource tracker "service" ("value" :: String)++      -- Use service within a layer+      withLayer () (service svc) $ \val -> liftIO do+        val `shouldBe` ("value" :: String)+        -- Service should be acquired+        acq <- readIORef (acquired tracker)+        "service" `elem` acq `shouldBe` True+        -- But not yet released+        rel <- readIORef (released tracker)+        "service" `elem` rel `shouldBe` False++      -- After layer exits, service should be cleaned up+      rel <- readIORef (released tracker)+      "service" `elem` rel `shouldBe` True++    it "different services with same type can coexist in separate layer scopes" $ do+      initCounter <- newIORef (0 :: Int)++      let makeService name = mkService $ resource+            (do+              n <- atomicModifyIORef' initCounter $ \n -> (n + 1, n)+              pure $ ((name ++ "-" ++ show n) :: String))+            (\_ -> pure ())++      let service1 = makeService ("service1" :: String)+      let service2 = makeService ("service2" :: String)++      -- Use services in separate scopes+      result1 <- runLayer () (service service1)+      result2 <- runLayer () (service service2)++      -- Each scope gets its own cache+      result1 `shouldBe` ("service1-0" :: String)+      result2 `shouldBe` ("service2-1" :: String)++    it "service with monadic bind maintains caching" $ do+      initCount <- newIORef (0 :: Int)++      let expensiveService = mkService $ resource+            (do+              atomicModifyIORef' initCount $ \n -> (n + 1, ())+              pure (100 :: Int))+            (\_ -> pure ())++      -- Use service multiple times in monadic composition+      let layer = do+            x <- service expensiveService+            y <- service expensiveService+            z <- effect $ do+              -- Even in nested effect+              runLayer () (service expensiveService)+            pure ((x + y + z) :: Int)++      result <- runLayer () layer+      result `shouldBe` (300 :: Int)++      -- Should still only initialize once within the same layer scope+      count <- readIORef initCount+      count `shouldBe` 2  -- Once for main layer, once for nested runLayer++    it "service initialization failure doesn't prevent cleanup of other resources" $ do+      tracker <- newResourceTracker++      let goodLayer = trackedResource tracker "good" ("good-value" :: String)+      let badService :: Service IO () Int = mkService do+            () <- resource+              (do+                trackAcquire tracker ("bad" :: String)+                pure ())+              (\_ -> trackRelease tracker ("bad" :: String))++            effect $ throwIO $ userError "Bad service"++      let composedLayer = do+            good <- goodLayer+            bad <- service badService+            pure (good, bad)++      -- Should fail+      runLayer () composedLayer `shouldThrow` anyException++      -- But good resource should still be cleaned up+      rel <- readIORef (released tracker)+      "good" `elem` rel `shouldBe` True+      "bad" `elem` rel `shouldBe` True  -- Even failed initialization should clean up++  describe "Layer - bracketed function" $ do+    it "manages scoped resources correctly" $ do+      acquired <- newIORef False+      released <- newIORef False++      let scopedBracket = \use -> bracket+            (writeIORef acquired True >> pure ("resource" :: String))+            (\_ -> writeIORef released True)+            use++      let layer = bracketed scopedBracket++      withLayer () layer $ \res -> liftIO $ do+        res `shouldBe` ("resource" :: String)+        readIORef acquired >>= (`shouldBe` True)+        readIORef released >>= (`shouldBe` False)  -- Not yet released++      -- After layer exits, resource should be released+      readIORef released >>= (`shouldBe` True)++    it "keeps resource alive during layer lifetime" $ do+      ref <- newIORef (0 :: Int)++      let scopedBracket = \use -> bracket+            (modifyIORef' ref (+1) >> pure ())+            (\_ -> modifyIORef' ref (*10))+            use++      let layer = bracketed scopedBracket++      withLayer () layer $ \_ -> liftIO $ do+        -- Bracket opened, count should be 1+        count <- readIORef ref+        count `shouldBe` 1+        -- Modify it during use+        modifyIORef' ref (+5)++      -- After layer exits, should have been multiplied by 10+      readIORef ref >>= (`shouldBe` 60)  -- (1 + 5) * 10++    it "handles exceptions correctly" $ do+      acquired <- newIORef False+      released <- newIORef False++      let scopedBracket = \use -> bracket+            (writeIORef acquired True >> pure ("resource" :: String))+            (\_ -> writeIORef released True)+            use++      let layer = bracketed scopedBracket >> (effect (throwIO $ userError "boom") :: Layer IO () String)++      withLayer () layer (\_ -> pure ()) `shouldThrow` anyException++      -- Resource should still be released despite exception+      readIORef released >>= (`shouldBe` True)++    it "works with concurrent operations" $ do+      counter <- newIORef (0 :: Int)++      let scopedBracket = \use -> bracket+            (atomicModifyIORef' counter $ \n -> (n+1, n+1))+            (\_ -> atomicModifyIORef' counter $ \n -> (n*2, ()))+            use++      let layer1 = bracketed scopedBracket+      let layer2 = bracketed scopedBracket++      let composed = liftA2 (,) layer1 layer2++      (a, b) <- runLayer () composed+      -- Each bracket should get a unique counter value+      a `shouldNotBe` b++      -- Both should be released (counter doubled twice)+      -- After acquiring both: counter = 2+      -- After first release: counter = 2 * 2 = 4+      -- After second release: counter = 4 * 2 = 8+      final <- readIORef counter+      final `shouldBe` 8++    it "resource survives beyond immediate scope" $ do+      resultRef <- newIORef ("" :: String)+      let testValue = "test-value" :: String++      let scopedBracket = \use -> bracket+            (pure testValue)+            (\val -> writeIORef resultRef val)+            use++      let layer = bracketed scopedBracket++      result <- runLayer () layer+      result `shouldBe` testValue++      -- Cleanup should have recorded the value+      readIORef resultRef >>= (`shouldBe` testValue)++    it "handles nested bracketed resources" $ do+      tracker <- newResourceTracker++      let bracket1 = \use -> bracket+            (trackAcquire tracker ("outer" :: String) >> pure ("outer" :: String))+            (\_ -> trackRelease tracker ("outer" :: String))+            use++      let bracket2 = \use -> bracket+            (trackAcquire tracker ("inner" :: String) >> pure ("inner" :: String))+            (\_ -> trackRelease tracker ("inner" :: String))+            use++      let layer = do+            outer <- bracketed bracket1+            inner <- bracketed bracket2+            pure (outer, inner)++      (o, i) <- runLayer () layer+      o `shouldBe` ("outer" :: String)+      i `shouldBe` ("inner" :: String)++      -- Both should be acquired+      acq <- readIORef (acquired tracker)+      length acq `shouldBe` 2++      -- Both should be released+      rel <- readIORef (released tracker)+      length rel `shouldBe` 2++    it "propagates exception when acquire throws instead of deadlocking" $ do+      let failingBracket :: forall a. (String -> IO a) -> IO a+          failingBracket _use =+            throwIO (userError "acquire exploded")++      let layer = bracketed failingBracket+      runLayer () layer `shouldThrow` anyException++  describe "Layer - ArrowZero and ArrowPlus instances" $ do+    it "zeroArrow throws EmptyLayer exception" $ do+      let layer = zeroArrow :: Layer IO Int String+      runLayer (42 :: Int) layer `shouldThrow` anyException++    it "<+> provides fallback with zeroArrow" $ do+      tracker <- newResourceTracker+      let failing = zeroArrow :: Layer IO () String+      let success = trackedResource tracker "success" ("fallback-value" :: String)+      let combined = failing <+> success++      result <- runLayer () combined+      result `shouldBe` ("fallback-value" :: String)++      acq <- readIORef (acquired tracker)+      acq `shouldBe` ["success"]++    it "<+> tries first arrow before fallback" $ do+      tracker <- newResourceTracker+      let primary = trackedResource tracker "primary" ("primary-value" :: String)+      let fallback = trackedResource tracker "fallback" ("fallback-value" :: String)+      let combined = primary <+> fallback++      result <- runLayer () combined+      result `shouldBe` ("primary-value" :: String)++      acq <- readIORef (acquired tracker)+      "primary" `elem` acq `shouldBe` True+      "fallback" `elem` acq `shouldBe` False  -- Fallback not tried++    it "<+> cleans up failed branch" $ do+      tracker <- newResourceTracker+      let failing = trackedResource tracker "failing" () >> zeroArrow :: Layer IO () String+      let success = trackedResource tracker "success" ("ok" :: String)+      let combined = failing <+> success++      result <- runLayer () combined+      result `shouldBe` ("ok" :: String)++      acq <- readIORef (acquired tracker)+      rel <- readIORef (released tracker)+      "failing" `elem` rel `shouldBe` True  -- Failed branch cleaned up+      "success" `elem` acq `shouldBe` True++    it "<+> chains multiple alternatives" $ do+      let opt1 = zeroArrow :: Layer IO () String+      let opt2 = zeroArrow :: Layer IO () String+      let opt3 = pure ("third-time-lucky" :: String) :: Layer IO () String+      let combined = opt1 <+> opt2 <+> opt3++      result <- runLayer () combined+      result `shouldBe` ("third-time-lucky" :: String)++  describe "Layer - ArrowChoice instance" $ do+    it "left routes Left values through the arrow" $ do+      let layer = arr ((*2) :: Int -> Int) :: Layer IO Int Int+      let leftLayer = left layer :: Layer IO (Either Int String) (Either Int String)++      result <- runLayer (Left 5) leftLayer+      result `shouldBe` Left 10++    it "left passes through Right values unchanged" $ do+      let layer = arr ((*2) :: Int -> Int) :: Layer IO Int Int+      let leftLayer = left layer :: Layer IO (Either Int String) (Either Int String)++      result <- runLayer (Right ("hello" :: String)) leftLayer+      result `shouldBe` Right "hello"++    it "right routes Right values through the arrow" $ do+      let layer = arr ((++ "!") :: String -> String) :: Layer IO String String+      let rightLayer = right layer :: Layer IO (Either Int String) (Either Int String)++      result <- runLayer (Right ("hello" :: String)) rightLayer+      result `shouldBe` Right "hello!"++    it "right passes through Left values unchanged" $ do+      let layer = arr ((++ "!") :: String -> String) :: Layer IO String String+      let rightLayer = right layer :: Layer IO (Either Int String) (Either Int String)++      result <- runLayer (Left (42 :: Int)) rightLayer+      result `shouldBe` Left 42++    it "+++ applies different arrows to Left and Right" $ do+      let intLayer = arr ((*3) :: Int -> Int) :: Layer IO Int Int+      let strLayer = arr ((++ "!") :: String -> String) :: Layer IO String String+      let combined = intLayer +++ strLayer :: Layer IO (Either Int String) (Either Int String)++      resultL <- runLayer (Left 7) combined+      resultL `shouldBe` Left 21++      resultR <- runLayer (Right ("hi" :: String)) combined+      resultR `shouldBe` Right "hi!"++    it "||| merges Either into a single output" $ do+      let intToStr = arr (show :: Int -> String) :: Layer IO Int String+      let idStr = arr ((\x -> x) :: String -> String) :: Layer IO String String+      let merged = intToStr ||| idStr :: Layer IO (Either Int String) String++      result1 <- runLayer (Left 42) merged+      result1 `shouldBe` ("42" :: String)++      result2 <- runLayer (Right ("hello" :: String)) merged+      result2 `shouldBe` ("hello" :: String)++  describe "Layer - ArrowApply instance" $ do+    it "app applies layer to input" $ do+      let makeLayer n = arr ((*n) :: Int -> Int) :: Layer IO Int Int+      let dynamicLayer = app :: Layer IO (Layer IO Int Int, Int) Int++      result <- runLayer (makeLayer (5 :: Int), (7 :: Int)) dynamicLayer+      result `shouldBe` (35 :: Int)++    it "app works with resource-based layers" $ do+      tracker <- newResourceTracker+      let layer = trackedResource tracker "dynamic" (100 :: Int)+      let dynamicApply = app :: Layer IO (Layer IO () Int, ()) Int++      result <- runLayer (layer, ()) dynamicApply+      result `shouldBe` (100 :: Int)++      acq <- readIORef (acquired tracker)+      acq `shouldBe` ["dynamic"]++    it "app enables dynamic layer selection" $ do+      tracker <- newResourceTracker+      let layer1 = trackedResource tracker "layer1" ("option-a" :: String)+      let layer2 = trackedResource tracker "layer2" ("option-b" :: String)++      let selectLayer :: Bool -> Layer IO () String+          selectLayer True = layer1+          selectLayer False = layer2++      -- Test with True+      result1 <- runLayer (selectLayer True, ()) app+      result1 `shouldBe` ("option-a" :: String)++      -- Test with False+      result2 <- runLayer (selectLayer False, ()) app+      result2 `shouldBe` ("option-b" :: String)++    it "app with complex arrow composition" $ do+      let doubler = arr ((*2) :: Int -> Int) :: Layer IO Int Int+      let adder = arr ((+10) :: Int -> Int) :: Layer IO Int Int++      -- Create a layer that chooses which operation to apply+      let picker = arr (\(choice, val) ->+            if choice then (doubler, val) else (adder, val))++      let pipeline = picker >>> app++      result1 <- runLayer ((True, 5 :: Int) :: (Bool, Int)) pipeline+      result1 `shouldBe` (10 :: Int)  -- 5 * 2++      result2 <- runLayer ((False, 5 :: Int) :: (Bool, Int)) pipeline+      result2 `shouldBe` (15 :: Int)  -- 5 + 10++  describe "Layer - Strong (Profunctor) instance" $ do+    it "first' processes first element of tuple" $ do+      let layer = do n <- ask; effect $ pure ((n * 2) :: Int)+      let firstLayer = first' layer :: Layer IO (Int, String) (Int, String)++      result <- runLayer ((5 :: Int), ("test" :: String)) firstLayer+      result `shouldBe` ((10 :: Int), ("test" :: String))++    it "second' processes second element of tuple" $ do+      let layer = do s <- ask; effect $ pure ((s ++ "!") :: String)+      let secondLayer = second' layer :: Layer IO (Int, String) (Int, String)++      result <- runLayer ((42 :: Int), ("hello" :: String)) secondLayer+      result `shouldBe` ((42 :: Int), ("hello!" :: String))++    it "first' with resource management" $ do+      tracker <- newResourceTracker+      let layer = trackedResource tracker "first-resource" (100 :: Int)+      let firstLayer = first' layer++      withLayer ((), ("data" :: String)) firstLayer $ \(val, str) -> liftIO $ do+        val `shouldBe` (100 :: Int)+        str `shouldBe` ("data" :: String)+        acq <- readIORef (acquired tracker)+        acq `shouldBe` ["first-resource"]++      rel <- readIORef (released tracker)+      rel `shouldBe` ["first-resource"]++    it "second' with resource management" $ do+      tracker <- newResourceTracker+      let layer = trackedResource tracker "second-resource" ("result" :: String)+      let secondLayer = second' layer++      withLayer (("data" :: String), ()) secondLayer $ \(str, val) -> liftIO $ do+        str `shouldBe` ("data" :: String)+        val `shouldBe` ("result" :: String)++      rel <- readIORef (released tracker)+      rel `shouldBe` ["second-resource"]++  describe "Layer - Choice (Profunctor) instance" $ do+    it "left' processes Left values" $ do+      let layer = do n <- ask; effect (pure (n * 2) :: IO Int) :: Layer IO Int Int+      let leftLayer = left' layer :: Layer IO (Either Int String) (Either Int String)++      result <- runLayer (Left 5) leftLayer+      result `shouldBe` Left 10++    it "left' passes through Right values" $ do+      let layer = do n <- ask; effect (pure (n * 2) :: IO Int) :: Layer IO Int Int+      let leftLayer = left' layer :: Layer IO (Either Int String) (Either Int String)++      result <- runLayer (Right ("test" :: String) :: Either Int String) leftLayer+      result `shouldBe` (Right ("test" :: String) :: Either Int String)++    it "right' processes Right values" $ do+      let layer = do s <- ask; effect (pure (s ++ "!") :: IO String) :: Layer IO String String+      let rightLayer = right' layer :: Layer IO (Either Int String) (Either Int String)++      result <- runLayer (Right ("hello" :: String) :: Either Int String) rightLayer+      result `shouldBe` (Right ("hello!" :: String) :: Either Int String)++    it "right' passes through Left values" $ do+      let layer = do s <- ask; effect (pure (s ++ "!") :: IO String) :: Layer IO String String+      let rightLayer = right' layer :: Layer IO (Either Int String) (Either Int String)++      result <- runLayer (Left (42 :: Int) :: Either Int String) rightLayer+      result `shouldBe` (Left (42 :: Int) :: Either Int String)++    it "left' with resource management only for Left" $ do+      tracker <- newResourceTracker+      let layer = trackedResource tracker "left-resource" (100 :: Int)+      let leftLayer = left' layer++      -- Test with Left - should acquire resource+      result1 <- runLayer (Left () :: Either () String) leftLayer+      result1 `shouldBe` (Left (100 :: Int) :: Either Int String)+      acq1 <- readIORef (acquired tracker)+      acq1 `shouldBe` ["left-resource"]++      -- Clear tracker+      writeIORef (acquired tracker) []+      writeIORef (released tracker) []++      -- Test with Right - should NOT acquire resource+      result2 <- runLayer (Right ("skip" :: String) :: Either () String) leftLayer+      result2 `shouldBe` (Right ("skip" :: String) :: Either Int String)+      acq2 <- readIORef (acquired tracker)+      acq2 `shouldBe` []  -- No resource acquired++  describe "Layer - Traversing (Profunctor) instance" $ do+    it "traverse' processes list elements" $ do+      let layer = do n <- ask; effect (pure (n * 2) :: IO Int) :: Layer IO Int Int+      let travLayer = traverse' layer :: Layer IO [Int] [Int]++      result <- runLayer [1, 2, 3, 4] travLayer+      result `shouldBe` [2, 4, 6, 8]++    it "traverse' works with empty lists" $ do+      let layer = do n <- ask; effect (pure (n * 2) :: IO Int) :: Layer IO Int Int+      let travLayer = traverse' layer :: Layer IO [Int] [Int]++      result <- runLayer [] travLayer+      result `shouldBe` []++    it "traverse' works with Maybe" $ do+      let layer = do n <- ask; effect (pure (n + 10) :: IO Int) :: Layer IO Int Int+      let travLayer = traverse' layer :: Layer IO (Maybe Int) (Maybe Int)++      result1 <- runLayer (Just 5) travLayer+      result1 `shouldBe` Just 15++      result2 <- runLayer Nothing travLayer+      result2 `shouldBe` Nothing++    it "traverse' with resource management" $ do+      tracker <- newResourceTracker+      counter <- newIORef (0 :: Int)++      let layer = do+            n <- ask+            resource+              (do+                i <- atomicModifyIORef' counter $ \c -> (c+1, c)+                trackAcquire tracker (("resource-" ++ show i) :: String)+                pure ((n * 2) :: Int))+              (\_ -> pure ())++      let travLayer = traverse' layer :: Layer IO [Int] [Int]++      result <- runLayer ([1, 2, 3] :: [Int]) travLayer+      result `shouldBe` ([2, 4, 6] :: [Int])++      -- Should acquire multiple resources (one per list element)+      acq <- readIORef (acquired tracker)+      length acq `shouldBe` 3++    it "traverse' processes complex structures" $ do+      let layer = do s <- ask; effect (pure (length s) :: IO Int) :: Layer IO String Int+      let travLayer = traverse' layer :: Layer IO [String] [Int]++      result <- runLayer (["a", "bb", "ccc"] :: [String]) travLayer+      result `shouldBe` ([1, 2, 3] :: [Int])++  describe "Layer - Semigroup instance" $ do+    it "combines layers with <>" $ do+      let layer1 = pure ([1, 2, 3] :: [Int]) :: Layer IO () [Int]+      let layer2 = pure ([4, 5, 6] :: [Int]) :: Layer IO () [Int]+      let combined = layer1 <> layer2++      result <- runLayer () combined+      result `shouldBe` ([1, 2, 3, 4, 5, 6] :: [Int])++    it "respects semigroup associativity" $ property $ \(a :: Int) (b :: Int) (c :: Int) ->+      monadicIO $ do+        let l1 = pure [a] :: Layer IO () [Int]+        let l2 = pure [b] :: Layer IO () [Int]+        let l3 = pure [c] :: Layer IO () [Int]++        r1 <- run $ runLayer () ((l1 <> l2) <> l3)+        r2 <- run $ runLayer () (l1 <> (l2 <> l3))+        assert $ r1 == r2++    it "combines with resource management" $ do+      tracker <- newResourceTracker+      let layer1 = trackedResource tracker "res1" ("hello" :: String)+      let layer2 = trackedResource tracker "res2" (" world" :: String)+      let combined = liftA2 ((<>) :: String -> String -> String) layer1 layer2++      result <- runLayer () combined+      result `shouldBe` ("hello world" :: String)++      acq <- readIORef (acquired tracker)+      length acq `shouldBe` 2++    it "works with String (semigroup)" $ do+      let layer1 = pure "Hello" :: Layer IO () String+      let layer2 = pure " World" :: Layer IO () String+      let combined = layer1 <> layer2++      result <- runLayer () combined+      result `shouldBe` "Hello World"++  describe "Layer - Monoid instance" $ do+    it "mempty produces empty value" $ do+      let layer = mempty :: Layer IO () [Int]+      result <- runLayer () layer+      result `shouldBe` []++    it "mempty is left identity" $ property $ \(xs :: [Int]) ->+      monadicIO $ do+        let layer = pure xs :: Layer IO () [Int]+        r1 <- run $ runLayer () (mempty <> layer)+        r2 <- run $ runLayer () layer+        assert $ r1 == r2++    it "mempty is right identity" $ property $ \(xs :: [Int]) ->+      monadicIO $ do+        let layer = pure xs :: Layer IO () [Int]+        r1 <- run $ runLayer () (layer <> mempty)+        r2 <- run $ runLayer () layer+        assert $ r1 == r2++    it "works with String (monoid)" $ do+      let combined = mempty <> pure "test" <> mempty :: Layer IO () String+      result <- runLayer () combined+      result `shouldBe` "test"++    it "mconcat combines multiple layers" $ do+      let layers = [pure [1], pure [2], pure [3], pure [4]] :: [Layer IO () [Int]]+      let combined = mconcat layers++      result <- runLayer () combined+      result `shouldBe` [1, 2, 3, 4]++  describe "Layer - Complex Alternative/MonadPlus chains" $ do+    it "deeply nested <|> chains work correctly" $ do+      tracker <- newResourceTracker+      let opt1 = trackedResource tracker "opt1" () >> empty :: Layer IO () String+      let opt2 = trackedResource tracker "opt2" () >> empty :: Layer IO () String+      let opt3 = trackedResource tracker "opt3" () >> empty :: Layer IO () String+      let opt4 = trackedResource tracker "opt4" ("success" :: String)+      let combined = opt1 <|> opt2 <|> opt3 <|> opt4++      result <- runLayer () combined+      result `shouldBe` ("success" :: String)++      -- All failed options should be cleaned up+      rel <- readIORef (released tracker)+      length (filter (`elem` ["opt1", "opt2", "opt3"]) rel) `shouldBe` 3++    it "mzero behaves like empty" $ do+      let layer = mzero :: Layer IO () String+      runLayer () layer `shouldThrow` anyException++    it "mplus behaves like <|>" $ do+      let failing = mzero :: Layer IO () String+      let success = pure ("fallback" :: String) :: Layer IO () String+      let combined = mplus failing success++      result <- runLayer () combined+      result `shouldBe` ("fallback" :: String)++    it "Alternative with resource dependencies" $ do+      tracker <- newResourceTracker+      let primary = do+            _ <- trackedResource tracker "primary-dep" ()+            empty :: Layer IO () String+      let fallback = do+            _ <- trackedResource tracker "fallback-dep" ()+            pure ("fallback-result" :: String)+      let combined = primary <|> fallback++      result <- runLayer () combined+      result `shouldBe` ("fallback-result" :: String)++      -- Primary dependency should be cleaned up before fallback runs+      acq <- readIORef (acquired tracker)+      rel <- readIORef (released tracker)+      "primary-dep" `elem` rel `shouldBe` True+      "fallback-dep" `elem` acq `shouldBe` True++    it "all alternatives fail propagates exception" $ do+      let opt1 = empty :: Layer IO () String+      let opt2 = empty :: Layer IO () String+      let opt3 = empty :: Layer IO () String+      let combined = opt1 <|> opt2 <|> opt3++      runLayer () combined `shouldThrow` anyException++  describe "Layer - Exception during cleanup" $ do+    it "exception in finalizer doesn't prevent other cleanups" $ do+      tracker <- newResourceTracker+      let layer1 = resource+            (do+              trackAcquire tracker ("res1" :: String)+              pure ("res1" :: String))+            (\_ -> do+              trackRelease tracker ("res1" :: String)+              throwIO $ userError "cleanup1 failed") :: Layer IO () String++      let layer2 = resource+            (do+              trackAcquire tracker ("res2" :: String)+              pure ("res2" :: String))+            (\_ -> trackRelease tracker ("res2" :: String)) :: Layer IO () String++      let combined = liftA2 (,) layer1 layer2++      -- The cleanup exception should propagate+      runLayer () combined `shouldThrow` anyException++      -- But both should attempt cleanup+      rel <- readIORef (released tracker)+      "res1" `elem` rel `shouldBe` True+      -- Note: res2 cleanup behavior depends on exception handling order++    it "exception in use phase still triggers cleanup" $ do+      tracker <- newResourceTracker+      let layer = trackedResource tracker "resource" ("value" :: String)++      withLayer () layer (\_ -> liftIO $ throwIO $ userError "use failed") `shouldThrow` anyException++      -- Resource should still be cleaned up+      rel <- readIORef (released tracker)+      "resource" `elem` rel `shouldBe` True++    it "multiple concurrent exceptions in zipLayer" $ do+      tracker <- newResourceTracker+      gate1 <- newEmptyMVar+      gate2 <- newEmptyMVar+      let layer1 = do+            _ <- trackedResource tracker "res1" ()+            effect (do+              putMVar gate1 ()+              takeMVar gate2+              throwIO (userError "error1")) :: Layer IO () String+      let layer2 = do+            _ <- trackedResource tracker "res2" ()+            effect (do+              putMVar gate2 ()+              takeMVar gate1+              throwIO (userError "error2")) :: Layer IO () String++      let combined = zipLayer layer1 layer2++      runLayer ((), ()) combined `shouldThrow` anyException++      rel <- readIORef (released tracker)+      "res1" `elem` rel `shouldBe` True+      "res2" `elem` rel `shouldBe` True++    it "exception in one zipLayer branch cleans up both" $ do+      tracker <- newResourceTracker+      let successLayer = trackedResource tracker "success" ("ok" :: String)+      let failLayer = trackedResource tracker "failing" () >> effect (throwIO $ userError "boom") :: Layer IO () String++      let combined = zipLayer successLayer failLayer++      runLayer ((), ()) combined `shouldThrow` anyException++      rel <- readIORef (released tracker)+      "success" `elem` rel `shouldBe` True+      "failing" `elem` rel `shouldBe` True++  describe "Layer - mapLayer" $ do+    it "transforms dependencies before layer runs" $ do+      let layer = do n <- ask; effect $ pure (n * 2 :: Int)+      let add10 = (+ 10) :: Int -> Int+      let mapped = mapLayer add10 layer+      result <- runLayer (5 :: Int) mapped+      result `shouldBe` (30 :: Int)++    it "mapLayer with resource management" $ do+      tracker <- newResourceTracker+      let layer = do+            n <- ask+            resource+              (do+                trackAcquire tracker "mapped-res"+                pure (n + 100 :: Int))+              (\_ -> trackRelease tracker "mapped-res")+      let mapped = mapLayer ((*3) :: Int -> Int) layer++      withLayer (7 :: Int) mapped $ \val -> liftIO $+        val `shouldBe` (121 :: Int)++      rel <- readIORef (released tracker)+      rel `shouldBe` ["mapped-res"]++  describe "Layer - unsafeMkLayer" $ do+    it "creates a layer from a ResourceT action" $ do+      let layer = unsafeMkLayer (\n -> pure (n * 3 :: Int)) :: Layer IO Int Int+      result <- runLayer (14 :: Int) layer+      result `shouldBe` (42 :: Int)++    it "unsafeMkLayer ignores interceptor" $ do+      ref <- newIORef (0 :: Int)+      let layer = unsafeMkLayer (\() -> do+            liftIO $ modifyIORef' ref (+ 1)+            pure (42 :: Int)) :: Layer IO () Int++      result <- runLayer () layer+      result `shouldBe` (42 :: Int)+      readIORef ref >>= (`shouldBe` 1)++  describe "Layer - uncached accessor" $ do+    it "extracts the underlying layer from a service" $ do+      let layer = effect $ pure (42 :: Int)+      let svc = mkService layer+      result <- runLayer () (uncached svc)+      result `shouldBe` (42 :: Int)++    it "uncached layer is not cached" $ do+      counter <- newIORef (0 :: Int)+      let layer = effect $ do+            atomicModifyIORef' counter $ \n -> (n + 1, n + 1)+      let svc = mkService layer+      let multiAccess = do+            a <- uncached svc+            b <- uncached svc+            pure (a, b)+      (r1, r2) <- runLayer () multiAccess+      r1 `shouldBe` (1 :: Int)+      r2 `shouldBe` (2 :: Int)++  describe "Layer - Profunctor lmap/rmap" $ do+    it "lmap transforms input" $ do+      let layer = do n <- ask; effect $ pure (n + 1 :: Int)+      let mapped = lmap ((*2) :: Int -> Int) layer+      result <- runLayer (5 :: Int) mapped+      result `shouldBe` (11 :: Int)++    it "rmap transforms output" $ do+      let layer = do n <- ask; effect $ pure (n + 1 :: Int)+      let mapped = P.rmap ((*3) :: Int -> Int) layer+      result <- runLayer (5 :: Int) mapped+      result `shouldBe` (18 :: Int)++  describe "Layer - Async exception safety" $ do+    it "async exception during layer build triggers resource cleanup" $ do+      tracker <- newResourceTracker+      cleanupDone <- newEmptyMVar+      readyForException <- newEmptyMVar+      let layer = resource+            (do+              trackAcquire tracker "async-resource"+              pure ("resource" :: String))+            (\_ -> do+              trackRelease tracker "async-resource"+              putMVar cleanupDone ())++      tid <- myThreadId+      void $ async $ do+        takeMVar readyForException+        E.throwTo tid ThreadKilled++      let action = withLayer () layer $ \val -> liftIO $ do+            val `shouldBe` ("resource" :: String)+            putMVar readyForException ()+            takeMVar cleanupDone++      action `shouldThrow` (\e -> case fromException e of+        Just ThreadKilled -> True+        _ -> False)++      rel <- readIORef (released tracker)+      "async-resource" `elem` rel `shouldBe` True++    it "mask protects critical sections in zipLayer" $ do+      tracker <- newResourceTracker+      let layer1 = trackedResource tracker "zip-a" ("a" :: String)+      let layer2 = trackedResource tracker "zip-b" ("b" :: String)+      let combined = zipLayer layer1 layer2++      (a, b) <- runLayer ((), ()) combined+      a `shouldBe` "a"+      b `shouldBe` "b"++  describe "Layer - Selective instance" $ do+    it "selectM works" $ do+      let layer = pure (Right (42 :: Int)) >>= \case+            Left f -> pure (f (0 :: Int))+            Right x -> pure x+      result <- runLayer () (layer :: Layer IO () Int)+      result `shouldBe` (42 :: Int)++  describe "Layer - composeLayer" $ do+    it "composes two layers sequentially" $ do+      let upper = effect $ pure (10 :: Int)+      let lower = do n <- ask; effect $ pure (n * 2 :: Int)+      let composed = composeLayer upper lower+      result <- runLayer () composed+      result `shouldBe` (20 :: Int)++    it "composeLayer preserves resource management" $ do+      tracker <- newResourceTracker+      let upper = trackedResource tracker "upper" (5 :: Int)+      let lower = do+            n <- ask+            resource+              (do+                trackAcquire tracker "lower"+                pure (n + 10 :: Int))+              (\_ -> trackRelease tracker "lower")+      let composed = composeLayer upper lower+      withLayer () composed $ \val -> liftIO $+        val `shouldBe` (15 :: Int)+      rel <- readIORef (released tracker)+      "upper" `elem` rel `shouldBe` True+      "lower" `elem` rel `shouldBe` True++  describe "Layer - Monad laws (property-based)" $ do+    it "left identity: return a >>= f  ===  f a" $ property $ \(n :: Int) ->+      monadicIO $ do+        let f x = pure (x * 2) :: Layer IO () Int+        r1 <- run $ runLayer () (return n >>= f)+        r2 <- run $ runLayer () (f n)+        assert $ r1 == r2++    it "right identity: m >>= return  ===  m" $ property $ \(n :: Int) ->+      monadicIO $ do+        let m = pure n :: Layer IO () Int+        r1 <- run $ runLayer () (m >>= return)+        r2 <- run $ runLayer () m+        assert $ r1 == r2++    it "associativity: (m >>= f) >>= g  ===  m >>= (\\x -> f x >>= g)" $ property $ \(n :: Int) ->+      monadicIO $ do+        let m = pure n :: Layer IO () Int+        let f x = pure (x + 1) :: Layer IO () Int+        let g x = pure (x * 2) :: Layer IO () Int+        r1 <- run $ runLayer () ((m >>= f) >>= g)+        r2 <- run $ runLayer () (m >>= (\x -> f x >>= g))+        assert $ r1 == r2++  describe "Layer - Arrow laws (property-based)" $ do+    it "arr id === id" $ property $ \(n :: Int) ->+      monadicIO $ do+        r1 <- run $ runLayer n (arr id :: Layer IO Int Int)+        r2 <- run $ runLayer n (id :: Layer IO Int Int)+        assert $ r1 == r2++    it "arr (f >>> g) === arr f >>> arr g" $ property $ \(n :: Int) ->+      monadicIO $ do+        let f = (+1) :: Int -> Int+        let g = (*2) :: Int -> Int+        let gf x = g (f x)+        r1 <- run $ runLayer n (arr gf :: Layer IO Int Int)+        r2 <- run $ runLayer n ((arr f :: Layer IO Int Int) >>> (arr g :: Layer IO Int Int))+        assert $ r1 == r2++  describe "Layer - withLayerAndInterceptor" $ do+    it "runs a layer with custom interceptor" $ do+      ref <- newIORef ([] :: [String])+      let interceptor = nullInterceptor+            { onEffectRun = \ctx -> modifyIORef ref (++ [show (operationName ctx)])+            }+      let layer = effect @IO @() @Int $ pure 42+      withLayerAndInterceptor interceptor () layer $ \val -> liftIO $+        val `shouldBe` (42 :: Int)+      logs <- readIORef ref+      length logs `shouldBe` 1++  describe "Layer - runLayerWithInterceptor" $ do+    it "runs a layer and returns value with interceptor" $ do+      ref <- newIORef ([] :: [String])+      let interceptor = nullInterceptor+            { onResourceAcquire = \ctx -> modifyIORef ref (++ ["acquire:" ++ show (operationName ctx)])+            , onResourceRelease = \_ -> modifyIORef ref (++ ["release"])+            }+      let layer = resource @IO @() @String+            (pure "hello")+            (\_ -> pure ())+      result <- runLayerWithInterceptor interceptor () layer+      result `shouldBe` ("hello" :: String)+      logs <- readIORef ref+      logs `shouldContain` ["release"]++  describe "Layer - Interceptor timing correctness" $ do+    it "onResourceRelease fires at actual release time, not acquisition time" $ do+      ref <- newIORef ([] :: [String])+      let interceptor = nullInterceptor+            { onResourceAcquire = \_ -> modifyIORef ref (++ ["acquire"])+            , onResourceRelease = \_ -> modifyIORef ref (++ ["release"])+            }+      let layer = resource @IO @() @String+            (pure "hello")+            (\_ -> pure ())+      withLayerAndInterceptor interceptor () layer $ \val -> liftIO $ do+        val `shouldBe` ("hello" :: String)+        logs <- readIORef ref+        logs `shouldBe` ["acquire"]+        logs `shouldNotContain` ["release"]+      logs <- readIORef ref+      logs `shouldBe` ["acquire", "release"]++  describe "Layer - EmptyLayer Show and Exception" $ do+    it "show EmptyLayer" $+      show EmptyLayer `shouldBe` "EmptyLayer"++    it "showList for EmptyLayer" $ do+      let s = show [EmptyLayer, EmptyLayer]+      s `shouldContain` "EmptyLayer"++    it "displayException for EmptyLayer" $ do+      let e = toException EmptyLayer+      displayException (e :: SomeException) `shouldContain` "EmptyLayer"++    it "fromException round-trips" $ do+      let e = toException EmptyLayer+      case fromException e of+        Just EmptyLayer -> pure ()+        Nothing -> expectationFailure "fromException failed"++  describe "Layer - Applicative <* and *> and <$" $ do+    it "*> discards left value" $ do+      let layer = pure (1 :: Int) *> pure (2 :: Int) :: Layer IO () Int+      result <- runLayer () layer+      result `shouldBe` (2 :: Int)++    it "<* discards right value" $ do+      let layer = pure (1 :: Int) <* pure (2 :: Int) :: Layer IO () Int+      result <- runLayer () layer+      result `shouldBe` (1 :: Int)++    it "<$ replaces value" $ do+      let layer = (99 :: Int) <$ pure ("ignored" :: String) :: Layer IO () Int+      result <- runLayer () layer+      result `shouldBe` (99 :: Int)++  describe "Layer - Semigroup stimes/sconcat" $ do+    it "stimes repeats the semigroup operation" $ do+      let layer = pure [1 :: Int] :: Layer IO () [Int]+      let repeated = stimes (3 :: Int) layer+      result <- runLayer () repeated+      result `shouldBe` [1, 1, 1]++    it "sconcat folds non-empty list" $ do+      let layers = pure [1 :: Int] :| [pure [2], pure [3]]+      let combined = sconcat layers :: Layer IO () [Int]+      result <- runLayer () combined+      result `shouldBe` [1, 2, 3]++  describe "Layer - Monoid mappend/mconcat" $ do+    it "mappend combines two layers" $ do+      let l1 = pure [1 :: Int] :: Layer IO () [Int]+      let l2 = pure [2 :: Int] :: Layer IO () [Int]+      result <- runLayer () (mappend l1 l2)+      result `shouldBe` [1, 2]++    it "mconcat combines list of layers" $ do+      let layers = [pure [1], pure [2], pure [3]] :: [Layer IO () [Int]]+      result <- runLayer () (mconcat layers)+      result `shouldBe` [1, 2, 3]++  describe "Layer - Selective select" $ do+    it "select passes through Right" $ do+      let condLayer = pure (Right (42 :: Int)) :: Layer IO () (Either Int Int)+      let funcLayer = pure ((*2) :: Int -> Int) :: Layer IO () (Int -> Int)+      result <- runLayer () (S.select condLayer funcLayer)+      result `shouldBe` (42 :: Int)++    it "select applies function on Left" $ do+      let condLayer = pure (Left (7 :: Int)) :: Layer IO () (Either Int Int)+      let funcLayer = pure ((*3) :: Int -> Int) :: Layer IO () (Int -> Int)+      result <- runLayer () (S.select condLayer funcLayer)+      result `shouldBe` (21 :: Int)++  describe "Layer - MonadReader reader" $ do+    it "reader maps over the environment" $ do+      let layer = reader (port :: Config -> Int) :: Layer IO Config Int+      result <- runLayer (Config 8080 "host") layer+      result `shouldBe` 8080++  describe "Layer - Profunctor composition" $ do+    it "Category composition chains layers" $ do+      let layer1 = do n <- ask; effect $ pure (n + 1 :: Int)+      let layer2 = do n <- ask; effect $ pure (n * 2 :: Int)+      let composed = layer2 . layer1+      result <- runLayer (5 :: Int) composed+      result `shouldBe` (12 :: Int)++  describe "Layer - Traversing wander" $ do+    it "wander processes traversable structure" $ do+      let layer = do n <- ask; effect (pure (n * 10 :: Int)) :: Layer IO Int Int+      let wandered = traverse' layer :: Layer IO [Int] [Int]+      result <- runLayer [1, 2, 3] wandered+      result `shouldBe` [10, 20, 30]

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}