diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 diff --git a/fractal-layer.cabal b/fractal-layer.cabal new file mode 100644 --- /dev/null +++ b/fractal-layer.cabal @@ -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 diff --git a/src/Fractal/Layer.hs b/src/Fractal/Layer.hs new file mode 100644 --- /dev/null +++ b/src/Fractal/Layer.hs @@ -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@ +-- (), 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 diff --git a/src/Fractal/Layer/Diagnostics.hs b/src/Fractal/Layer/Diagnostics.hs new file mode 100644 --- /dev/null +++ b/src/Fractal/Layer/Diagnostics.hs @@ -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 + diff --git a/src/Fractal/Layer/Interceptor.hs b/src/Fractal/Layer/Interceptor.hs new file mode 100644 --- /dev/null +++ b/src/Fractal/Layer/Interceptor.hs @@ -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} diff --git a/src/Fractal/Layer/Internal.hs b/src/Fractal/Layer/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Fractal/Layer/Internal.hs @@ -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 diff --git a/test/Fractal/Layer/DiagnosticsSpec.hs b/test/Fractal/Layer/DiagnosticsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Fractal/Layer/DiagnosticsSpec.hs @@ -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" diff --git a/test/Fractal/Layer/InterceptorSpec.hs b/test/Fractal/Layer/InterceptorSpec.hs new file mode 100644 --- /dev/null +++ b/test/Fractal/Layer/InterceptorSpec.hs @@ -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" diff --git a/test/Fractal/Layer/LayerSpec.hs b/test/Fractal/Layer/LayerSpec.hs new file mode 100644 --- /dev/null +++ b/test/Fractal/Layer/LayerSpec.hs @@ -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] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}