cauldron (empty) → 0.4.0.0
raw patch · 9 files changed
+2046/−0 lines, 9 filesdep +algebraic-graphsdep +basedep +bytestring
Dependencies added: algebraic-graphs, base, bytestring, cauldron, containers, multicurryable, sop-core, tasty, tasty-hunit, text, transformers
Files
- CHANGELOG.md +31/−0
- LICENSE +30/−0
- app/Main.hs +240/−0
- cauldron.cabal +77/−0
- lib/Cauldron.hs +1081/−0
- lib/Cauldron/Managed.hs +77/−0
- test/appTests.hs +159/−0
- test/managedTests.hs +109/−0
- test/tests.hs +242/−0
+ CHANGELOG.md view
@@ -0,0 +1,31 @@+# Revision history for cauldron++## 0.4.0.0++* `exportToDot` takes a new parameter to configure how to print the steps. Before, only the TyCon was printed. Now, the full type is printed by default.++## 0.3.1.0 ++* Now the `MissingDependencies` only includes keys with actual missing dependencies.++## 0.3.0.0 ++* Add `cookNonEmpty` and `cookTree` for cooking hierarchies of 'Cauldron's.+* Rename `addLast` to `addOuter` and `addFirst` to `addInner`.+* Add a copy of the `Managed` type from ["managed"](https://hackage.haskell.org/package/managed).+* Change the nomenclature of the `pack-` related functions.+* Add the `Packer` type.+* Add `Fire` type to customize the handling of dependency cycles.++## 0.2.0.0 ++* Decorators are no longer `Endo`s. They just take the decorated entity as a + regular parameter.++* Remove the applicative wrappers.++* Allow effectful constructors.++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2023, Daniel Diaz++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * 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.++ * Neither the name of Daniel Diaz nor the names of other+ 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+OWNER 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.
+ app/Main.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DerivingStrategies #-}++-- | We have a bunch of datatypes, and a single recipe (constructor) for each+-- datatype. This means the wiring can be type-directed: we don't have to make a+-- decision at the term level about which constructor to use.+--+-- We wire the constructors in two ways: manually, and using a bit of dynamic+-- typing magic from the "Cauldron" module.+module Main where++import Cauldron+import Data.Function ((&))+import Data.Maybe (fromJust)++{-+ HERE ARE A BUNCH OF DATATYPES.++ The idea is that each datatype represents a bean, a component of our application.++ In a real application, these datatypes would be records containing effectful functions.++-}++data A = A deriving (Show)++data B = B deriving (Show)++data C = C deriving (Show)++data D = D deriving (Show)++data E = E deriving (Show)++data F = F deriving (Show)++data G = G deriving (Show)++data H = H deriving (Show)++data I = I deriving (Show)++data J = J deriving (Show)++data K = K deriving (Show)++data L = L deriving (Show)++data M = M deriving (Show)++data N = N deriving (Show)++data O = O deriving (Show)++data P = P deriving (Show)++data Q = Q deriving (Show)++data R = R deriving (Show)++data S = S deriving (Show)++data T = T deriving (Show)++data U = U deriving (Show)++data V = V deriving (Show)++data W = W deriving (Show)++data X = X deriving (Show)++data Y = Y deriving (Show)++data Z = Z deriving (Show)++{-+ These beans are a bit special: they are "secondary" beans which are optionally+ produced by the constructors of other beans.++ They have Monoid instances. The values returned by all the constructors that+ produce them will be combined.+-}++-- | A window into the internal state of some bean.+newtype Inspector = Inspector {inspect :: IO [String]}+ deriving newtype (Semigroup, Monoid)++-- | And initialization action which some beans might register.+newtype Initializer = Initializer {runInitializer :: IO ()}+ deriving newtype (Semigroup, Monoid)++{-+ HERE ARE A BUNCH OF CONSTRUCTORS AND DECORATORS.++-}+makeA :: A+makeA = A++-- A bean with a monoidal registration.+--+-- The registration could be some generic introspection mechanism, or perhaps+-- some effectful action that sets up a worker thread.+makeB :: (Inspector, B)+makeB = (Inspector (pure ["B stuff"]), B)++makeC :: C+makeC = C++makeD :: D+makeD = D++makeE :: A -> E+makeE = \_ -> E++makeF :: B -> C -> (Inspector, F)+makeF = \_ _ -> (Inspector (pure ["F stuff"]), F)++-- | A bean with a self-dependency!+--+-- We need this if we want self-invocations to be decorated.+--+-- Dependency cycles of more than one bean are forbidden, however.+makeG :: E -> F -> G -> G+makeG _ _ !_ = G++-- | A decorator.+--+-- Decorators are basically normal constructors, only that they return+-- a Endo that knows how to tweak the value of a bean.+--+-- Because they are normal constructors, they can be effectful, and they+-- might have dependencies of their own.+makeGDeco1 :: A -> G -> G+makeGDeco1 _ g = g++-- | A bean with two monoidal registrations.+makeH :: A -> D -> G -> (Initializer, Inspector, H)+makeH _ _ _ = (Initializer (putStrLn "H init"), Inspector (pure ["H stuff"]), H)++-- | Notice that this bean has "Inspector" as a dependency. Inspector is a+-- monoidal bean which is aggregated across all the constructor that register+-- it. This is OK as long as there are no dependency cycles.+--+-- Why would a bean depend on such a aggregated bean? Well, for example, a+-- server bean might want to publish diagnostic information collected from beans+-- that register it.+makeZ :: Inspector -> D -> H -> Z+makeZ _ _ _ = Z++makeZDeco1 :: B -> E -> Z -> Z+makeZDeco1 _ _ z = z++-- | A decorator with a monoidal registration.+makeZDeco2 :: (F -> Z -> (Initializer, Z))+makeZDeco2 = \_ z -> (Initializer (putStrLn "Z deco init"), z)++boringWiring :: IO (Initializer, Inspector, Z)+boringWiring = do+ let -- We have to remember to collect the monoidal registrations.+ initializer = init1 <> init2+ -- We have to remember to collect the monoidal registrations.+ inspector = inspector1 <> inspector2 <> inspector3+ -- Now let's tie the constructors together.+ a = makeA+ (inspector1, b) = makeB+ c = makeC+ d = makeD+ e = makeE a+ (inspector2, f) = makeF b c+ g0 = makeG e f g+ g1 = makeGDeco1 a g0+ g = g1+ -- Here we apply a single decorator.+ (init1, inspector3, h) = makeH a d g+ -- Compose the decorators before applying them.+ z0 = makeZ inspector d h+ z1 = makeZDeco1 b e z0+ (init2, z2) = makeZDeco2 f z1+ z = z2+ pure (initializer, inspector, z)++-- | Here we don't have to worry about positional parameters. We throw all the+-- constructors into the 'Cauldron' and taste the bean values at the end, plus a+-- graph we may want to draw.+--+-- Note that we detect wiring errors *before* running the effectful constructors.+coolWiring :: Fire IO -> Either BadBeans (DependencyGraph, IO (Initializer, Inspector, Z))+coolWiring fire = do+ let cauldron :: Cauldron IO =+ mempty+ & insert @A do makeBean do pack value makeA+ & insert @B do makeBean do pack (valueWith \(reg, bean) -> regs1 reg bean) do makeB+ & insert @C do makeBean do pack value makeC+ & insert @D do makeBean do pack value makeD+ & insert @E do makeBean do pack value makeE+ & insert @F do makeBean do pack (valueWith \(reg, bean) -> regs1 reg bean) do makeF+ & insert @G do+ Bean+ { constructor = pack value makeG,+ decos =+ fromConstructors+ [ pack value makeGDeco1+ ]+ }+ & insert @H do makeBean do pack (valueWith \(reg1, reg2, bean) -> regs2 reg1 reg2 bean) do makeH+ & insert @Z do+ Bean+ { constructor = pack value makeZ,+ decos =+ fromConstructors+ [ pack value makeZDeco1,+ pack (valueWith \(reg, bean) -> regs1 reg bean) do makeZDeco2+ ]+ }+ & insert @(Initializer, Inspector, Z) do makeBean do pack value \a b c -> (a, b, c)+ fmap (fmap (fmap (fromJust . taste @(Initializer, Inspector, Z)))) do cook fire cauldron++main :: IO ()+main = do+ do+ (Initializer {runInitializer}, Inspector {inspect}, z) <- boringWiring+ inspection <- inspect+ print inspection+ print z+ runInitializer+ case coolWiring allowSelfDeps of+ Left badBeans -> do+ print badBeans+ Right (depGraph, action) -> do+ exportToDot defaultStepToText "beans.dot" depGraph+ exportToDot defaultStepToText "beans-no-agg.dot" do removeSecondaryBeans do depGraph+ exportToDot defaultStepToText "beans-no-agg-no-decos.dot" do removeDecos do removeSecondaryBeans do depGraph+ exportToDot defaultStepToText "beans-simple.dot" do collapsePrimaryBeans do removeDecos do removeSecondaryBeans do depGraph+ exportToDot defaultStepToText "beans-simple-with-decos.dot" do collapsePrimaryBeans do removeSecondaryBeans do depGraph+ (Initializer {runInitializer}, Inspector {inspect}, z) <- action+ inspection <- inspect+ print inspection+ print z+ runInitializer
+ cauldron.cabal view
@@ -0,0 +1,77 @@+cabal-version: 3.4+name: cauldron+version: 0.4.0.0+synopsis: Toy dependency injection framework+description: Toy dependency injection framework that wires things at runtime.+license: BSD-3-Clause+license-file: LICENSE+author: diaz_carrete@yahoo.com+maintainer: Daniel Díaz+-- copyright:+build-type: Simple+extra-doc-files: CHANGELOG.md+-- extra-source-files:+category: Dependency Injection+tested-with: GHC ==9.8.1 || ==9.6.3+source-repository head+ type: git+ location: https://github.com/danidiaz/cauldron.git++common common-base+ build-depends:+ base >= 4.18.0 && < 5,+ ghc-options: -Wall+ default-language: GHC2021++common common-lib+ import: common-base+ build-depends:+ containers >= 0.5.0 && < 0.8,+ text >= 2.0 && < 2.2,++common common-tests+ import: common-lib+ build-depends:+ tasty ^>= 1.5,+ tasty-hunit ^>= 0.10,+ transformers >= 0.5 && < 0.7,+ cauldron,++library+ import: common-lib+ build-depends:+ algebraic-graphs ^>= 0.7,+ multicurryable ^>= 0.1.1.0,+ bytestring >= 0.10.0 && < 0.13,+ sop-core >= 0.5.0 && < 0.6,+ hs-source-dirs: lib+ exposed-modules: + Cauldron+ Cauldron.Managed++executable cauldron-example-wiring+ import: common-base+ main-is: Main.hs+ build-depends:+ cauldron,++ hs-source-dirs: app++test-suite tests+ import: common-tests+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: tests.hs++test-suite app-tests+ import: common-tests+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: appTests.hs++test-suite tests-managed+ import: common-tests+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: managedTests.hs+
+ lib/Cauldron.hs view
@@ -0,0 +1,1081 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NoFieldSelectors #-}++-- | This is a library for performing dependency injection. It's an alternative+-- to manually wiring your functions and passing all required parameters+-- explicitly. Instead of that, you throw your functions into a 'Cauldron', which wires+-- them for you, guiding itself by the types.+--+-- Wiring errors are detected at runtime, not at compile time.+--+-- This library should be used at the ["composition root"](https://stackoverflow.com/questions/6277771/what-is-a-composition-root-in-the-context-of-dependency-injection) of the application,+-- and only there: the components we are wiring together need not be aware that the library exists.+--+-- >>> :{+-- data A = A deriving Show+-- data B = B deriving Show+-- data C = C deriving Show+-- makeA :: A+-- makeA = A+-- makeB :: A -> B+-- makeB = \_ -> B+-- makeC :: A -> B -> IO C+-- makeC = \_ _ -> pure C+-- :}+--+-- >>> :{+-- do+-- let cauldron :: Cauldron IO+-- cauldron =+-- emptyCauldron+-- & insert @A do makeBean do pack value makeA+-- & insert @B do makeBean do pack value makeB+-- & insert @C do makeBean do pack effect makeC+-- Right (_ :: DependencyGraph, action) = cook forbidDepCycles cauldron+-- beans <- action+-- pure do taste @C beans+-- :}+-- Just C+module Cauldron+ ( -- * Filling the cauldron+ Cauldron,+ emptyCauldron,+ insert,+ adjust,+ delete,+ hoistCauldron,++ -- * Beans+ Bean (..),+ makeBean,+ setConstructor,+ setDecos,+ overDecos,+ hoistBean,++ -- ** Decorators+ -- $decos+ Decos,+ emptyDecos,+ fromConstructors,+ addOuter,+ addInner,+ hoistDecos,++ -- ** Constructors+ -- $constructors+ Constructor,+ pack,+ pack0,+ pack1,+ pack2,+ pack3,+ hoistConstructor,+ Packer (..),+ value,+ effect,++ -- *** Registering secondary beans+ -- $registrations+ valueWith,+ effectWith,+ Regs,+ regs0,+ regs1,+ regs2,+ regs3,++ -- * Cooking the beans+ cook,+ cookNonEmpty,+ cookTree,++ -- ** How loopy can we get?+ Fire,+ forbidDepCycles,+ allowSelfDeps,++ -- ** Tasting the results+ BoiledBeans,+ taste,+ BadBeans (..),+ PathToCauldron,++ -- ** Drawing deps+ DependencyGraph,+ exportToDot,+ defaultStepToText,+ BeanConstructionStep (..),+ removeSecondaryBeans,+ removeDecos,+ collapsePrimaryBeans,+ toAdjacencyMap,+ )+where++import Algebra.Graph.AdjacencyMap (AdjacencyMap)+import Algebra.Graph.AdjacencyMap qualified as Graph+import Algebra.Graph.AdjacencyMap.Algorithm qualified as Graph+import Algebra.Graph.Export.Dot qualified as Dot+import Control.Applicative+import Control.Monad.Fix+import Data.Bifunctor (first)+import Data.ByteString qualified+import Data.Dynamic+import Data.Foldable qualified+import Data.Functor (($>), (<&>))+import Data.Functor.Compose+import Data.Functor.Contravariant+import Data.Kind+import Data.List.NonEmpty (NonEmpty)+import Data.List.NonEmpty qualified+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe (fromJust)+import Data.Monoid (Endo (..))+import Data.SOP (All, And, K (..))+import Data.SOP.NP+import Data.Sequence (Seq)+import Data.Sequence qualified as Seq+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text qualified+import Data.Text.Encoding qualified+import Data.Tree+import Data.Type.Equality (testEquality)+import Data.Typeable+import GHC.Exts (IsList (..))+import Multicurryable+import Type.Reflection qualified++-- | A map of 'Bean' recipes. Parameterized by the monad @m@ in which the 'Bean'+-- 'Constructor's might have effects.+newtype Cauldron m where+ Cauldron :: {recipes :: Map TypeRep (SomeBean m)} -> Cauldron m++-- | Union of two 'Cauldron's, right-biased: prefers values from the /right/ cauldron when+-- both contain the same bean. (Note that 'Data.Map.Map' is left-biased.)+instance Semigroup (Cauldron m) where+ Cauldron {recipes = r1} <> Cauldron {recipes = r2} = Cauldron do Map.unionWith (flip const) r1 r2++instance Monoid (Cauldron m) where+ mempty = Cauldron do Map.empty++emptyCauldron :: Cauldron m+emptyCauldron = mempty++-- | Change the monad used by the beans in the 'Cauldron'.+hoistCauldron :: (forall x. m x -> n x) -> Cauldron m -> Cauldron n+hoistCauldron f (Cauldron {recipes}) = Cauldron {recipes = hoistSomeBean f <$> recipes}++data SomeBean m where+ SomeBean :: (Typeable bean) => Bean m bean -> SomeBean m++hoistSomeBean :: (forall x. m x -> n x) -> SomeBean m -> SomeBean n+hoistSomeBean f (SomeBean bean) = SomeBean do hoistBean f bean++-- | A bean recipe, to be inserted into a 'Cauldron'.+data Bean m bean where+ Bean ::+ { -- | How to build the bean itself.+ constructor :: Constructor m bean,+ -- | How to build the decorators that wrap the bean. There might be no decorators.+ decos :: Decos m bean+ } ->+ Bean m bean++-- | Change the monad used by the bean\'s 'Constructor' and its 'Decos'.+hoistBean :: (forall x. m x -> n x) -> Bean m bean -> Bean n bean+hoistBean f (Bean {constructor, decos}) =+ Bean+ { constructor = hoistConstructor f constructor,+ decos = hoistDecos f decos+ }++-- | A 'Bean' without decorators, having only the main constructor.+makeBean :: Constructor m a -> Bean m a+makeBean constructor = Bean {constructor, decos = mempty}++-- $decos+--+-- Decorators are 'Constructor's which, instead constructing the original+-- version of a bean, they modify it in some way (but without changing its+-- type). Because they modify the bean, typically decorators will take the bean+-- as an argument.+--+-- Decorators can have other dependencies beyond the modified bean.+--+-- When the bean is a record-of-functions, decorators can be used to+-- add behaviors like caching, logging... to the functions.+--+--+-- >>> :{+-- newtype Foo = Foo { sayFoo :: IO () }+-- makeFoo :: Foo+-- makeFoo = Foo { sayFoo = putStrLn "foo" }+-- makeFooDeco1 :: Foo -> Foo+-- makeFooDeco1 Foo { sayFoo } = Foo { sayFoo = putStrLn "deco1 enter" >> sayFoo >> putStrLn "deco1 exit" }+-- makeFooDeco2 :: Foo -> IO Foo+-- makeFooDeco2 Foo { sayFoo } = putStrLn "deco2 init" >> pure Foo { sayFoo = putStrLn "deco2 enter" >> sayFoo >> putStrLn "deco2 exit" }+-- :}+--+-- >>> :{+-- do+-- let cauldron :: Cauldron IO+-- cauldron =+-- emptyCauldron+-- & insert @Foo+-- Bean {+-- constructor = pack value makeFoo,+-- decos = fromConstructors [+-- pack value makeFooDeco1,+-- pack effect makeFooDeco2+-- ]+-- }+-- Right (_ :: DependencyGraph, action) = cook forbidDepCycles cauldron+-- beans <- action+-- let Just Foo {sayFoo} = taste beans+-- sayFoo+-- :}+-- deco2 init+-- deco2 enter+-- deco1 enter+-- foo+-- deco1 exit+-- deco2 exit++-- | A list of 'Constructor's for the decorators of some 'Bean'.+--+-- 'Constructor's for a decorator will have the @bean@ itself among their+-- arguments. That @bean@ argument will be either the \"bare\" undecorated+-- bean (for the first decorator) or the result of applying the previous+-- decorator in the list.+--+-- Decorators can have other dependencies besides the @bean@.+newtype Decos m bean where+ Decos :: {decoCons :: Seq (Constructor m bean)} -> Decos m bean+ deriving newtype (Semigroup, Monoid)++instance IsList (Decos m bean) where+ type Item (Decos m bean) = Constructor m bean+ fromList decos = Decos do GHC.Exts.fromList decos+ toList (Decos {decoCons}) = GHC.Exts.toList decoCons++-- | Empty list of decorators.+emptyDecos :: Decos m bean+emptyDecos = mempty++-- | Change the monad used by the decorators.+hoistDecos :: (forall x. m x -> n x) -> Decos m bean -> Decos n bean+hoistDecos f (Decos {decoCons}) = Decos {decoCons = hoistConstructor f <$> decoCons}++setConstructor :: Constructor m bean -> Bean m bean -> Bean m bean+setConstructor constructor (Bean {decos}) = Bean {constructor, decos}++setDecos :: Decos m bean -> Bean m bean -> Bean m bean+setDecos decos (Bean {constructor}) = Bean {constructor, decos}++overDecos :: (Decos m bean -> Decos m bean) -> Bean m bean -> Bean m bean+overDecos f (Bean {constructor, decos}) = Bean {constructor, decos = f decos}++-- | Add a new decorator that modifies the bean /after/ all existing decorators.+--+-- This means the behaviours it adds to the bean\'s methods will be applied+-- /first/ when entering the method.+addOuter :: Constructor m bean -> Decos m bean -> Decos m bean+addOuter con (Decos {decoCons}) = Decos do decoCons Seq.|> con++-- | Add a new decorator that modifies the bean /before/ all existing+-- decorators.+--+-- This means the behaviours it adds to the bean\'s methods will be applied+-- /last/, just before entering the base bean's method.+--+-- Usually 'addOuter' is preferrable.+addInner :: Constructor m bean -> Decos m bean -> Decos m bean+addInner con (Decos {decoCons}) = Decos do con Seq.<| decoCons++-- | Build the decorators from a list of 'Constructor's, first innermost,+-- last outermost.+fromConstructors ::+ [Constructor m bean] ->+ Decos m bean+fromConstructors cons = Decos do Seq.fromList cons++-- $constructors+--+-- The bean-producing or bean-decorating functions that we want to wire need to be+-- coaxed into a 'Constructor' value before creating a 'Bean' recipe and adding it to the 'Cauldron'.+--+-- If your aren't dealing with secondary beans, don't sweat it: use @pack value@ for pure+-- constructors functions and @pack effect@ for effectful ones. That should be enough.++-- | A way of building some @bean@ value, potentially requiring some+-- dependencies, potentially returning some secondary beans+-- along the primary @bean@ result, and also potentially requiring some+-- initialization effect in a monad @m@.+--+-- Note that only the type of the primary @bean@ is reflected in the+-- 'Constructor' type. Those of the dependencies and secondary beans are not.+--+-- A typical initialization monad will be 'IO', used for example to create+-- mutable references that the bean will use internally. Sometimes the a+-- constructor will allocate resources with bracket-like operations, and in that+-- case a monad like 'Managed' might be needed instead.+data Constructor m bean where+ Constructor ::+ (All Typeable args, All (Typeable `And` Monoid) regs) =>+ { constructor_ :: Args args (m (Regs regs bean))+ } ->+ Constructor m bean++data ConstructorReps where+ ConstructorReps ::+ { beanRep :: TypeRep,+ argReps :: Set TypeRep,+ regReps :: Map TypeRep Dynamic+ } ->+ ConstructorReps++-- | Change the monad in which the 'Constructor'\'s effects take place.+hoistConstructor :: (forall x. m x -> n x) -> Constructor m bean -> Constructor n bean+hoistConstructor f (Constructor {constructor_}) = Constructor do fmap f constructor_++-- | Put a recipe for a 'Bean' into the 'Cauldron'.+--+-- Only one recipe is allowed for each different @bean@ type, so 'insert' for a+-- @bean@ will overwrite previous recipes for that type.+insert ::+ forall (bean :: Type) m.+ (Typeable bean) =>+ Bean m bean ->+ Cauldron m ->+ Cauldron m+insert recipe Cauldron {recipes} = do+ let rep = typeRep (Proxy @bean)+ Cauldron {recipes = Map.insert rep (SomeBean recipe) recipes}++-- | Tweak an already existing 'Bean' recipe.+adjust ::+ forall bean m.+ (Typeable bean) =>+ (Bean m bean -> Bean m bean) ->+ Cauldron m ->+ Cauldron m+adjust f (Cauldron {recipes}) = do+ let rep = typeRep (Proxy @bean)+ Cauldron+ { recipes =+ Map.adjust+ do+ \(SomeBean (r :: Bean m a)) ->+ case testEquality (Type.Reflection.typeRep @bean) (Type.Reflection.typeRep @a) of+ Nothing -> error "should never happen"+ Just Refl -> SomeBean (f r)+ rep+ recipes+ }++delete ::+ forall bean m.+ (Typeable bean) =>+ Cauldron m ->+ Cauldron m+delete Cauldron {recipes} =+ Cauldron {recipes = Map.delete (typeRep (Proxy @bean)) recipes}++-- | Strategy for dealing with dependency cycles.+--+-- (Terrible uninformative name caused by a metaphor stretched too far.)+data Fire m = Fire+ { shouldOmitDependency :: (BeanConstructionStep, BeanConstructionStep) -> Bool,+ followPlanCauldron ::+ Cauldron m ->+ BoiledBeans ->+ Plan ->+ m BoiledBeans+ }++removeBeanFromArgs :: ConstructorReps -> ConstructorReps+removeBeanFromArgs ConstructorReps {argReps, regReps, beanRep} =+ ConstructorReps {argReps = Set.delete beanRep argReps, regReps, beanRep}++-- | Allow /direct/ self-dependencies.+--+-- A bean constructor might depend on itself. This can be useful for having+-- decorated self-invocations, because the version of the bean received as+-- argument comes \"from the future\" and is already decorated. (__BEWARE__:+-- Pattern-matching too eagerly on this \"bean from the future\" during+-- construction will cause infinite loops.)+--+-- Note that a 'MonadFix' instance is required of the initialization monad.+allowSelfDeps :: (MonadFix m) => Fire m+allowSelfDeps =+ Fire+ { shouldOmitDependency = \case+ (BarePrimaryBean bean, PrimaryBean anotherBean) | bean == anotherBean -> True+ _ -> False,+ followPlanCauldron = \cauldron initial plan ->+ mfix do+ \final ->+ Data.Foldable.foldlM+ do followPlanStep cauldron final+ initial+ plan+ }++-- | Forbid any kind of cyclic dependencies between beans. This is probably what you want.+forbidDepCycles :: (Monad m) => Fire m+forbidDepCycles =+ Fire+ { shouldOmitDependency = \_ -> False,+ followPlanCauldron = \cauldron initial plan ->+ Data.Foldable.foldlM+ do followPlanStep cauldron BoiledBeans {beans = Map.empty}+ initial+ plan+ }++-- https://discord.com/channels/280033776820813825/280036215477239809/1147832555828162594+-- https://github.com/ghc-proposals/ghc-proposals/pull/126#issuecomment-1363403330++-- | This function DOESN'T return the bean rep itself in the argreps.+constructorReps :: (Typeable bean) => Constructor m bean -> ConstructorReps+constructorReps Constructor {constructor_ = (_ :: Args args (m (Regs accums bean)))} =+ ConstructorReps+ { beanRep,+ argReps =+ do+ Set.fromList do+ collapse_NP do+ cpure_NP @_ @args+ do Proxy @Typeable+ typeRepHelper,+ regReps =+ Map.fromList do+ collapse_NP do+ cpure_NP @_ @accums+ do Proxy @(Typeable `And` Monoid)+ typeRepHelper'+ }+ where+ typeRepHelper :: forall a. (Typeable a) => K TypeRep a+ typeRepHelper = K (typeRep (Proxy @a))+ typeRepHelper' :: forall a. ((Typeable `And` Monoid) a) => K (TypeRep, Dynamic) a+ typeRepHelper' = K (typeRep (Proxy @a), toDyn @a mempty)+ beanRep = typeRep (Proxy @bean)++type Plan = [BeanConstructionStep]++-- | A step in the construction of a bean value.+data BeanConstructionStep+ = -- | Undecorated bean.+ BarePrimaryBean TypeRep+ | -- | Apply the decorator with the given index. Comes after the 'BarePrimaryBean' and all 'PrimaryBeanDeco's with a lower index value.+ PrimaryBeanDeco TypeRep Int+ | -- | Final, fully decorated version of a bean. If there are no decorators, comes directly after 'BarePrimaryBean'.+ PrimaryBean TypeRep+ | -- | Beans that are secondary registrations of a 'Constructor' and which are aggregated monoidally.+ SecondaryBean TypeRep+ deriving stock (Show, Eq, Ord)++-- | The successful result of 'cook'ing a 'Cauldron'. Can't do a lot with them other than to 'taste' them.+newtype BoiledBeans where+ BoiledBeans :: {beans :: Map TypeRep Dynamic} -> BoiledBeans++-- | Build the beans using the recipes stored in the 'Cauldron'.+cook ::+ forall m.+ (Monad m) =>+ Fire m ->+ Cauldron m ->+ Either BadBeans (DependencyGraph, m BoiledBeans)+cook fire cauldron = do+ let result = cookTree (Node (fire, cauldron) [])+ result <&> \(tg, m) -> (rootLabel tg, rootLabel <$> m)++-- | Cook a list of 'Cauldron's.+--+-- 'Cauldron's later in the list can see the beans in all previous 'Cauldron's,+-- but not vice versa.+--+-- Beans in a 'Cauldron' have priority over the same beans in previous 'Cauldron's.+cookNonEmpty ::+ forall m.+ (Monad m) =>+ NonEmpty (Fire m, Cauldron m) ->+ Either BadBeans (NonEmpty DependencyGraph, m (NonEmpty BoiledBeans))+cookNonEmpty nonemptyCauldronList = do+ let result = cookTree (nonEmptyToTree nonemptyCauldronList)+ result <&> \(ng, m) -> (unsafeTreeToNonEmpty ng, unsafeTreeToNonEmpty <$> m)++-- | Cook a hierarchy of 'Cauldron's.+--+-- 'Cauldron's down in the branches can see the beans of their ancestor+-- 'Cauldron's, but not vice versa.+--+-- Beans in a 'Cauldron' have priority over the same beans in ancestor 'Cauldron's.+cookTree ::+ forall m.+ (Monad m) =>+ Tree (Fire m, Cauldron m) ->+ Either BadBeans (Tree DependencyGraph, m (Tree BoiledBeans))+cookTree (treecipes) = do+ accumMap <- first DoubleDutyBeans do checkNoDoubleDutyBeans (snd <$> treecipes)+ () <- first (uncurry MissingDependencies) do checkMissingDeps (Map.keysSet accumMap) (snd <$> treecipes)+ treeplan <- first DependencyCycle do buildPlans (Map.keysSet accumMap) treecipes+ Right+ ( treeplan <&> \(graph, _) -> DependencyGraph {graph},+ followPlan (BoiledBeans accumMap) (snd <$> treeplan)+ )++checkNoDoubleDutyBeans ::+ Tree (Cauldron m) ->+ Either (Set TypeRep) (Map TypeRep Dynamic)+checkNoDoubleDutyBeans treecipes = do+ let (accumMap, beanSet) = cauldronTreeRegs treecipes+ let common = Set.intersection (Map.keysSet accumMap) beanSet+ if not (Set.null common)+ then Left common+ else Right accumMap++-- | Will always be @[]@ when using 'cook'; identifies a 'Cauldron' in a hierarchy of 'Cauldron's when+-- using 'cookNonEmpty' or 'cookTree'.+type PathToCauldron = [Int]++cauldronTreeRegs :: Tree (Cauldron m) -> (Map TypeRep Dynamic, Set TypeRep)+cauldronTreeRegs = foldMap cauldronRegs++cauldronRegs :: Cauldron m -> (Map TypeRep Dynamic, Set TypeRep)+cauldronRegs Cauldron {recipes} =+ Map.foldMapWithKey+ do \rep recipe -> (recipeRegs recipe, Set.singleton rep)+ recipes++-- | Returns the accumulators, not the main bean+recipeRegs :: SomeBean m -> Map TypeRep Dynamic+recipeRegs (SomeBean (Bean {constructor, decos = Decos {decoCons}})) = do+ let extractRegReps = (.regReps) . constructorReps+ extractRegReps constructor+ <> foldMap extractRegReps decoCons++checkMissingDeps ::+ -- | accums+ Set TypeRep ->+ Tree (Cauldron m) ->+ Either (PathToCauldron, Map TypeRep (Set TypeRep)) ()+checkMissingDeps accums treecipes = do+ let decoratedTreecipes = decorate ([], Map.empty, treecipes)+ missing = (\(key, available, requested) -> first (key,) do checkMissingDepsCauldron accums (Map.keysSet available) requested) <$> decoratedTreecipes+ sequence_ missing+ where+ decorate ::+ (PathToCauldron, Map TypeRep PathToCauldron, Tree (Cauldron m)) ->+ Tree (PathToCauldron, Map TypeRep PathToCauldron, Cauldron m)+ decorate = unfoldTree+ do+ \(key, acc, Node (current@Cauldron {recipes}) rest) ->+ let -- current level has priority+ newAcc = (recipes $> key) `Map.union` acc+ newSeeds = do+ (i, z) <- zip [0 ..] rest+ let newKey = key ++ [i]+ [(newKey, newAcc, z)]+ in ((key, newAcc, current), newSeeds)++checkMissingDepsCauldron ::+ -- | accums+ Set TypeRep ->+ -- | available at this level+ Set TypeRep ->+ Cauldron m ->+ Either (Map TypeRep (Set TypeRep)) ()+checkMissingDepsCauldron accums available Cauldron {recipes} = do+ let missingMap = (`Map.mapMaybe` recipes) \someBean -> do+ let missing = Set.filter (`Set.notMember` available) do demanded someBean+ if Set.null missing+ then Nothing+ else Just missing+ if not (Map.null missingMap)+ then Left missingMap+ else Right ()+ where+ demanded :: SomeBean m -> Set TypeRep+ demanded (SomeBean Bean {constructor, decos = Decos {decoCons}}) =+ ( Set.fromList do+ let ConstructorReps {argReps = beanArgReps} = constructorReps constructor+ Set.toList beanArgReps ++ do+ decoCon <- Data.Foldable.toList decoCons+ let ConstructorReps {argReps = decoArgReps} = constructorReps decoCon+ Set.toList decoArgReps+ )+ `Set.difference` accums++buildPlans :: Set TypeRep -> Tree (Fire m, Cauldron m) -> Either (NonEmpty BeanConstructionStep) (Tree (AdjacencyMap BeanConstructionStep, (Plan, Fire m, Cauldron m)))+buildPlans secondary = traverse \(fire@Fire {shouldOmitDependency}, cauldron) -> do+ let deps = filter (not . shouldOmitDependency) do buildDepsCauldron secondary cauldron+ let graph = Graph.edges deps+ case Graph.topSort graph of+ Left recipeCycle ->+ Left recipeCycle+ Right (reverse -> plan) -> do+ let completeGraph = Graph.edges deps+ Right (completeGraph, (plan, fire, cauldron))++buildDepsCauldron :: Set TypeRep -> Cauldron m -> [(BeanConstructionStep, BeanConstructionStep)]+buildDepsCauldron secondary Cauldron {recipes} = do+ let makeTargetStep :: TypeRep -> BeanConstructionStep+ makeTargetStep rep =+ if rep `Set.member` secondary+ then SecondaryBean rep+ else PrimaryBean rep+ (flip Map.foldMapWithKey)+ recipes+ \beanRep+ ( SomeBean+ ( Bean+ { constructor = constructor :: Constructor m bean,+ decos = Decos {decoCons}+ }+ )+ ) -> do+ let bareBean = BarePrimaryBean beanRep+ boiledBean = PrimaryBean beanRep+ decos = do+ (decoIndex, decoCon) <- zip [0 :: Int ..] (Data.Foldable.toList decoCons)+ [(PrimaryBeanDeco beanRep decoIndex, decoCon)]+ beanDeps = do+ constructorEdges makeTargetStep bareBean (do constructorReps constructor)+ decoDeps = do+ (decoBean, decoCon) <- decos+ constructorEdges makeTargetStep decoBean (removeBeanFromArgs do constructorReps decoCon)+ full = bareBean Data.List.NonEmpty.:| (fst <$> decos) ++ [boiledBean]+ innerDeps = zip (Data.List.NonEmpty.tail full) (Data.List.NonEmpty.toList full)+ beanDeps ++ decoDeps ++ innerDeps++constructorEdges ::+ (TypeRep -> BeanConstructionStep) ->+ BeanConstructionStep ->+ ConstructorReps ->+ [(BeanConstructionStep, BeanConstructionStep)]+constructorEdges makeTargetStep item (ConstructorReps {argReps, regReps}) =+ -- consumers depend on their args+ ( do+ argRep <- Set.toList argReps+ let argStep = makeTargetStep argRep+ [(item, argStep)]+ )+ +++ -- secondary beans depend on their producers+ ( do+ (regRep, _) <- Map.toList regReps+ let repStep = SecondaryBean regRep+ [(repStep, item)]+ )++followPlan ::+ (Monad m) =>+ BoiledBeans ->+ (Tree (Plan, Fire m, Cauldron m)) ->+ m (Tree BoiledBeans)+followPlan initial treecipes =+ unfoldTreeM+ ( \(initial', Node (plan, Fire {followPlanCauldron}, cauldron) rest) -> do+ newInitial' <- followPlanCauldron cauldron initial' plan+ pure (newInitial', (,) newInitial' <$> rest)+ )+ (initial, treecipes)++followPlanStep ::+ (Monad m) =>+ Cauldron m ->+ BoiledBeans ->+ BoiledBeans ->+ BeanConstructionStep ->+ m BoiledBeans+followPlanStep Cauldron {recipes} (BoiledBeans final) (BoiledBeans super) item =+ BoiledBeans <$> case item of+ BarePrimaryBean rep -> case fromJust do Map.lookup rep recipes of+ SomeBean (Bean {constructor}) -> do+ let ConstructorReps {beanRep} = constructorReps constructor+ -- We delete the beanRep before running the constructor,+ -- because if we have a self-dependency, we don't want to use the bean+ -- from a previous context (if it exists) we want the bean from final.+ -- There is a test for this.+ (super', bean) <- followConstructor constructor final (Map.delete beanRep super)+ pure do Map.insert beanRep (toDyn bean) super'+ PrimaryBeanDeco rep index -> case fromJust do Map.lookup rep recipes of+ SomeBean (Bean {decos = Decos {decoCons}}) -> do+ let decoCon = fromJust do Seq.lookup index decoCons+ let ConstructorReps {beanRep} = constructorReps decoCon+ -- Unlike before, we don't delete the beanRep before running the constructor.+ (super', bean) <- followConstructor decoCon final super+ pure do Map.insert beanRep (toDyn bean) super'+ -- \| We do nothing here, the work has been done in previous 'BarePrimaryBean' and+ -- 'PrimaryBeanDeco' steps.+ PrimaryBean _ -> pure super+ -- \| We do nothing here, secondary beans are built as a byproduct+ -- of primary beans and decorators.+ SecondaryBean _ -> pure super++-- | Build a bean out of already built beans.+-- This can only work without blowing up if there aren't dependecy cycles+-- and the order of construction respects the depedencies!+followConstructor ::+ (Monad m) =>+ Constructor m bean ->+ Map TypeRep Dynamic ->+ Map TypeRep Dynamic ->+ m (Map TypeRep Dynamic, bean)+followConstructor Constructor {constructor_ = Args {runArgs}} final super = do+ let Extractor {runExtractor} = sequence_NP do cpure_NP (Proxy @Typeable) makeExtractor+ args = runExtractor final super+ results <- runArgs args+ case results of+ Regs regs bean -> do+ let inserters = cfoldMap_NP (Proxy @(Typeable `And` Monoid)) makeRegInserter regs+ pure (appEndo inserters super, bean)++newtype Extractor a where+ Extractor :: {runExtractor :: Map TypeRep Dynamic -> Map TypeRep Dynamic -> a} -> Extractor a+ deriving (Functor, Applicative) via ((->) (Map TypeRep Dynamic) `Compose` ((->) (Map TypeRep Dynamic)))++makeExtractor :: forall a. (Typeable a) => Extractor a+makeExtractor =+ let runExtractor final super =+ fromJust do taste' @a super <|> taste' @a final+ in Extractor {runExtractor}++makeRegInserter :: forall a. ((Typeable `And` Monoid) a) => I a -> Endo (Map TypeRep Dynamic)+makeRegInserter (I a) =+ let appEndo dynMap = do+ let reg = fromJust do taste' @a dynMap+ dyn = toDyn (reg <> a)+ Map.insert (dynTypeRep dyn) dyn dynMap+ in Endo {appEndo}++-- | Return the resulting @bean@, if present.+taste :: forall bean. (Typeable bean) => BoiledBeans -> Maybe bean+taste BoiledBeans {beans} = taste' beans++taste' :: forall bean. (Typeable bean) => Map TypeRep Dynamic -> Maybe bean+taste' beans = do+ let rep = typeRep (Proxy @bean)+ dyn <- Map.lookup rep beans+ fromDynamic @bean dyn++-- | Sometimes the 'cook'ing process goes wrong.+data BadBeans+ = -- | The 'Cauldron' identified by 'PathToCauldron' has beans+ -- that depend on beans that can't be found either in the current 'Cauldron' or its ancestors.+ MissingDependencies PathToCauldron (Map TypeRep (Set TypeRep))+ | -- | Beans that work both as primary beans and as secondary beans+ -- are disallowed.+ DoubleDutyBeans (Set TypeRep)+ | -- | Dependency cycles are disallowed by some 'Fire's.+ DependencyCycle (NonEmpty BeanConstructionStep)+ deriving stock (Show)++-- | An edge means that the source depends on the target.+--+-- The dependencies of each bean are given separatedly from its decorators.+newtype DependencyGraph = DependencyGraph {graph :: AdjacencyMap BeanConstructionStep}++-- | Conversion to a graph type+-- from the+-- [algebraic-graphs](https://hackage.haskell.org/package/algebraic-graphs-0.7/docs/Algebra-Graph-AdjacencyMap.html)+-- library for further processing.+toAdjacencyMap :: DependencyGraph -> AdjacencyMap BeanConstructionStep+toAdjacencyMap DependencyGraph {graph} = graph++removeSecondaryBeans :: DependencyGraph -> DependencyGraph+removeSecondaryBeans DependencyGraph {graph} =+ DependencyGraph {graph = Graph.induce (\case SecondaryBean {} -> False; _ -> True) graph}++removeDecos :: DependencyGraph -> DependencyGraph+removeDecos DependencyGraph {graph} =+ DependencyGraph {graph = Graph.induce (\case PrimaryBeanDeco {} -> False; _ -> True) graph}++-- | Unifies 'PrimaryBean's with their respective 'BarePrimaryBean's and 'PrimaryBeanDeco's.+--+-- Also removes any self-loops.+collapsePrimaryBeans :: DependencyGraph -> DependencyGraph+collapsePrimaryBeans DependencyGraph {graph} = do+ let simplified =+ Graph.gmap+ ( \case+ BarePrimaryBean rep -> PrimaryBean rep+ PrimaryBeanDeco rep _ -> PrimaryBean rep+ other -> other+ )+ graph+ -- Is there a simpler way to removoe self-loops?+ vertices = Graph.vertexList simplified+ edges = Graph.edgeList simplified+ edgesWithoutSelfLoops =+ filter+ ( \case+ (PrimaryBean source, PrimaryBean target) -> if source == target then False else True+ _ -> True+ )+ edges+ DependencyGraph {graph = Graph.vertices vertices `Graph.overlay` Graph.edges edgesWithoutSelfLoops}++-- | See the [DOT format](https://graphviz.org/doc/info/lang.html).+exportToDot :: (BeanConstructionStep -> Data.Text.Text) -> FilePath -> DependencyGraph -> IO ()+exportToDot prettyRep filepath DependencyGraph {graph} = do+ let dot =+ Dot.export+ do Dot.defaultStyle prettyRep+ graph+ Data.ByteString.writeFile filepath (Data.Text.Encoding.encodeUtf8 dot)++defaultStepToText :: BeanConstructionStep -> Data.Text.Text+defaultStepToText =+ let p rep = Data.Text.pack do show rep+ in \case+ BarePrimaryBean rep -> p rep <> Data.Text.pack "#bare"+ PrimaryBeanDeco rep index -> p rep <> Data.Text.pack ("#deco#" ++ show index)+ PrimaryBean rep -> p rep+ SecondaryBean rep -> p rep <> Data.Text.pack "#sec"++newtype Args args r = Args {runArgs :: NP I args -> r}+ deriving newtype (Functor, Applicative, Monad)++argsN ::+ forall (args :: [Type]) r curried.+ (MulticurryableF args r curried (IsFunction curried)) =>+ curried ->+ Args args r+argsN = Args . multiuncurry++-- $registrations+--+-- 'Constructor's produce a single primary bean, but sometimes they might also+-- \"register\" a number of secondary beans.+--+-- These secondary beans+-- must have 'Monoid' instances and, unlike the primary bean, can be produced by+-- more that one 'Constructor'. Their values are aggregated across all the 'Constructor's+-- that produce them. The final aggregated value can be depended upon by other 'Constructor's+-- as if it were a normal bean.+--+-- The 'Regs' type is used to represent the main bean along with the secondary+-- beans that it registers. Because usually we'll be working with functions that+-- do not use the 'Regs' type, a 'Packer' must be used to coax the \"tip\" of+-- the constructor function into the required shape expected by 'Constructor'.+--+-- >>> :{+-- data A = A deriving Show+-- data B = B deriving Show+-- data C = C (Sum Int) deriving Show+-- makeA :: (Sum Int, A)+-- makeA = (Sum 1, A)+-- makeB :: A -> IO (Sum Int, B)+-- makeB = \_ -> pure (Sum 2, B)+-- makeC :: Sum Int -> C+-- makeC = \theSum -> C theSum+-- :}+--+--+-- >>> :{+-- do+-- let cauldron :: Cauldron IO+-- cauldron =+-- emptyCauldron+-- & insert @A do makeBean do pack (valueWith \(s, a) -> regs1 s a) makeA+-- & insert @B do makeBean do pack (effectWith \(s, b) -> regs1 s b) makeB+-- & insert @C do makeBean do pack value makeC+-- Right (_ :: DependencyGraph, action) = cook forbidDepCycles cauldron+-- beans <- action+-- pure do taste @C beans+-- :}+-- Just (C (Sum {getSum = 3}))++-- | Auxiliary type which contains a primary bean along with zero or more+-- secondary beans. The secondary beans must have+-- 'Monoid' instances.+data Regs (regs :: [Type]) bean = Regs (NP I regs) bean+ deriving (Functor)++-- | A primary @bean@ without secondary beans.+regs0 :: bean -> Regs '[] bean+regs0 bean = Regs Nil bean++-- | A primary @bean@ with one secondary bean.+regs1 :: reg1 -> bean -> Regs '[reg1] bean+regs1 reg1 bean = Regs (I reg1 :* Nil) bean++-- | A primary @bean@ with two secondary beans.+regs2 :: reg1 -> reg2 -> bean -> Regs '[reg1, reg2] bean+regs2 reg1 reg2 bean = Regs (I reg1 :* I reg2 :* Nil) bean++-- | A primary @bean@ with three secondary beans.+regs3 :: reg1 -> reg2 -> reg3 -> bean -> Regs '[reg1, reg2, reg3] bean+regs3 reg1 reg2 reg3 bean = Regs (I reg1 :* I reg2 :* I reg3 :* Nil) bean++-- | Applies a transformation to the tip of a curried function, coaxing+-- it into the shape expected by a 'Constructor', which includes information+-- about which is the primary bean and which are the secondary ones.+--+-- * For pure constructors without registrations, try 'value'.+--+-- * For effectful constructors without registrations, try 'effect'.+--+-- More complex cases might require 'valueWith', 'effectWith', or working with+-- the 'Packer' constructor itself.+newtype Packer m regs bean r = Packer (r -> m (Regs regs bean))++runPacker :: Packer m regs bean r -> r -> m (Regs regs bean)+runPacker (Packer f) = f++instance Contravariant (Packer m regs bean) where+ contramap f (Packer p) = Packer (p . f)++-- | For pure constructors that return the @bean@ directly, and do not register+-- secondary beans.+value :: (Applicative m) => Packer m '[] bean bean+value = Packer \bean -> pure do regs0 bean++-- | For effectul constructors that return an @m bean@ initialization action,+-- and do not register secondary beans.+effect :: (Applicative m) => Packer m '[] bean (m bean)+effect = Packer \action -> do fmap regs0 action++-- |+-- >>> :{+-- data A = A deriving Show+-- data B = B deriving Show+-- makeB :: A -> (Sum Int, B)+-- makeB = \_ -> (Sum 1, B)+-- constructorB :: Constructor IO B+-- constructorB = pack (valueWith \(s,bean) -> regs1 s bean) makeB+-- :}+valueWith ::+ (Applicative m, All (Typeable `And` Monoid) regs) =>+ -- | Massage the pure value at the tip of the constructor into a 'Regs'.+ (r -> Regs regs bean) ->+ Packer m regs bean r+valueWith f = Packer do pure . f++-- |+-- >>> :{+-- data A = A deriving Show+-- data B = B deriving Show+-- makeB :: A -> IO (Sum Int, B)+-- makeB = \_ -> pure (Sum 1, B)+-- constructorB :: Constructor IO B+-- constructorB = pack (effectWith \(s,bean) -> regs1 s bean) makeB+-- :}+effectWith ::+ (Applicative m, All (Typeable `And` Monoid) regs) =>+ -- | Massage the value returned by the action at the tip of the constructor into a 'Regs'.+ (r -> Regs regs bean) ->+ Packer m regs bean (m r)+effectWith f = Packer do fmap f++-- | Take a curried function that constructs a bean, uncurry it recursively and+-- then apply a 'Packer' to its tip, resulting in a 'Constructor'.+--+-- >>> :{+-- data A = A deriving Show+-- data B = B deriving Show+-- data C = C deriving Show+-- makeB :: A -> B+-- makeB = \_ -> B+-- makeC :: A -> B -> IO C+-- makeC = \_ _ -> pure C+-- constructorB :: Constructor IO B+-- constructorB = pack value makeB+-- constructorC :: Constructor IO C+-- constructorC = pack effect makeC+-- :}+--+-- There are 'pack0', 'pack1'... functions which work for specific number of arguments, but+-- the generic 'pack' should work in most cases anyway.+pack ::+ forall (args :: [Type]) r curried regs bean m.+ ( MulticurryableF args r curried (IsFunction curried),+ All Typeable args,+ All (Typeable `And` Monoid) regs+ ) =>+ -- | Fit the outputs of the constructor into the auxiliary 'Regs' type.+ --+ -- See 'regs1' and similar functions.+ Packer m regs bean r ->+ -- | Action returning a function ending in @r@, some datatype containing+ -- @regs@ and @bean@ values.+ curried ->+ Constructor m bean+pack packer curried = Constructor do runPacker packer <$> do argsN curried++-- | Slightly simpler version of 'pack' for @0@-argument functions.+pack0 ::+ (All (Typeable `And` Monoid) regs) =>+ Packer m regs bean r ->+ -- | @0@-argument constructor+ r ->+ Constructor m bean+pack0 packer r = Constructor do Args @'[] \Nil -> runPacker packer r++-- | Slightly simpler version of 'pack' for @1@-argument functions.+pack1 ::+ forall arg1 r m regs bean.+ (Typeable arg1, All (Typeable `And` Monoid) regs) =>+ Packer m regs bean r ->+ -- | @1@-argument constructor+ (arg1 -> r) ->+ Constructor m bean+pack1 packer f = Constructor do Args @'[arg1] \(I arg1 :* Nil) -> runPacker packer (f arg1)++-- | Slightly simpler version of 'pack' for @2@-argument functions.+pack2 ::+ forall arg1 arg2 r m regs bean.+ (Typeable arg1, Typeable arg2, All (Typeable `And` Monoid) regs) =>+ Packer m regs bean r ->+ -- | @2@-argument constructor+ (arg1 -> arg2 -> r) ->+ Constructor m bean+pack2 packer f = Constructor do Args @[arg1, arg2] \(I arg1 :* I arg2 :* Nil) -> runPacker packer (f arg1 arg2)++-- | Slightly simpler version of 'pack' for @3@-argument functions.+pack3 ::+ forall arg1 arg2 arg3 r m regs bean.+ (Typeable arg1, Typeable arg2, Typeable arg3, All (Typeable `And` Monoid) regs) =>+ Packer m regs bean r ->+ -- | @3@-argument constructor+ (arg1 -> arg2 -> arg3 -> r) ->+ Constructor m bean+pack3 packer f = Constructor do Args @[arg1, arg2, arg3] \(I arg1 :* I arg2 :* I arg3 :* Nil) -> runPacker packer (f arg1 arg2 arg3)++nonEmptyToTree :: NonEmpty a -> Tree a+nonEmptyToTree = \case+ a Data.List.NonEmpty.:| [] -> Node a []+ a Data.List.NonEmpty.:| (b : rest) -> Node a [nonEmptyToTree (b Data.List.NonEmpty.:| rest)]++unsafeTreeToNonEmpty :: Tree a -> NonEmpty a+unsafeTreeToNonEmpty = \case+ Node a [] -> a Data.List.NonEmpty.:| []+ Node a [b] -> Data.List.NonEmpty.cons a (unsafeTreeToNonEmpty b)+ _ -> error "tree not list-shaped"++-- $setup+-- >>> :set -XBlockArguments+-- >>> :set -Wno-incomplete-uni-patterns+-- >>> import Data.Functor.Identity+-- >>> import Data.Function ((&))+-- >>> import Data.Monoid
+ lib/Cauldron/Managed.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE BlockArguments #-}++module Cauldron.Managed+ ( -- * The Managed monad for handling resources+ Managed,+ managed,+ with,+ )+where++import Control.Concurrent.MVar+import Control.Exception.Base+import Control.Monad.Fix+import Control.Monad.IO.Class+import GHC.IO.Unsafe++-- | This is a copy of the @Managed@ type from the+-- [managed](https://hackage.haskell.org/package/managed) package, with a dodgy+-- 'Control.Monad.Fix.MonadFix' instance tacked on.+newtype Managed a = Managed (forall b. (a -> IO b) -> IO b)++-- | Build a 'Managed' value from a @withFoo@-style resource-handling function+-- that accepts a continuation, like 'System.IO.withFile'.+--+-- Passing functions that do weird things like running their continuation+-- /twice/ will tear apart the fabric of reality. Why would you want to do that?+-- Pass only @withFoo@-style functions.+managed :: (forall r. (a -> IO r) -> IO r) -> Managed a+managed = Managed++-- | This instance is a little dodgy (continuation-like monads don't have proper+-- 'MonadFix' instances) but it is nevertheless useful because it lets us use+-- 'Managed' with 'allowSelfDeps'. Follow the recommendations for the 'managed'+-- function.+--+-- [\"if you embrace the unsafety, it could be a fun way to tie knots.\"](https://stackoverflow.com/questions/25827227/why-cant-there-be-an-instance-of-monadfix-for-the-continuation-monad#comment113010373_63906214)+instance MonadFix Managed where+ -- https://stackoverflow.com/a/63906214+ -- See also the implementation for fixIO https://hackage.haskell.org/package/base-4.19.0.0/docs/src/System.IO.html#fixIO+ mfix f = Managed \k -> do+ m <- newEmptyMVar+ x <-+ unsafeDupableInterleaveIO+ ( readMVar m `catch` \BlockedIndefinitelyOnMVar ->+ throwIO FixIOException+ )+ unManage (f x) \x' -> do+ putMVar m x'+ k x'+ where+ unManage (Managed a) = a++-- | Make use of the managed resource by supplying a callback.+with :: Managed a -> (a -> IO b) -> IO b+with (Managed r) = r++instance Functor Managed where+ fmap f (Managed m) = Managed (\k -> m (\x -> k (f x)))+ {-# INLINE fmap #-}++instance Applicative Managed where+ pure x = Managed (\k -> k x)+ {-# INLINE pure #-}+ Managed f <*> Managed g = Managed (\bfr -> f (\ab -> g (\x -> bfr (ab x))))+ {-# INLINE (<*>) #-}++instance Monad Managed where+ return = pure+ {-# INLINE return #-}+ m >>= k = Managed (\c -> with m (\a -> with (k a) c))+ {-# INLINE (>>=) #-}++instance MonadIO Managed where+ liftIO m = Managed \return_ -> do+ a <- m+ return_ a+ {-# INLINE liftIO #-}
+ test/appTests.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoFieldSelectors #-}++-- | The example in the executable, as a test.+module Main (main) where++import Cauldron+import Data.Function ((&))+import Data.Maybe (fromJust)+import Test.Tasty+import Test.Tasty.HUnit++data A = A deriving (Show)++data B = B deriving (Show)++data C = C deriving (Show)++data D = D deriving (Show)++data E = E deriving (Show)++data F = F deriving (Show)++data G = G deriving (Show)++data H = H deriving (Show)++data I = I deriving (Show)++data J = J deriving (Show)++data K = K deriving (Show)++data L = L deriving (Show)++data M = M deriving (Show)++data N = N deriving (Show)++data O = O deriving (Show)++data P = P deriving (Show)++data Q = Q deriving (Show)++data R = R deriving (Show)++data S = S deriving (Show)++data T = T deriving (Show)++data U = U deriving (Show)++data V = V deriving (Show)++data W = W deriving (Show)++data X = X deriving (Show)++data Y = Y deriving (Show)++data Z = Z deriving (Show)++newtype Inspector = Inspector {inspect :: IO [String]}+ deriving newtype (Semigroup, Monoid)++newtype Initializer = Initializer {runInitializer :: IO ()}+ deriving newtype (Semigroup, Monoid)++makeA :: A+makeA = A++makeB :: (Inspector, B)+makeB = (Inspector (pure ["B stuff"]), B)++makeC :: C+makeC = C++makeD :: D+makeD = D++makeE :: A -> E+makeE = \_ -> E++makeF :: B -> C -> (Inspector, F)+makeF = \_ _ -> (Inspector (pure ["F stuff"]), F)++makeG :: E -> F -> G -> G+makeG _ _ (_ :: G) = G++makeGDeco1 :: A -> G -> G+makeGDeco1 _ g = g++makeH :: A -> D -> G -> (Initializer, Inspector, H)+makeH _ _ _ = (Initializer (putStrLn "H init"), Inspector (pure ["H stuff"]), H)++makeZ :: Inspector -> D -> H -> Z+makeZ _ _ _ = Z++makeZDeco1 :: B -> E -> Z -> Z+makeZDeco1 _ _ z = z++makeZDeco2 :: F -> Z -> (Initializer, Z)+makeZDeco2 = \_ z -> (Initializer (putStrLn "Z deco init"), z)++coolWiring :: Fire IO -> Either BadBeans (DependencyGraph, IO (Initializer, Inspector, Z))+coolWiring fire = do+ let cauldron :: Cauldron IO =+ mempty+ & insert @A do makeBean do pack value makeA+ & insert @B do makeBean do pack (valueWith \(reg, bean) -> regs1 reg bean) do makeB+ & insert @C do makeBean do pack value makeC+ & insert @D do makeBean do pack value makeD+ & insert @E do makeBean do pack value makeE+ & insert @F do makeBean do pack (valueWith \(reg, bean) -> regs1 reg bean) do makeF+ & insert @G+ Bean+ { constructor = pack value do makeG,+ decos =+ fromConstructors+ [ pack value do makeGDeco1+ ]+ }+ & insert @H do makeBean do pack (valueWith \(reg1, reg2, bean) -> regs2 reg1 reg2 bean) do makeH+ & insert @Z+ Bean+ { constructor = pack value do makeZ,+ decos =+ fromConstructors+ [ pack value do makeZDeco1,+ pack (valueWith \(reg, bean) -> regs1 reg bean) do makeZDeco2+ ]+ }+ & insert @(Initializer, Inspector, Z) do makeBean do pack value do \a b c -> (a, b, c)+ fmap (fmap (fmap (fromJust . taste @(Initializer, Inspector, Z)))) do cook fire cauldron++tests :: TestTree+tests =+ testGroup+ "All"+ [ testCase "example" do+ case coolWiring allowSelfDeps of+ Left badBeans -> assertFailure do show badBeans+ Right _ -> pure ()+ pure (),+ testCase "dep cycles forbidden" do+ case coolWiring forbidDepCycles of+ Left (DependencyCycle _) -> pure ()+ Left _ -> assertFailure do "wrong kind of error detected"+ Right _ -> assertFailure do "self dependency not detected"+ pure ()+ ]++main :: IO ()+main = defaultMain tests
+ test/managedTests.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoFieldSelectors #-}++module Main (main) where++import Cauldron+import Cauldron.Managed+import Data.Function ((&))+import Data.IORef+import Data.Maybe (fromJust)+import Data.Text (Text)+import Test.Tasty+import Test.Tasty.HUnit++newtype Logger m = Logger+ { logMessage :: Text -> m ()+ }++makeLogger :: IORef [Text] -> forall r. (Logger IO -> IO r) -> IO r+makeLogger ref =+ makeWithWrapperWithMessage+ ref+ "allocating logger"+ "deallocating logger"+ ( Logger \message ->+ modifyIORef ref (++ [message])+ )++data Weird m = Weird+ { weirdOp :: m (),+ anotherWeirdOp :: m ()+ }++makeSelfInvokingWeird :: IORef [Text] -> Logger IO -> Weird IO -> forall r. (Weird IO -> IO r) -> IO r+makeSelfInvokingWeird ref Logger {logMessage} ~Weird {weirdOp = selfWeirdOp} = do+ makeWithWrapperWithMessage+ ref+ "allocating weird"+ "deallocating weird"+ ( Weird+ { weirdOp = do+ modifyIORef ref (++ ["weirdOp 2"])+ logMessage "logging",+ anotherWeirdOp = do+ modifyIORef ref (++ ["another weirdOp 2"])+ selfWeirdOp+ }+ )++makeWeirdDecorator :: Logger IO -> Weird IO -> Weird IO+makeWeirdDecorator Logger {logMessage} Weird {weirdOp = selfWeirdOp, anotherWeirdOp} =+ Weird+ { weirdOp = do+ selfWeirdOp+ logMessage "logging from deco",+ anotherWeirdOp+ }++makeWithWrapperWithMessage ::+ IORef [Text] ->+ Text ->+ Text ->+ a ->+ forall r. (a -> IO r) -> IO r+makeWithWrapperWithMessage ref inMsg outMsg v handler = do+ modifyIORef ref (++ [inMsg])+ r <- handler v+ modifyIORef ref (++ [outMsg])+ pure r++managedCauldron :: IORef [Text] -> Cauldron Managed+managedCauldron ref =+ emptyCauldron+ & insert @(Logger IO) do makeBean do pack effect do managed (makeLogger ref)+ & insert @(Weird IO)+ Bean+ { constructor = pack effect do \logger self -> managed (makeSelfInvokingWeird ref logger self),+ decos =+ fromConstructors+ [ pack value makeWeirdDecorator+ ]+ }+ & insert @(Logger IO, Weird IO) do makeBean do pack value do (,)++tests :: TestTree+tests =+ testGroup+ "All"+ [ testCase "simple" do+ ref <- newIORef []+ case cook allowSelfDeps (managedCauldron ref) of+ Left _ -> assertFailure "could not wire"+ Right (_, beansAction) -> with beansAction \boiledBeans -> do+ let (Logger {logMessage}, (Weird {anotherWeirdOp}) :: Weird IO) = fromJust . taste $ boiledBeans+ logMessage "foo"+ anotherWeirdOp+ pure ()+ traces <- readIORef ref+ assertEqual+ "traces"+ ["allocating logger", "allocating weird", "foo", "another weirdOp 2", "weirdOp 2", "logging", "logging from deco", "deallocating weird", "deallocating logger"]+ traces+ ]++main :: IO ()+main = defaultMain tests
+ test/tests.hs view
@@ -0,0 +1,242 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoFieldSelectors #-}++module Main (main) where++import Cauldron+import Control.Monad.IO.Class+import Control.Monad.Trans.Writer+import Data.Function ((&))+import Data.IORef+import Data.List.NonEmpty (NonEmpty)+import Data.List.NonEmpty qualified+import Data.Map (Map)+import Data.Map qualified as Map+import Data.Maybe (fromJust)+import Data.Monoid+import Data.Text (Text)+import Test.Tasty+import Test.Tasty.HUnit++type M = WriterT [Text] IO++-- | And initialization action which some beans might register.+newtype Initializer = Initializer {runInitializer :: M ()}+ deriving (Semigroup, Monoid) via (Ap M ())++newtype Logger m = Logger+ { logMessage :: Text -> m ()+ }++makeLogger :: M (Initializer, Logger M)+makeLogger = do+ tell ["logger constructor"]+ pure+ ( Initializer do tell ["logger init"],+ Logger \message -> tell [message]+ )++data Repository m = Repository+ { findById :: Int -> m (Maybe Text),+ store :: Int -> Text -> m ()+ }++makeRepository :: Logger M -> M (Initializer, Repository M)+makeRepository Logger {logMessage} = do+ mapRef <- liftIO do newIORef @(Map Int Text) mempty+ pure+ ( Initializer do logMessage "repo init invoking logger",+ Repository+ { findById = \key -> do+ logMessage "findById"+ m <- liftIO do readIORef mapRef+ pure do Map.lookup key m,+ store = \key v -> do+ logMessage "store"+ liftIO do modifyIORef mapRef do Map.insert key v+ }+ )++data Weird m = Weird+ { weirdOp :: m (),+ anotherWeirdOp :: m ()+ }++makeWeird :: Logger M -> M (Weird M)+makeWeird _ = do+ tell ["weird constructor"]+ pure+ Weird+ { weirdOp = tell ["weirdOp"],+ anotherWeirdOp = tell ["another weirdOp"]+ }++data Lonely m = Lonely {soLonely :: m ()}++makeLonely :: Lonely M+makeLonely = do+ Lonely {soLonely = tell ["so lonely"]}++-- | Note that the patter-match on the self-dependency must be lazy, or else a+-- nasty, difficult to diagnose infinite loop will happen!+makeSelfInvokingWeird :: Weird M -> M (Weird M)+makeSelfInvokingWeird ~Weird {weirdOp = selfWeirdOp} = do+ tell ["self-invoking weird constructor"]+ pure+ Weird+ { weirdOp = tell ["weirdOp 2"],+ anotherWeirdOp = do+ tell ["another weirdOp 2"]+ selfWeirdOp+ }++weirdDeco :: Text -> Weird M -> Weird M+weirdDeco txt Weird {weirdOp, anotherWeirdOp} =+ Weird+ { weirdOp = do+ tell ["deco for weirdOp " <> txt]+ weirdOp,+ anotherWeirdOp = do+ tell ["deco for anotherWeirdOp " <> txt]+ anotherWeirdOp+ }++cauldron :: Cauldron M+cauldron =+ mempty+ & insert @(Logger M) do makeBean do pack (Packer do fmap (\(reg, bean) -> regs1 reg bean)) do makeLogger+ & insert @(Repository M) do makeBean do pack (Packer do fmap (\(reg, bean) -> regs1 reg bean)) do makeRepository+ & insert @(Initializer, Repository M) do makeBean do pack value do \a b -> (a, b)++cauldronMissingDep :: Cauldron M+cauldronMissingDep =+ cauldron+ & delete @(Logger M)++cauldronDoubleDutyBean :: Cauldron M+cauldronDoubleDutyBean =+ cauldron+ & insert @Initializer do makeBean do pack value do do (Initializer (pure ()))++cauldronWithCycle :: Cauldron M+cauldronWithCycle =+ cauldron+ & insert @(Logger M) do makeBean do pack (Packer do fmap \(reg, bean) -> regs1 reg bean) do const @_ @(Repository M) makeLogger++cauldronNonEmpty :: NonEmpty (Cauldron M)+cauldronNonEmpty =+ Data.List.NonEmpty.fromList+ [ mempty+ & do+ let packer = Packer do fmap (\(reg, bean) -> regs1 reg bean)+ insert @(Logger M) do makeBean do pack packer do makeLogger+ & insert @(Weird M) do makeBean do pack effect makeWeird,+ mempty+ & insert @(Repository M) do makeBean do pack (Packer do fmap (\(reg, bean) -> regs1 reg bean)) do makeRepository+ & insert @(Weird M)+ Bean+ { constructor = pack effect makeSelfInvokingWeird,+ decos =+ fromConstructors+ [ pack value do weirdDeco "inner",+ pack value do weirdDeco "outer"+ ]+ }+ & insert @(Initializer, Repository M, Weird M) do makeBean do pack value do \a b c -> (a, b, c)+ ]++cauldronLonely :: Cauldron M+cauldronLonely = emptyCauldron & insert @(Lonely M) do makeBean do pack0 value makeLonely++tests :: TestTree+tests =+ testGroup+ "All"+ [ testCase "value" do+ (_, traces) <- case cook' cauldron of+ Left _ -> assertFailure "could not wire"+ Right (_, beansAction) -> runWriterT do+ boiledBeans <- beansAction+ let (Initializer {runInitializer}, Repository {findById, store}) = fromJust . taste $ boiledBeans+ runInitializer+ store 1 "foo"+ _ <- findById 1+ pure ()+ assertEqual+ "traces"+ [ "logger constructor",+ "logger init",+ "repo init invoking logger",+ "store",+ "findById"+ ]+ traces,+ testCase "value sequential" do+ (_, traces) <- case cookNonEmpty' cauldronNonEmpty of+ Left _ -> assertFailure "could not wire"+ Right (_, beansAction) -> runWriterT do+ _ Data.List.NonEmpty.:| [boiledBeans] <- beansAction+ let ( Initializer {runInitializer},+ Repository {findById, store},+ Weird {anotherWeirdOp}+ ) = fromJust . taste $ boiledBeans+ runInitializer+ store 1 "foo"+ _ <- findById 1+ anotherWeirdOp+ pure ()+ assertEqual+ "traces"+ [ "logger constructor",+ "weird constructor",+ "self-invoking weird constructor",+ "logger init",+ "repo init invoking logger",+ "store",+ "findById",+ -- the deco is applied! The outer the deco, the earliest is invoked.+ "deco for anotherWeirdOp outer",+ "deco for anotherWeirdOp inner",+ "another weirdOp 2",+ "deco for weirdOp outer",+ "deco for weirdOp inner",+ -- note that the self-invocation used the method from 'makeSelfInvokingWeird'+ "weirdOp 2"+ ]+ traces,+ testCase "lonely beans get build" do+ (_, _) <- case cook' cauldronLonely of+ Left _ -> assertFailure "could not wire"+ Right (_, beansAction) -> runWriterT do+ boiledBeans <- beansAction+ let Lonely {soLonely} = fromJust . taste $ boiledBeans+ soLonely+ pure ()+ pure (),+ testCase "cauldron missing dep" do+ case cook' cauldronMissingDep of+ Left (MissingDependencies [] missingMap)+ | Map.size missingMap == 1 -> pure ()+ | otherwise -> assertFailure "missing dependency error has too many entries"+ _ -> assertFailure "missing dependency not detected"+ pure (),+ testCase "cauldron with double duty bean" do+ case cook' cauldronDoubleDutyBean of+ Left (DoubleDutyBeans _) -> pure ()+ _ -> assertFailure "double duty beans not detected"+ pure (),+ testCase "cauldron with cycle" do+ case cook' cauldronWithCycle of+ Left (DependencyCycle _) -> pure ()+ _ -> assertFailure "dependency cycle not detected"+ pure ()+ ]+ where+ cook' = cook allowSelfDeps+ cookNonEmpty' = cookNonEmpty . fmap (allowSelfDeps,)++main :: IO ()+main = defaultMain tests