fractal-layer-0.1.0.0: test/Fractal/Layer/LayerSpec.hs
{-# 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]