cauldron 0.4.0.0 → 0.6.0.0

raw patch · 12 files changed

+2433/−1225 lines, 12 filesdep −multicurryabledep −sop-corePVP ok

version bump matches the API change (PVP)

Dependencies removed: multicurryable, sop-core

API changes (from Hackage documentation)

Files

• CHANGELOG.md +40/−0
• README.md +162/−0
• app/Main.hs +50/−45
• cauldron.cabal +19/−7
• lib/Cauldron.hs +1184/−1081
• lib/Cauldron/Args.hs +434/−0
• lib/Cauldron/Beans.hs +152/−0
• test/appTests.hs +39/−33
• test/argsTests.hs +72/−0
• test/codecTests.hs +161/−0
• test/managedTests.hs +14/−13
• test/tests.hs +106/−46

@@ -1,5 +1,45 @@ # Revision history for cauldron +## 0.6.0.0++* Remove sop-core dependency, incorporate just the needed functionality into the library.++  Also make the internals of the library less dependent on n-ary tuples. Now+  they are more of an added layer for convenience.++* The `cook` family of functions don't return a `DependencyGraph` anymore. Instead, the +  graph can be obtained at any moment using `getDependencyGraph`, even for non-wireable `Cauldron`s.++* `BoiledBeans` is now just `Beans` and has its own module.++* A new `Cauldron.Args` module which defines the `Args` applicative.++* The way of creating `Constructor`s has been overhauled.++  `Packer` and `pack` are gone, along with `value`, `eff` and similar functions. The old `Regs` type is gone.++  To create `Constructor`s, now we should use `val` and `eff` along with `wire`.++* The `Bean` record is now called `Recipe`. There's also a `SomeRecipe` that hides the bean type parameter.+ +* New `ToRecipe` typeclass that helps treating single `Constructor`s as recipes-without-decos.++* The `Decos` type is now just a `Seq` of constructors of the same type.++* New `allowDepCycles` `Fire`.++* Now `DependencyGraph` renders all the dependencies, even those that are ignored during plan construction to allow for dependency cycles.++* New `Monoid` instance for `DependencyGraph`.++* `BadBeans` is now `RecipeError`. It has now an `Exception` instance and a pretty function.++* `exportToDot` is now `writeAsDot` and accepts a `RecipeError` to highlight problematic nodes.++* Now `Constructor`s and `Recipe`s keep track of the `CallStack` of when they were created. This is used+  by errors to print the relevant code locations.+  Because now we have code locations, `PathToCauldron` is no longer useful and has been removed.+ ## 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,0 +1,162 @@+# cauldron++> Double, double toil and trouble;+>+> Fire burn and caldron bubble.+>+> Fillet of a fenny snake,+>+> In the caldron boil and bake;++**cauldron** is a library for performing dependency injection. It's an alternative to+manually wiring the constructors for the components ("beans") of your+application. ++It expects the bean constructors to conform to a certain shape.++**cauldron** should be used at the [composition root](https://stackoverflow.com/questions/6277771/what-is-a-composition-root-in-the-context-of-dependency-injection). Bean constructors shouldn't be aware that **cauldron** exists, or depend on its types.++**cauldron** relies on dynamic typing and finds wiring errors at runtime, not compilation time.++# Why you should(n't) use this library++To be honest, you probably shouldn't use this library. I have noticed that using+**cauldron** is actually *more* verbose that manually doing the wiring yourself.+Perhaps it would start to pay for complex beans with many dependencies, but+I'm not sure.++Another possible objection to this library is that wiring errors are detected at+runtime. I don't find that to be a problem though: the wiring happens at the+very beginning of the application, and it's easy to write an unit test for it.++On the plus side, this library lets you render the graph of dependencies between+beans, something which is difficult to do with naive manual wiring.++Another advantage is that you can easily modify an existing web of dependencies,+be it by inserting a new bean, overriding another, or adding a decorator.++# The expected shape of constructors++**cauldron** expects "bean" constructors to have a shape like:++```+makeServer :: Logger -> Repository -> Server+```++Where `Logger`, `Repository` and `Server` are [records-of-functions](https://www.iankduncan.com/articles/2024-01-26-records-of-effects). `Server` is+the component produced by this constructor, and it has `Logger` and `Repository`+as dependencies.++Sometimes constructors are effectful because they must perform some+initialization (for example allocating some `IORef` for the internal `Server`+state). In that case the shape of the constructor becomes something like:++```+makeServer :: Logger -> Repository -> IO Server+```++or even, for constructors which want to ensure that [resources are+deallocated](https://hackage.haskell.org/package/managed) after we are finished using the bean:++```+makeServer :: Logger -> Repository -> Managed Server+```++Having more than one constructor for the same bean type is disallowed. The+wiring is *type-directed*, so there can't be any ambiguity about which bean+constructor to use.++## Monoidally aggregated secondary beans++More complex constructors can return—besides a "primary" bean as seen in the+previous section—one or more "secondary" beans. For example:++```+makeServer :: Logger -> Repository -> (Initializer, Inspector, Server)+```++or ++```+makeServer :: Logger -> Repository -> IO (Initializer, Inspector, Server)+```++These secondary outputs of a constructor, like `Initializer` and `Inspector`,+must have `Monoid` instances. Unlike with the "primary" bean the constructor produces, they+*can* be produced by more than one constructor. Their values will be aggregated+across all the constructors that produce them.++Constructors can depend on the aggregated value of a secondary bean by taking+the bean as a regular argument. Here, `makeDebuggingServer` receives the+`mappend`ed value of all the `Inspector`s produced by other constructors (or+`mempty`, if no constructor produces them):++```+makeDebuggingServer :: Inspector -> IO DebuggingServer+```++## Decorators++Decorators are like normal constructors, but they're used to *modify* a primary+bean, instead of *producing* it. Because of that, they usually take the bean+they decorate as an argument:++```+makeServerDecorator :: Server -> Server+```++Like normal constructors, decorators can have their own dependencies (other than the+decorated bean), perform effects, and register secondary beans:++```+makeServerDecorator :: Logger -> Server -> IO (Initializer,Server)+```++# Example code++See [this example application](/app/Main.hs) with dummy components.++For a slightly more realistic example, see [here](https://github.com/danidiaz/comments-project/blob/8206c50b9af2097e2246cec0992d489029b84686/comments/lib/Comments/Main.hs#L36).++# Similarities with the [Java Spring framework IoC container](https://docs.spring.io/spring-framework/reference/core/beans.html)++Some features of this library have loose analogues in how Java Spring handles+dependency injection (although of course Spring has many more features).++First, a big *difference*: there's no analogue here of annotations, or classpath+scanning. Beans and decorators must be explicitly registered. ++- Java POJOs are Haskell [records-of-functions](https://www.iankduncan.com/articles/2024-01-26-records-of-effects), where the functions will usually+be closures which encapsulate access to some shared internal state (state like+configuration values, or mutable references). Functions that return+records-of-functions correspond to POJO constructors.++- [@PostConstruct](https://docs.spring.io/spring-framework/reference/core/beans/annotation-config/postconstruct-and-predestroy-annotations.html#page-title) roughly corresponds to effectful constructors.++  Although I expect effectful constructors to be used comparatively more in this+ library than in Spring, because here they're required to initialize mutable+ references used by the beans.++- [decorated self-invocations](https://docs.spring.io/spring-framework/reference/core/aop/proxying.html#aop-understanding-aop-proxies) correspond to constructors that+  depend on the same bean that they produce.++  Note that this is different from decorators that depend on the bean they+  modify. The constructor will receive the fully decorated bean "from the+  future" (with the possibility of infinite loops if it makes use of it too+  eagerly). In contrast, a decorator will receive either the bare "undecorated"+  bean, or the in-construction result of applying the decorators that come+  earlier in the decorator sequence.++- [context hierachies](https://docs.spring.io/spring-framework/reference/testing/testcontext-framework/ctx-management/hierarchies.html) correspond to distributing the constructors into various sets organized in parent-child relationships, so that constructors in a child can see the beans of the parent, but not vice-versa. ++- [injecting all the beans that implement a certain interface as a list](https://twitter.com/NiestrojRobert/status/1746808940435042410) roughly corresponds to a constructor that takes a monoidally aggregated "secondary bean" as an argument. ++Some features I'm not yet sure how to mimic:++- [bean scopes](https://docs.spring.io/spring-framework/reference/core/beans/factory-scopes.html), like [request scope](https://docs.spring.io/spring-framework/reference/core/beans/factory-scopes.html#beans-factory-scopes-other-injection). [This Stack Overflow post](https://stackoverflow.com/a/77174979/1364288) gives some information about how they are implemented in Spring.++  The SO post explains that in Spring the injection of request scoped beans into long-lived beans involves thread-local variables. I explored such a technique for Cauldron [here](https://discourse.haskell.org/t/i-got-rid-of-readert-and-now-my-application-is-hanging-by-a-thread/9330).++# See also++- [registry](https://hackage.haskell.org/package/registry) is a more mature and useable library for dependency injection in Haskell. See [this explanatory video](https://www.youtube.com/watch?v=fFCcvsbCrH8).

@@ -1,5 +1,5 @@-{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedLists #-}  -- | 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@@ -10,7 +10,6 @@ module Main where  import Cauldron-import Data.Function ((&)) import Data.Maybe (fromJust)  {-@@ -122,7 +121,7 @@ -- -- Dependency cycles of more than one bean are forbidden, however. makeG :: E -> F -> G -> G-makeG _ _ !_ = G+makeG _ _ _ = G  -- | A decorator. --@@ -155,7 +154,9 @@ makeZDeco2 :: (F -> Z -> (Initializer, Z)) makeZDeco2 = \_ z -> (Initializer (putStrLn "Z deco init"), z) -boringWiring :: IO (Initializer, Inspector, Z)+data Entrypoint = Entrypoint Initializer Inspector Z++boringWiring :: IO Entrypoint boringWiring = do   let -- We have to remember to collect the monoidal registrations.       initializer = init1 <> init2@@ -178,63 +179,67 @@       z1 = makeZDeco1 b e z0       (init2, z2) = makeZDeco2 f z1       z = z2-  pure (initializer, inspector, z)+  pure $ Entrypoint 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+coolWiring :: Either RecipeError (IO Entrypoint)+coolWiring = fmap (fmap (fromJust . taste @Entrypoint)) $ cook allowSelfDeps cauldron +cauldron :: Cauldron IO+cauldron :: Cauldron IO =+  [ recipe @A $ val $ pure makeA,+    recipe @B $ val $ pure makeB,+    recipe @C $ val $ wire makeC,+    recipe @D $ val $ wire makeD,+    recipe @E $ val $ wire makeE,+    recipe @F $ val $ wire makeF,+    recipe @G $+      Recipe+        { bean = val $ wire makeG,+          decos =+            [ val $ wire makeGDeco1+            ]+        },+    recipe @H $ val $ wire makeH,+    recipe @Z+      Recipe+        { bean = val $ wire makeZ,+          decos =+            [ val $ wire makeZDeco1,+              val $ wire makeZDeco2+            ]+        },+    recipe @Entrypoint $ val $ wire Entrypoint+  ]+ main :: IO () main = do+  -- "manual" wiring   do-    (Initializer {runInitializer}, Inspector {inspect}, z) <- boringWiring+    Entrypoint (Initializer {runInitializer}) (Inspector {inspect}) z <- boringWiring     inspection <- inspect     print inspection     print z     runInitializer-  case coolWiring allowSelfDeps of+  -- wiring with Cauldron+  merr <- case coolWiring 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+      putStrLn $ prettyRecipeError badBeans+      pure $ Just badBeans+    Right action -> do+      Entrypoint (Initializer {runInitializer}) (Inspector {inspect}) z <- action       inspection <- inspect       print inspection       print z       runInitializer+      pure $ Nothing+  let depGraph = getDependencyGraph cauldron+  writeAsDot (defaultStyle merr) "beans.dot" depGraph+  writeAsDot (defaultStyle merr) "beans-no-agg.dot" $ removeSecondaryBeans $ depGraph+  writeAsDot (defaultStyle merr) "beans-no-agg-no-decos.dot" $ removeDecos $ removeSecondaryBeans $ depGraph+  writeAsDot (defaultStyle merr) "beans-simple.dot" $ collapseToPrimaryBeans $ removeDecos $ removeSecondaryBeans $ depGraph+  writeAsDot (defaultStyle merr) "beans-simple-with-decos.dot" $ collapseToPrimaryBeans $ removeSecondaryBeans $ depGraph

@@ -1,18 +1,18 @@ 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.+version:            0.6.0.0+synopsis:           Dependency injection library+description:        Dependency injection library 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-doc-files:    README.md, CHANGELOG.md -- extra-source-files: category: Dependency Injection-tested-with: GHC ==9.8.1 || ==9.6.3+tested-with: GHC ==9.8.2 source-repository    head     type:     git     location: https://github.com/danidiaz/cauldron.git@@ -35,18 +35,19 @@       tasty           ^>= 1.5,       tasty-hunit     ^>= 0.10,       transformers >= 0.5 && < 0.7,+      algebraic-graphs ^>= 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.Beans+        Cauldron.Args         Cauldron.Managed  executable cauldron-example-wiring@@ -63,6 +64,12 @@     hs-source-dirs:   test     main-is:          tests.hs +test-suite codec-tests+    import:           common-tests+    type:             exitcode-stdio-1.0+    hs-source-dirs:   test+    main-is:          codecTests.hs+ test-suite app-tests     import:           common-tests     type:             exitcode-stdio-1.0@@ -75,3 +82,8 @@     hs-source-dirs:   test     main-is:          managedTests.hs +test-suite tests-args+    import:           common-tests+    type:             exitcode-stdio-1.0+    hs-source-dirs:   test+    main-is:          argsTests.hs

@@ -1,1081 +1,1184 @@-{-# 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+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeFamilies #-}+{-# 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.+--+-- These extensions, while not required, play well with the library:+--+-- @+-- {-# LANGUAGE ApplicativeDo #-} -- For building complex values in the Args applicative.+-- {-# LANGUAGE OverloadedLists #-} -- For avoiding explicit calls to fromRecipeList and fromDecoList+-- @+--+-- An example of using a 'Cauldron' to wire the constructors of dummy @A@, @B@, @C@ datatypes:+--+-- >>> :{+-- 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 = [+--           recipe @A $ val $ wire makeA,+--           recipe @B $ val $ wire makeB,+--           recipe @C $ eff $ wire makeC -- we use eff because the constructor has IO effects+--         ]+--   action <- either throwIO pure $ cook forbidDepCycles cauldron+--   beans <- action+--   pure $ taste @C beans+-- :}+-- Just C+module Cauldron+  ( -- * Filling the cauldron+    Cauldron,+    empty,+    insert,+    adjust,+    delete,+    keysSet,+    restrictKeys,+    fromRecipeList,+    toRecipeMap,+    hoistCauldron,+    hoistCauldron',++    -- * Recipes+    Recipe (..),+    ToRecipe,+    fromDecoList,+    (Data.Sequence.|>),+    (Data.Sequence.<|),+    hoistRecipe,+    hoistRecipe',++    -- ** How decorators work+    -- $decos++    -- ** Hiding a 'Recipe''s bean type+    SomeRecipe,+    recipe,+    withRecipe,+    getRecipeCallStack,++    -- * Constructors+    -- $constructors+    Constructor,+    val_,+    val,+    val',+    eff_,+    eff,+    eff',+    wire,+    getConstructorArgs,+    getConstructorCallStack,+    hoistConstructor,+    hoistConstructor',++    -- ** Registering secondary beans+    -- $secondarybeans++    -- * Cooking the beans+    cook,+    cookNonEmpty,+    cookTree,++    -- ** How loopy can we get?+    Fire,+    forbidDepCycles,+    allowSelfDeps,+    allowDepCycles,++    -- ** Tasting the results+    Beans,+    taste,++    -- ** When things go wrong+    RecipeError (..),+    MissingDependencies (..),+    DoubleDutyBeans (..),+    DependencyCycle (..),+    prettyRecipeError,+    prettyRecipeErrorLines,++    -- ** Visualizing dependencies between beans.+    getDependencyGraph,+    DependencyGraph,+    writeAsDot,+    defaultStyle,+    setVertexName,+    BeanConstructionStep (..),+    toAdjacencyMap,++    -- *** Simplifying the dep graph+    -- $simplifygraph+    removeSecondaryBeans,+    removeDecos,+    collapseToPrimaryBeans,+  )+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 Cauldron.Args+import Cauldron.Beans (SomeMonoidTypeRep (..))+import Cauldron.Beans qualified+import Control.Exception (Exception (..))+import Control.Monad.Fix+import Data.Bifunctor (first)+import Data.ByteString qualified+import Data.Dynamic+import Data.Foldable qualified+import Data.Function ((&))+import Data.Functor ((<&>))+import Data.Functor.Identity (Identity (..))+import Data.Kind+import Data.List qualified+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.Semigroup qualified+import Data.Sequence (Seq)+import Data.Sequence qualified+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.Exception (CallStack, prettyCallStackLines)+import GHC.IsList+import GHC.Stack (HasCallStack, callStack, withFrozenCallStack)+import Type.Reflection qualified++-- | A map of bean recipes, indexed by the 'TypeRep' of the bean each recipe+-- ultimately produces. Only one recipe is allowed for each bean type.+-- Parameterized by the monad @m@ in which the recipe 'Constructor's might have+-- effects.+type Cauldron :: (Type -> Type) -> Type+newtype Cauldron m where+  Cauldron :: {recipeMap :: Map TypeRep (SomeRecipe m)} -> Cauldron m++empty :: Cauldron m+empty = Cauldron Map.empty++-- | Union of two 'Cauldron's, right-biased: prefers 'Recipe's from the /right/ cauldron when+-- both contain the same key. (Note that 'Data.Map.Map' is left-biased.)+instance Semigroup (Cauldron m) where+  Cauldron {recipeMap = r1} <> Cauldron {recipeMap = r2} = Cauldron do Map.unionWith (flip const) r1 r2++instance Monoid (Cauldron m) where+  mempty = Cauldron Map.empty++instance IsList (Cauldron m) where+  type Item (Cauldron m) = SomeRecipe m+  toList (Cauldron {recipeMap}) = Map.elems recipeMap+  fromList = fromRecipeList++-- | Change the monad used by the 'Recipe's in the 'Cauldron'.+hoistCauldron :: (forall x. m x -> n x) -> Cauldron m -> Cauldron n+hoistCauldron f (Cauldron {recipeMap}) = Cauldron {recipeMap = hoistSomeRecipe f <$> recipeMap}++-- | More general form of 'hoistCauldron' that lets you modify the 'Args'+-- inside all the 'Recipe's in the 'Cauldron'. See 'hoistRecipe''.+hoistCauldron' ::+  -- | Transformation to apply to the base constructor of each recipe.+  (forall x. (Typeable x) => Args (m (Regs x)) -> Args (n (Regs x))) ->+  -- | Transformation to apply to each decorator. Takes the decorator index as parameter.+  (forall x. (Typeable x) => Int -> Args (m (Regs x)) -> Args (n (Regs x))) ->+  Cauldron m ->+  Cauldron n+hoistCauldron' f fds Cauldron {recipeMap} =+  Cauldron+    { recipeMap = Map.map (hoistSomeRecipe' f fds) recipeMap+    }++-- | In order to put recipes producing different bean types into a container, we+-- need to hide each recipe's bean type. This wrapper allows that.+type SomeRecipe :: (Type -> Type) -> Type+data SomeRecipe m where+  SomeRecipe :: (Typeable bean) => {_recipeCallStack :: CallStack, _recipe :: Recipe m bean} -> SomeRecipe m++-- | Build a 'SomeRecipe' from a 'Recipe' or a 'Constructor'. See 'ToRecipe'.+--+-- Useful in combination with 'fromRecipeList'.+recipe ::+  forall {recipelike} {m} bean.+  (ToRecipe recipelike, Typeable bean, HasCallStack) =>+  -- | A 'Recipe' or a 'Constructor'.+  recipelike m bean ->+  SomeRecipe m+recipe theRecipe = withFrozenCallStack do+  SomeRecipe callStack (toRecipe theRecipe)++-- | Access the 'Recipe' inside a 'SomeRecipe'.+withRecipe :: forall {m} r. (forall bean. (Typeable bean) => Recipe m bean -> r) -> SomeRecipe m -> r+withRecipe f (SomeRecipe {_recipe}) = f _recipe++getRecipeRep :: SomeRecipe m -> TypeRep+getRecipeRep = withRecipe go+  where+    go :: forall bean m. (Typeable bean) => Recipe m bean -> TypeRep+    go _ = typeRep (Proxy @bean)++fromRecipeList :: [SomeRecipe m] -> Cauldron m+fromRecipeList =+  foldMap \sr -> Cauldron {recipeMap = Map.singleton (getRecipeRep sr) sr}++toRecipeMap :: Cauldron m -> Map TypeRep (SomeRecipe m)+toRecipeMap Cauldron {recipeMap} = recipeMap++hoistSomeRecipe :: (forall x. m x -> n x) -> SomeRecipe m -> SomeRecipe n+hoistSomeRecipe f r@SomeRecipe {_recipe} = r {_recipe = hoistRecipe f _recipe}++hoistSomeRecipe' ::+  forall m n.+  (forall x. (Typeable x) => Args (m (Regs x)) -> Args (n (Regs x))) ->+  (forall x. (Typeable x) => Int -> Args (m (Regs x)) -> Args (n (Regs x))) ->+  SomeRecipe m ->+  SomeRecipe n+hoistSomeRecipe' f fds sr = withRecipe go sr+  where+    go :: forall bean. (Typeable bean) => Recipe m bean -> SomeRecipe n+    go r = sr {_recipe = hoistRecipe' (f @bean) (fds @bean) r}++-- | Instructions for how to build a value of type @bean@ while possibly+-- performing actions in the monad @m@.+--+-- Because the instructions aren't really run until the 'Cauldron' is 'cook'ed,+-- they can be modified with functions like 'adjust', in order to change the+-- base bean 'Constructor', or add or remove decorators.+type Recipe :: (Type -> Type) -> Type -> Type+data Recipe m bean = Recipe+  { -- | How to build the bean itself.+    bean :: Constructor m bean,+    -- | A 'Data.Sequence.Sequence' of decorators that will wrap the bean. There might be no decorators.+    --+    -- See 'fromDecoList', 'Data.Sequence.|>' and 'Data.Sequence.<|'.+    decos :: Seq (Constructor m bean)+  }++fromDecoList :: [Constructor m bean] -> Seq (Constructor m bean)+fromDecoList = Data.Sequence.fromList++-- | Convenience typeclass that allows passing either 'Recipe's or 'Constructor's+-- to the 'insert' and 'recipe' functions.+type ToRecipe :: ((Type -> Type) -> Type -> Type) -> Constraint+class ToRecipe recipelike where+  toRecipe :: recipelike m bean -> Recipe m bean++-- | Simply identity.+instance ToRecipe Recipe where+  toRecipe = id++-- | 'Constructor' is converted to a 'Recipe' without decorators.+instance ToRecipe Constructor where+  toRecipe bean = Recipe {bean, decos = Data.Sequence.empty}++-- | Change the monad used by the bean\'s main 'Constructor' and its decos.+hoistRecipe :: (forall x. m x -> n x) -> Recipe m bean -> Recipe n bean+hoistRecipe f (Recipe {bean, decos}) =+  Recipe+    { bean = hoistConstructor f bean,+      decos = hoistConstructor f <$> decos+    }++-- | More general form of 'hoistRecipe' that enables precise control over the inner `Args`+-- of each constructor in the 'Recipe'.+hoistRecipe' ::+  -- | Transformation to apply to the base constructor.+  (Args (m (Regs bean)) -> Args (n (Regs bean))) ->+  -- | Transformation to apply to each decorator. Takes the decorator index as parameter.+  (Int -> Args (m (Regs bean)) -> Args (n (Regs bean))) ->+  Recipe m bean ->+  Recipe n bean+hoistRecipe' f fds (Recipe {bean, decos}) =+  Recipe+    { bean = hoistConstructor' f bean,+      decos = Data.Sequence.mapWithIndex (\i deco -> hoistConstructor' (fds i) deco) decos+    }++-- $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 and logging to the functions.+--+-- The order of the decorators in the sequence is the order in which they modify+-- the underlying bean. First decorator wraps first, last decorator wraps last.+--+-- >>> :{+-- 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 = [+--           recipe @Foo $ Recipe {+--             bean = val $ wire makeFoo,+--             decos = [+--                  val $ wire makeFooDeco1,+--                  eff $ wire makeFooDeco2+--               ]+--           }+--         ]+--   action <- either throwIO pure $ cook forbidDepCycles cauldron+--   beans <- action+--   let Just Foo {sayFoo} = taste beans+--   sayFoo+-- :}+-- deco2 init+-- deco2 enter+-- deco1 enter+-- foo+-- deco1 exit+-- deco2 exit++-- $constructors+--+-- Bean-producing and bean-decorating functions need to be coaxed into 'Constructor's in order to be used in 'Cauldron's.++data ConstructorReps where+  ConstructorReps ::+    { beanRep :: TypeRep,+      argReps :: Set TypeRep,+      regReps :: Map TypeRep Dynamic+    } ->+    ConstructorReps++-- | Put a 'Recipe' into the 'Cauldron'.+--+-- Only one recipe is allowed for each bean type, so 'insert' for a+-- bean will overwrite any previous recipe for that bean.+insert ::+  forall {recipelike} {m} (bean :: Type).+  (Typeable bean, ToRecipe recipelike, HasCallStack) =>+  -- | A 'Recipe' or a 'Constructor'.+  recipelike m bean ->+  Cauldron m ->+  Cauldron m+insert recipelike Cauldron {recipeMap} = withFrozenCallStack do+  let rep = typeRep (Proxy @bean)+  Cauldron {recipeMap = Map.insert rep (SomeRecipe callStack (toRecipe recipelike)) recipeMap}++-- | Tweak a 'Recipe' inside the 'Cauldron', if the recipe exists.+adjust ::+  forall {m} bean.+  (Typeable bean) =>+  (Recipe m bean -> Recipe m bean) ->+  Cauldron m ->+  Cauldron m+adjust f (Cauldron {recipeMap}) = withFrozenCallStack do+  let rep = typeRep (Proxy @bean)+  Cauldron+    { recipeMap =+        recipeMap+          & Map.adjust+            do+              \r@SomeRecipe {_recipe = _recipe :: Recipe m a} ->+                case testEquality (Type.Reflection.typeRep @bean) (Type.Reflection.typeRep @a) of+                  Nothing -> error "should never happen"+                  Just Refl -> r {_recipe = f _recipe}+            rep+    }++delete ::+  forall m.+  TypeRep ->+  Cauldron m ->+  Cauldron m+delete tr Cauldron {recipeMap} =+  Cauldron {recipeMap = Map.delete tr recipeMap}++-- | Strategy for dealing with dependency cycles.+--+-- (The name is admittedly uninformative; the culinary metaphor was stretched too far.)+data Fire m = Fire+  { shouldOmitDependency :: (BeanConstructionStep, BeanConstructionStep) -> Bool,+    followPlanCauldron ::+      Cauldron m ->+      Set TypeRep ->+      Beans ->+      Plan ->+      m Beans+  }++removeBeanFromArgs :: ConstructorReps -> ConstructorReps+removeBeanFromArgs ConstructorReps {argReps, regReps, beanRep} =+  ConstructorReps {argReps = Set.delete beanRep argReps, regReps, beanRep}++-- | 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 _secondaryBeanReps initial plan ->+        Data.Foldable.foldlM+          do followPlanStep (\_ -> id) (\_ -> id) cauldron mempty+          initial+          plan+    }++-- | 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.+--+-- Note that a 'MonadFix' instance is required of the initialization monad.+--+-- __BEWARE__: Pattern-matching too eagerly on a \"bean from the future\" during+-- construction will cause infinite loops or, if you are lucky, throw+-- 'Control.Exception.FixIOException's.+allowSelfDeps :: (MonadFix m) => Fire m+allowSelfDeps =+  Fire+    { shouldOmitDependency = \case+        (BarePrimaryBean bean, PrimaryBean anotherBean) | bean == anotherBean -> True+        _ -> False,+      followPlanCauldron = \cauldron _secondaryBeanReps initial plan ->+        mfix do+          \final ->+            Data.Foldable.foldlM+              do followPlanStep Cauldron.Beans.delete (\_ -> id) cauldron final+              initial+              plan+    }++-- | Allow /any/ kind of dependency cycles.+--+-- Usually comes in handy for creating serializers / deserializers for mutually+-- dependent types.+--+-- Note that a 'MonadFix' instance is required of the initialization monad.+--+-- __BEWARE__: Pattern-matching too eagerly on argument beans during+-- construction will cause infinite loops or, if you are lucky, throw+-- 'Control.Exception.FixIOException's.+allowDepCycles :: (MonadFix m) => Fire m+allowDepCycles =+  Fire+    { shouldOmitDependency = \case+        (BarePrimaryBean _, PrimaryBean _) -> True+        (PrimaryBeanDeco _ _, PrimaryBean _) -> True+        _ -> False,+      followPlanCauldron = \cauldron secondaryBeanReps initial plan -> do+        let makeBareView _ = (`Cauldron.Beans.restrictKeys` secondaryBeanReps)+        let makeDecoView tr = (`Cauldron.Beans.restrictKeys` (Set.insert tr secondaryBeanReps))+        mfix do+          \final ->+            Data.Foldable.foldlM+              do followPlanStep makeBareView makeDecoView cauldron final+              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 :: forall {m} bean. (Typeable bean) => Constructor m bean -> ConstructorReps+constructorReps (getConstructorArgs -> c) =+  ConstructorReps+    { beanRep = typeRep (Proxy @bean),+      argReps = getArgsReps c,+      regReps =+        c+          & getRegsReps+          & Set.map (\mtr@(SomeMonoidTypeRep tr) -> Data.Semigroup.Arg (Type.Reflection.SomeTypeRep tr) (toDyn (Cauldron.Beans.someMonoidTypeRepMempty mtr)))+          & Map.fromArgSet+    }++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)++-- | Build the beans using the recipeMap stored in the 'Cauldron'.+--+-- Any secondary beans that are registered by constructors are aggregated+-- monoidally.+cook ::+  forall m.+  (Monad m) =>+  Fire m ->+  Cauldron m ->+  Either RecipeError (m Beans)+cook fire cauldron =+  fmap @(Either RecipeError) (fmap @m rootLabel) $+    cookTree (Node (fire, cauldron) [])++-- | Cook a nonempty 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 RecipeError (m (NonEmpty Beans))+cookNonEmpty nonemptyCauldronList = do+  fmap @(Either RecipeError) (fmap @m unsafeTreeToNonEmpty) $+    cookTree (nonEmptyToTree nonemptyCauldronList)++-- | 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 RecipeError (m (Tree Beans))+cookTree (treecipes) = do+  accumMap <- first DoubleDutyBeansError do checkNoDoubleDutyBeans (snd <$> treecipes)+  () <- first MissingDependenciesError do checkMissingDeps (Map.keysSet accumMap) (snd <$> treecipes)+  treeplan <- first DependencyCycleError do buildPlans (Map.keysSet accumMap) treecipes+  Right $ followPlan (fromDynList (Data.Foldable.toList accumMap)) (treeplan)++newtype DoubleDutyBeans = DoubleDutyBeans (Map TypeRep (CallStack, CallStack))+  deriving stock (Show)++-- | Get a graph of dependencies between 'BeanConstructionStep's. The graph can+-- be obtained even if the 'Cauldron' can't be 'cook'ed successfully.+getDependencyGraph :: Cauldron m -> DependencyGraph+getDependencyGraph cauldron =+  let (accumMap, _) = cauldronRegs cauldron+      (_, deps) = buildDepsCauldron (Map.keysSet accumMap) cauldron+   in DependencyGraph {graph = Graph.edges deps}++checkNoDoubleDutyBeans ::+  Tree (Cauldron m) ->+  Either DoubleDutyBeans (Map TypeRep Dynamic)+checkNoDoubleDutyBeans treecipes = do+  let (accumMap, beanSet) = cauldronTreeRegs treecipes+  let common = Map.intersectionWith (,) (fst <$> accumMap) beanSet+  if not (Map.null common)+    then Left $ DoubleDutyBeans common+    else Right $ snd <$> accumMap++cauldronTreeRegs :: Tree (Cauldron m) -> (Map TypeRep (CallStack, Dynamic), Map TypeRep CallStack)+cauldronTreeRegs = foldMap cauldronRegs++cauldronRegs :: Cauldron m -> (Map TypeRep (CallStack, Dynamic), Map TypeRep CallStack)+cauldronRegs Cauldron {recipeMap} =+  Map.foldMapWithKey+    do \rep aRecipe -> (recipeRegs aRecipe, Map.singleton rep (getRecipeCallStack aRecipe))+    recipeMap++-- | Returns the accumulators, not the main bean+recipeRegs :: SomeRecipe m -> Map TypeRep (CallStack, Dynamic)+recipeRegs (SomeRecipe _ (Recipe {bean, decos})) = do+  let extractRegReps c = (getConstructorCallStack c,) <$> (\ConstructorReps {regReps} -> regReps) (constructorReps c)+  extractRegReps bean+    <> foldMap extractRegReps decos++data MissingDependencies = MissingDependencies CallStack TypeRep (Set TypeRep)+  deriving stock (Show)++checkMissingDeps ::+  -- | accums+  Set TypeRep ->+  Tree (Cauldron m) ->+  Either MissingDependencies ()+checkMissingDeps accums treecipes = do+  let decoratedTreecipes = decorate (Map.empty, treecipes)+      missing =+        decoratedTreecipes <&> \(available, requested) ->+          do checkMissingDepsCauldron accums (Map.keysSet available) requested+  sequence_ missing+  where+    decorate ::+      (Map TypeRep (SomeRecipe m), Tree (Cauldron m)) ->+      Tree (Map TypeRep (SomeRecipe m), Cauldron m)+    decorate = unfoldTree+      do+        \(acc, Node (current@Cauldron {recipeMap}) rest) ->+          let -- current level has priority+              newAcc = recipeMap `Map.union` acc+              newSeeds = do+                z <- rest+                [(newAcc, z)]+           in ((newAcc, current), newSeeds)++checkMissingDepsCauldron ::+  -- | accums+  Set TypeRep ->+  -- | available at this level+  Set TypeRep ->+  Cauldron m ->+  Either MissingDependencies ()+checkMissingDepsCauldron accums available cauldron =+  Data.Foldable.for_ (demandsByConstructorsInCauldron cauldron) \(stack, tr, demanded) ->+    let missing = Set.filter (`Set.notMember` (available `Set.union` accums)) demanded+     in if Set.null missing+          then Right ()+          else Left $ MissingDependencies stack tr missing++demandsByConstructorsInCauldron :: Cauldron m -> [(CallStack, TypeRep, Set TypeRep)]+demandsByConstructorsInCauldron Cauldron {recipeMap} = do+  (tr, SomeRecipe _ (Recipe {bean, decos})) <- Map.toList recipeMap+  ( let ConstructorReps {argReps = beanArgReps} = constructorReps bean+     in [(getConstructorCallStack bean, tr, beanArgReps)]+    )+    ++ do+      decoCon <- Data.Foldable.toList decos+      let ConstructorReps {argReps = decoArgReps} = constructorReps decoCon+       in [(getConstructorCallStack decoCon, tr, decoArgReps)]++newtype DependencyCycle = DependencyCycle (NonEmpty (BeanConstructionStep, Maybe CallStack))+  deriving stock (Show)++buildPlans :: Set TypeRep -> Tree (Fire m, Cauldron m) -> Either DependencyCycle (Tree (Plan, Fire m, Cauldron m))+buildPlans secondary = traverse \(fire@Fire {shouldOmitDependency}, cauldron) -> do+  let (locations, deps) = buildDepsCauldron secondary cauldron+  -- We may omit some dependency edges to allow for cyclic dependencies.+  let graph = Graph.edges $ filter (not . shouldOmitDependency) deps+  case Graph.topSort graph of+    Left recipeCycle ->+      Left $ DependencyCycle $ recipeCycle <&> \step -> (step, Map.lookup step locations)+    Right (reverse -> plan) -> do+      Right (plan, fire, cauldron)++buildDepsCauldron :: Set TypeRep -> Cauldron m -> (Map BeanConstructionStep CallStack, [(BeanConstructionStep, BeanConstructionStep)])+buildDepsCauldron secondary Cauldron {recipeMap} = do+  -- Are we depending on a primary bean, or on a monoidally aggregated secondary bean?+  -- I wonder if we could make this more uniform, it's kind of annoying to have to make this decision here...+  let makeTargetStep :: TypeRep -> BeanConstructionStep+      makeTargetStep rep =+        if rep `Set.member` secondary+          then SecondaryBean rep+          else PrimaryBean rep+  recipeMap+    & Map.foldMapWithKey+      \beanRep+       SomeRecipe+         { _recipeCallStack,+           _recipe =+             Recipe+               { bean = bean :: Constructor m bean,+                 decos+               }+         } ->+          do+            let bareBean = BarePrimaryBean beanRep+                boiledBean = PrimaryBean beanRep+                decoSteps = do+                  (decoIndex, decoCon) <- zip [0 :: Int ..] (Data.Foldable.toList decos)+                  [(PrimaryBeanDeco beanRep decoIndex, decoCon)]+                beanDeps = do+                  constructorEdges makeTargetStep bareBean (constructorReps bean)+                decoDeps = do+                  (decoStep, decoCon) <- decoSteps+                  -- We remove the bean because from the args becase, in the+                  -- case of decos, we want to depend on the in-the-making+                  -- version of the bean, not the completed bean.+                  constructorEdges makeTargetStep decoStep (removeBeanFromArgs do constructorReps decoCon)+                innerSteps = bareBean Data.List.NonEmpty.:| (fst <$> decoSteps) ++ [boiledBean]+                innerDeps =+                  -- This explicit dependency between the completed bean and its+                  -- "bare" undecorated form is not strictly required. It will+                  -- always exist in an indirect manner, through the decorators.+                  -- But it might be useful when rendering the dep graph.+                  (PrimaryBean beanRep, BarePrimaryBean beanRep)+                    :+                    -- The dep chain of completed bean -> decorators -> bare bean.+                    zip (Data.List.NonEmpty.tail innerSteps) (Data.List.NonEmpty.toList innerSteps)+            ( Map.fromList $+                [ (bareBean, getConstructorCallStack bean),+                  (boiledBean, _recipeCallStack)+                ]+                  ++ do+                    (decoStep, decoCon) <- decoSteps+                    [(decoStep, getConstructorCallStack decoCon)],+              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) =>+  Beans ->+  (Tree (Plan, Fire m, Cauldron m)) ->+  m (Tree Beans)+followPlan initialBeans treecipes =+  let secondaryBeanReps = Cauldron.Beans.keysSet initialBeans+   in unfoldTreeM+        ( \(previousStageBeans, Node (plan, Fire {followPlanCauldron}, cauldron) rest) -> do+            currentStageBeans <- followPlanCauldron cauldron secondaryBeanReps previousStageBeans plan+            pure (currentStageBeans, (,) currentStageBeans <$> rest)+        )+        (initialBeans, treecipes)++followPlanStep ::+  (Monad m) =>+  (TypeRep -> Beans -> Beans) ->+  (TypeRep -> Beans -> Beans) ->+  Cauldron m ->+  Beans ->+  Beans ->+  BeanConstructionStep ->+  m Beans+followPlanStep makeBareView makeDecoView Cauldron {recipeMap} final super item =+  case item of+    BarePrimaryBean rep -> case fromJust do Map.lookup rep recipeMap of+      SomeRecipe {_recipe = Recipe {bean}} -> do+        let ConstructorReps {beanRep} = constructorReps bean+        -- We delete the beanRep before running the bean,+        -- 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.+        inserter <- followConstructor bean final (makeBareView beanRep super)+        pure do inserter super+    PrimaryBeanDeco rep index -> case fromJust do Map.lookup rep recipeMap of+      SomeRecipe {_recipe = Recipe {decos}} -> do+        let deco = decos `Data.Sequence.index` index+        let ConstructorReps {beanRep} = constructorReps deco+        -- Unlike before, we don't delete the beanRep before running the constructor.+        inserter <- followConstructor deco final (makeDecoView beanRep super)+        pure do inserter 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, Typeable bean) =>+  Constructor m bean ->+  Beans ->+  Beans ->+  m (Beans -> Beans)+followConstructor c final super = do+  (regs, bean) <- runConstructor [super, final] c+  pure \bs ->+    Cauldron.Beans.unionBeansMonoidally (getRegsReps (getConstructorArgs c)) bs regs+      & Cauldron.Beans.insert bean++-- | Sometimes the 'cook'ing process goes wrong.+data RecipeError+  = -- | The 'Cauldron' identified by 'PathToCauldron' has beans+    -- that depend on beans that can't be found either in the current 'Cauldron' or its ancestors.+    MissingDependenciesError MissingDependencies+  | -- | Beans that work both as primary beans and as secondary beans+    -- are disallowed.+    DoubleDutyBeansError DoubleDutyBeans+  | -- | Dependency cycles are disallowed by some 'Fire's.+    DependencyCycleError DependencyCycle+  deriving stock (Show)++instance Exception RecipeError where+  displayException = prettyRecipeError++prettyRecipeError :: RecipeError -> String+prettyRecipeError = Data.List.intercalate "\n" . prettyRecipeErrorLines++prettyRecipeErrorLines :: RecipeError -> [String]+prettyRecipeErrorLines = \case+  MissingDependenciesError+    (MissingDependencies constructorCallStack constructorResultRep missingDependenciesReps) ->+      [ "This constructor for a value of type "+          ++ show constructorResultRep+          ++ ":"+      ]+        ++ (("\t" ++) <$> prettyCallStackLines constructorCallStack)+        ++ [ "is missing the following dependencies:"+           ]+        ++ do+          rep <- Data.Foldable.toList missingDependenciesReps+          ["- " ++ show rep]+  DoubleDutyBeansError (DoubleDutyBeans doubleDutyMap) ->+    [ "The following beans work both as primary beans and secondary beans:"+    ]+      ++ ( flip Map.foldMapWithKey doubleDutyMap \rep (secCS, primCS) ->+             [ "- " ++ show rep ++ " is a secondary bean in this constructor:"+             ]+               ++ (("\t" ++) <$> prettyCallStackLines secCS)+               ++ [ "  and a primary bean in this recipe:"+                  ]+               ++ (("\t" ++) <$> prettyCallStackLines primCS)+         )+  DependencyCycleError (DependencyCycle theCycle) ->+    [ "Forbidden dependency cycle between bean construction steps:"+    ]+      ++ ( flip foldMap theCycle \(step, mstack) ->+             [ "- " ++ case step of+                 BarePrimaryBean rep -> "Bare bean " ++ show rep+                 PrimaryBeanDeco rep i -> "Decorator " ++ show i ++ " for bean " ++ show rep+                 PrimaryBean rep -> "Complete bean " ++ show rep+                 SecondaryBean rep -> "Secondary bean " ++ show rep+             ]+               ++ case mstack of+                 Nothing -> []+                 Just stack -> (("\t" ++) <$> prettyCallStackLines stack)+         )++-- | 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}+  deriving newtype (Show, Eq, Ord, Semigroup, Monoid)++-- | 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++-- | Remove all vertices and edges related to secondary beans.+removeSecondaryBeans :: DependencyGraph -> DependencyGraph+removeSecondaryBeans DependencyGraph {graph} =+  DependencyGraph {graph = Graph.induce (\case SecondaryBean {} -> False; _ -> True) graph}++-- | Remove all vertices and edges related to bean decorators.+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.+collapseToPrimaryBeans :: DependencyGraph -> DependencyGraph+collapseToPrimaryBeans 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).+writeAsDot :: Dot.Style BeanConstructionStep Data.Text.Text -> FilePath -> DependencyGraph -> IO ()+writeAsDot style filepath DependencyGraph {graph} = do+  let dot = Dot.export style graph+  Data.ByteString.writeFile filepath (Data.Text.Encoding.encodeUtf8 dot)++-- | Default DOT rendering style to use with 'writeAsDot'.+-- When a 'RecipeError' exists, is highlights the problematic 'BeanConstructionStep's.+defaultStyle :: Maybe RecipeError -> Dot.Style BeanConstructionStep Data.Text.Text+defaultStyle merr =+  -- https://graphviz.org/docs/attr-types/style/+  -- https://hackage.haskell.org/package/algebraic-graphs-0.7/docs/Algebra-Graph-Export-Dot.html+  (Dot.defaultStyle defaultStepToText)+    { Dot.vertexAttributes = \step -> case merr of+        Nothing -> []+        Just (MissingDependenciesError (MissingDependencies _ _ missing)) ->+          case step of+            PrimaryBean rep+              | Set.member rep missing ->+                  [ Data.Text.pack "style" Dot.:= Data.Text.pack "dashed",+                    Data.Text.pack "color" Dot.:= Data.Text.pack "red"+                  ]+            _ -> []+        Just (DoubleDutyBeansError (DoubleDutyBeans (Map.keysSet -> bs))) ->+          case step of+            PrimaryBean rep+              | Set.member rep bs ->+                  [ Data.Text.pack "style" Dot.:= Data.Text.pack "bold",+                    Data.Text.pack "color" Dot.:= Data.Text.pack "green"+                  ]+            SecondaryBean rep+              | Set.member rep bs ->+                  [ Data.Text.pack "style" Dot.:= Data.Text.pack "bold",+                    Data.Text.pack "color" Dot.:= Data.Text.pack "green"+                  ]+            _ -> []+        Just (DependencyCycleError (DependencyCycle (Set.fromList . Data.Foldable.toList . fmap fst -> cycleStepSet))) ->+          if Set.member step cycleStepSet+            then+              [ Data.Text.pack "style" Dot.:= Data.Text.pack "bold",+                Data.Text.pack "color" Dot.:= Data.Text.pack "blue"+              ]+            else []+    }++-- | Change the default way of how 'BeanConstructionStep's are rendered to text.+setVertexName :: (BeanConstructionStep -> Data.Text.Text) -> Dot.Style BeanConstructionStep Data.Text.Text -> Dot.Style BeanConstructionStep Data.Text.Text+setVertexName vertexName style = style {Dot.vertexName}++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 "#agg"++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"++-- | A way of building value of type @bean@, 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+-- constructor will allocate resources with bracket-like operations, and in that+-- case a monad like 'Cauldron.Managed.Managed' might be needed instead.+data Constructor m bean = Constructor+  { _constructorCallStack :: CallStack,+    _args :: Args (m (Regs bean))+  }++-- | Create a 'Constructor' from an 'Args' value that returns a 'bean'.+--+-- Usually, the 'Args' value will be created by 'wire'ing a constructor function.+val_ :: forall bean m. (Applicative m, HasCallStack) => Args bean -> Constructor m bean+val_ x = Constructor callStack $ fmap (pure . pure) x++-- | Like 'val_', but examines the @nested@ value returned by the 'Args' looking+-- for (potentially nested) tuples.  All tuple components except the+-- rightmost-innermost one are registered as secondary beans (if they have+-- 'Monoid' instances, otherwise 'val' won't compile).+val :: forall {nested} bean m. (Registrable nested bean, Applicative m, HasCallStack) => Args nested -> Constructor m bean+val x = withFrozenCallStack (val' $ fmap runIdentity $ register $ fmap Identity x)++-- | Like 'val', but uses an alternative form of registering secondary beans.+-- Less 'Registrable' typeclass magic, but more verbose.+val' :: forall bean m. (Applicative m, HasCallStack) => Args (Regs bean) -> Constructor m bean+val' x = Constructor callStack $ fmap pure x++-- | Create a 'Constructor' from an 'Args' value that returns an initialization+-- effect that produces 'bean'.+--+-- Usually, the 'Args' value will be created by 'wire'ing an effectul constructor function.+eff_ :: forall bean m. (Functor m, HasCallStack) => Args (m bean) -> Constructor m bean+eff_ x = Constructor callStack $ fmap (fmap pure) x++-- | Like 'eff_', but examines the @nested@ value produced by the action+-- returned by the 'Args' looking for (potentially nested) tuples.  All tuple+-- components except the rightmost-innermost one are registered as secondary+-- beans (if they have 'Monoid' instances, otherwise 'eff' won't compile).+eff :: forall {nested} bean m. (Registrable nested bean, Monad m, HasCallStack) => Args (m nested) -> Constructor m bean+eff x = withFrozenCallStack (eff' $ register x)++-- | Like 'eff', but uses an alternative form of registering secondary beans.+-- Less 'Registrable' typeclass magic, but more verbose.+eff' :: forall bean m. (HasCallStack) => Args (m (Regs bean)) -> Constructor m bean+eff' = Constructor callStack++runConstructor :: (Monad m) => [Beans] -> Constructor m bean -> m (Beans, bean)+runConstructor bss (Constructor {_args}) = do+  regs <- _args & runArgs (Data.Foldable.asum (taste <$> bss))+  pure (runRegs (getRegsReps _args) regs)++-- | 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 c@Constructor {_args} = c {_args = fmap f _args}++-- | More general form of 'hoistConstructor' that enables precise control over the inner `Args`.+hoistConstructor' :: (Args (m (Regs bean)) -> Args (n (Regs bean))) -> Constructor m bean -> Constructor n bean+hoistConstructor' f c@Constructor {_args} = c {_args = f _args}++-- | Get the inner 'Args' value for the 'Constructor', typically for inspecting+-- 'TypeRep's of its arguments/registrations.+getConstructorArgs :: Constructor m bean -> Args (m (Regs bean))+getConstructorArgs (Constructor {_args}) = _args++-- | For debugging purposes, 'Constructor's remember the 'CallStack'+-- of when they were created.+getConstructorCallStack :: Constructor m bean -> CallStack+getConstructorCallStack (Constructor {_constructorCallStack}) = _constructorCallStack++-- | For debugging purposes, 'SomeRecipe's remember the 'CallStack'+-- of when they were created.+getRecipeCallStack :: SomeRecipe m -> CallStack+getRecipeCallStack (SomeRecipe {_recipeCallStack}) = _recipeCallStack++-- | The set of all 'TypeRep' keys of the map.+keysSet :: Cauldron m -> Set TypeRep+keysSet Cauldron {recipeMap} = Map.keysSet recipeMap++-- | Restrict a 'Cauldron' to only those 'TypeRep's found in a 'Set'.+restrictKeys :: Cauldron m -> Set TypeRep -> Cauldron m+restrictKeys Cauldron {recipeMap} trs = Cauldron {recipeMap = Map.restrictKeys recipeMap trs}++-- $simplifygraph+--+-- 'DependencyGraph's can get complex and difficult to intepret because they+-- include bean decorators and secondary beans, details in which we many not be+-- interested.+--+-- These functions help simplify 'DependencyGraph's before passing them to+-- 'writeAsDot'. They can be composed between themselves.++-- $secondarybeans+--+-- There is an exception to the 'Cauldron' rule that each bean type can only+-- be produced by a single 'Recipe' in the 'Cauldron'.+--+-- 'Constructor's can produce, besides their \"primary\" bean result,+-- \"secondary\" beans that are not reflected in the 'Constructor' signature.+-- Multiple constructors across different recipeMap can produce secondary beans of the+-- same type.+--+-- Secondary beans are a bit special, in that:+--+-- * The value that is \"seen"\ by a 'Constructor' that depends on a secondary bean+--   is the aggregation of /all/ values produced for that bean in the 'Cauldron'. This+--   means that secondary beans must have 'Monoid' instances, to enable aggregation.+--+-- * When calculating build plan steps for a 'Cauldron', 'Constructor's that depend on a+--   secondary bean come after /all/ of the 'Constructor's that produce that secondary bean.+--+-- * Secondary beans can't be decorated.+--+-- * A bean type can't be primary and secondary at the same time. See 'DoubleDutyBeansError'.+--+-- What are secondary beans useful for?+--+-- * Exposing some uniform control or inspection interface for certain beans.+--+-- * Registering tasks or workers that must be run after application initialization.+--+-- The simplest way of registering secondary beans is to pass an 'Args' value returning a tuple+-- to the 'val' (for pure constructors) or 'eff' (for effectful constructors) functions. Components+-- of the tuple other than the rightmost component are considered secondary beans:+--+-- >>> :{+-- con :: Constructor Identity String+-- con = val $ pure (Sum @Int, All False, "foo")+-- effCon :: Constructor IO String+-- effCon = eff $ pure $ pure @IO (Sum @Int, All False, "foo")+-- :}+--+-- Example of how secondary bean values are accumulated:+--+-- >>> :{+-- data U = U deriving Show+-- data V = V deriving Show+-- makeU :: (Sum Int, U)+-- makeU = (Sum 1, U)+-- makeV :: U -> (Sum Int, V)+-- makeV = \_ -> (Sum 7, V)+-- newtype W = W (Sum Int) deriving Show -- depends on the secondary bean+-- :}+--+-- >>> :{+-- do+--   let cauldron :: Cauldron Identity+--       cauldron = [+--           recipe @U $ val $ wire makeU,+--           recipe @V $ val $ wire makeV,+--           recipe @W $ val $ wire W+--         ]+--   Identity beans <- either throwIO pure $ cook forbidDepCycles cauldron+--   pure $ taste @W beans+-- :}+-- Just (W (Sum {getSum = 8}))++-- $setup+-- >>> :set -XBlockArguments+-- >>> :set -XOverloadedLists+-- >>> :set -Wno-incomplete-uni-patterns+-- >>> import Data.Functor.Identity+-- >>> import Data.Function ((&))+-- >>> import Data.Monoid+-- >>> import Data.Either (either)+-- >>> import Control.Exception (throwIO)

@@ -0,0 +1,434 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoFieldSelectors #-}++module Cauldron.Args+  ( -- * Arguments+    Args,+    arg,+    runArgs,+    getArgsReps,+    contramapArgs,++    -- ** Reducing 'arg' boilerplate with 'wire'+    Wireable (wire),++    -- ** When a bean is missing+    LazilyReadBeanMissing (..),++    -- * Registrations+    -- $registrations+    Regs,+    foretellReg,+    runRegs,+    getRegsReps,++    -- ** Reducing 'foretellReg' boilerplate with 'register'+    Registrable (register),++    -- * Re-exports+    Beans,+    taste,+    fromDynList,+    SomeMonoidTypeRep,+  )+where++import Cauldron.Beans (Beans, SomeMonoidTypeRep (..), fromDynList, taste)+import Cauldron.Beans qualified+import Control.Exception (Exception, throw)+import Data.Dynamic+import Data.Foldable qualified+import Data.Function ((&))+import Data.Functor ((<&>))+import Data.Kind+import Data.Sequence (Seq)+import Data.Sequence qualified+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Typeable+import Type.Reflection (SomeTypeRep (..))+import Type.Reflection qualified++-- | An 'Applicative' that knows how to construct values by searching in a+-- 'Beans' map, and keeps track of the types that will be searched in the+-- 'Beans' map.+data Args a = Args+  { _argReps :: Set SomeTypeRep,+    _regReps :: Set SomeMonoidTypeRep,+    _runArgs :: (forall t. (Typeable t) => Maybe t) -> a+  }+  deriving stock (Functor)++-- | Look for a type in the 'Beans' map and return its corresponding value.+--+-- >>> :{+-- fun1 :: Bool -> Int+-- fun1 _ = 5+-- w1 :: Args Int+-- w1 = fun1 <$> arg+-- fun2 :: String -> Bool -> Int+-- fun2 _ _ = 5+-- w2 :: Args Int+-- w2 = fun2 <$> arg <*> arg+-- :}+arg :: forall a. (Typeable a) => Args a+arg =+  let tr = typeRep (Proxy @a)+   in Args+        { _argReps = Set.singleton tr,+          _regReps = Set.empty,+          _runArgs = \f ->+            case f @a of+              Just v -> v+              Nothing -> throw (LazilyReadBeanMissing tr)+        }++-- | Here the 'Beans' map is not passed /directly/, instead, we pass a+-- function-like value that, given a type, will return a value of that type or+-- 'Nothing'. Such function is usually constructed using 'taste' on some 'Beans'+-- map.+--+-- >>> :{+-- let beans = fromDynList [toDyn @Int 5]+--  in runArgs (taste beans) (arg @Int)+-- :}+-- 5+--+-- See also 'LazilyReadBeanMissing'.+runArgs :: (forall b. (Typeable b) => Maybe b) -> Args a -> a+runArgs f (Args _ _ _runArgs) =+  -- https://www.reddit.com/r/haskell/comments/16diti/comment/c7vc9ky/+  _runArgs f++-- | Inspect ahead of time what types will be searched in the 'Beans' map.+--+-- >>> :{+-- let beans = fromDynList [toDyn @Int 5, toDyn False]+--     args = (,) <$> arg @Int <*> arg @Bool+--  in (getArgsReps args, runArgs (taste beans) args)+-- :}+-- (fromList [Int,Bool],(5,False))+getArgsReps :: Args a -> Set TypeRep+getArgsReps (Args {_argReps}) = _argReps++-- | Tweak the look-by-type function that is eventually passed to 'runArgs'.+--+-- Unlikely to be commonly useful.+--+-- >>> :{+-- let tweak :: forall t. Typeable t => Maybe t -> Maybe t+--     tweak _ = case Type.Reflection.typeRep @t+--                    `Type.Reflection.eqTypeRep`+--                    Type.Reflection.typeRep @Int of+--                  Just HRefl -> Just 5+--                  Nothing -> Nothing+--  in runArgs (taste Cauldron.Beans.empty) $ contramapArgs tweak $ arg @Int+-- :}+-- 5+contramapArgs :: (forall t. (Typeable t) => Maybe t -> Maybe t) -> Args a -> Args a+contramapArgs tweak args@Args {_runArgs} = args {_runArgs = \f -> _runArgs (tweak f)}++-- | Inspect ahead of time the types of registrations that might be contained in+-- the result value of an 'Args'.+--+-- >>> :{+-- let args = foretellReg @(Sum Int) *> pure ()+--  in getRegsReps args+-- :}+-- fromList [Sum Int]+getRegsReps :: Args a -> Set SomeMonoidTypeRep+getRegsReps (Args {_regReps}) = _regReps++-- | This function is used in an 'Args' context to create a tell-like function+-- that can later be used to register a value into a 'Regs'.+--+-- The type of the future registration must be an instance of 'Monoid'.+--+-- There are no other ways of registering values into 'Regs'.+foretellReg :: forall a. (Typeable a, Monoid a) => Args (a -> Regs ())+foretellReg =+  let tr = SomeMonoidTypeRep (Type.Reflection.typeRep @a)+   in Args+        { _argReps = Set.empty,+          _regReps = Set.singleton tr,+          _runArgs = \_ a -> Regs (Data.Sequence.singleton (toDyn a)) ()+        }++instance Applicative Args where+  pure a =+    Args+      { _argReps = Set.empty,+        _regReps = Set.empty,+        _runArgs = \_ -> a+      }+  Args+    { _argReps = _argReps1,+      _regReps = _regReps1,+      _runArgs = f+    }+    <*> Args+      { _argReps = _argReps2,+        _regReps = _regReps2,+        _runArgs = a+      } =+      Args+        { _argReps = _argReps1 `Set.union` _argReps2,+          _regReps = _regReps1 `Set.union` _regReps2,+          _runArgs = \beans -> (f beans) (a beans)+        }++someMonoidTypeRepToSomeTypeRep :: SomeMonoidTypeRep -> SomeTypeRep+someMonoidTypeRepToSomeTypeRep (SomeMonoidTypeRep tr) = SomeTypeRep tr++-- | A writer-like monad for collecting the values of registrations.+data Regs a = Regs (Seq Dynamic) a+  deriving stock (Functor)++-- | Extract the 'Beans' map of registrations, along with the main result value.+--+-- The 'Set' of 'SomeMonoidTypeRep's will typically come from 'getRegsReps'.+--+-- Only values for 'TypeRep's present in the set will be returned. There will be+-- values for all 'TypeRep's present in the set (some of them might be the+-- 'mempty' for that type).+runRegs :: Set SomeMonoidTypeRep -> Regs a -> (Beans, a)+runRegs monoidReps (Regs dyns a) =+  -- https://www.reddit.com/r/haskell/comments/16diti/comment/c7vc9ky/+  let onlyStaticlyKnown =+        ( manyMemptys monoidReps : do+            dyn <- Data.Foldable.toList dyns+            -- This bit is subtle. I mistakenly used Cauldron.Beans.singleton here+            -- and ended up with the Dynamic type as the *key*. It was hell to debug.+            [fromDynList [dyn]]+        )+          & do foldl (Cauldron.Beans.unionBeansMonoidally monoidReps) (mempty @Beans)+          & do flip Cauldron.Beans.restrictKeys (Set.map someMonoidTypeRepToSomeTypeRep monoidReps)+   in (onlyStaticlyKnown, a)++instance Applicative Regs where+  pure a = Regs Data.Sequence.empty a+  Regs w1 f <*> Regs w2 a2 =+    Regs (w1 Data.Sequence.>< w2) (f a2)++instance Monad Regs where+  (Regs w1 a) >>= k =+    let Regs w2 r = k a+     in Regs (w1 Data.Sequence.>< w2) r++manyMemptys :: Set SomeMonoidTypeRep -> Beans+manyMemptys reps =+  reps+    & Data.Foldable.toList+    <&> Cauldron.Beans.someMonoidTypeRepMempty+    & fromDynList++-- | Imprecise exception that might lie hidden in the result of 'runArgs', if+-- the 'Beans' map lacks a value for some type demanded by the 'Args'.+--+-- Why not make 'runArgs' return a 'Maybe' instead of throwing an imprecise+-- exception? The answer is that, for my purposes, using 'Maybe' or 'Either'+-- caused undesirable strictness when doing weird things like reading values+-- \"from the future\".+--+-- >>> :{+-- runArgs (taste Cauldron.Beans.empty) (arg @Int)+-- :}+-- *** Exception: LazilyReadBeanMissing Int+--+-- If more safety is needed, one can perform additional preliminary checks with+-- the help of 'getArgsReps'.+newtype LazilyReadBeanMissing = LazilyReadBeanMissing TypeRep+  deriving stock (Show)+  deriving anyclass (Exception)++-- | Convenience typeclass for wiring all the arguments of a curried function in one go.+class Wireable curried tip | curried -> tip where+  -- | Takes a curried function and reads all of its arguments by type using+  -- 'arg', returning an 'Args' for the final result value of the function.+  --+  -- >>> :{+  -- fun0 :: Int+  -- fun0 = 5+  -- w0 :: Args Int+  -- w0 = wire fun0+  -- fun1 :: Bool -> Int+  -- fun1 _ = 5+  -- w1 :: Args Int+  -- w1 = wire fun1+  -- fun2 :: String -> Bool -> Int+  -- fun2 _ _ = 5+  -- w2 :: Args Int+  -- w2 = wire fun2+  -- :}+  wire :: curried -> Args tip++instance (Wireable_ (IsFunction curried) curried tip) => Wireable curried tip where+  wire curried = wire_ (Proxy @(IsFunction curried)) do pure curried++class Wireable_ (where_ :: Where) curried tip | where_ curried -> tip where+  wire_ :: Proxy where_ -> Args curried -> Args tip++instance Wireable_ AtTheTip a a where+  wire_ _ r = r++instance (Typeable b, Wireable_ (IsFunction rest) rest tip) => Wireable_ NotYetThere (b -> rest) tip where+  wire_ _ af = wire_ (Proxy @(IsFunction rest)) do af <*> arg @b++type IsFunction :: Type -> Where+type family IsFunction f :: Where where+  IsFunction (_ -> _) = 'NotYetThere+  IsFunction _ = 'AtTheTip++data Where+  = NotYetThere+  | AtTheTip++data WhereNested+  = Tup2+  | Tup3+  | Tup4+  | Innermost++type IsReg :: Type -> WhereNested+type family IsReg f :: WhereNested where+  IsReg (_, _) = 'Tup2+  IsReg (_, _, _) = 'Tup3+  IsReg (_, _, _, _) = 'Tup4+  IsReg _ = 'Innermost++-- | Convenience typeclass for automatically extracting registrations from a value.+-- Counterpart of 'Wireable' for registrations.+class Registrable nested tip | nested -> tip where+  -- | We look for (potentially nested) tuples in the value. All tuple+  -- components except the rightmost-innermost must have 'Monoid' instances, and+  -- are put into a 'Regs'.+  --+  -- >>> :{+  -- args :: Args (Identity (Sum Int, All, String))+  -- args = pure (Identity (Sum 5, All False, "foo"))+  -- registeredArgs :: Args (Identity (Regs String))+  -- registeredArgs = register args+  -- :}+  --+  -- >>> :{+  -- let reps = getRegsReps registeredArgs+  --  in ( reps == Data.Set.fromList [ SomeMonoidTypeRep $ Type.Reflection.typeRep @(Sum Int)+  --                                 , SomeMonoidTypeRep $ Type.Reflection.typeRep @All]+  --     , registeredArgs & runArgs (taste Cauldron.Beans.empty)+  --                      & runIdentity+  --                      & runRegs reps+  --                      & \(beans,_) -> (taste @(Sum Int) beans, taste @All beans)+  --     )+  -- :}+  -- (True,(Just (Sum {getSum = 5}),Just (All {getAll = False})))+  --+  -- Tuples can be nested:+  --+  -- >>> :{+  -- args :: Args (Identity (Sum Int, (All, String)))+  -- args = pure (Identity (Sum 5, (All False, "foo")))+  -- registeredArgs :: Args (Identity (Regs String))+  -- registeredArgs = register args+  -- :}+  --+  -- If there are no tuples in the result type, no values are put into 'Regs'.+  --+  -- >>> :{+  -- args :: Args (Identity String)+  -- args = pure (Identity "foo")+  -- registeredArgs :: Args (Identity (Regs String))+  -- registeredArgs = register args+  -- :}+  register :: forall m. (Functor m) => Args (m nested) -> Args (m (Regs tip))++instance (Registrable_ (IsReg nested) nested tip) => Registrable nested tip where+  register amnested = register_ (Proxy @(IsReg nested)) do fmap (fmap pure) amnested++class Registrable_ (where_ :: WhereNested) nested tip | where_ nested -> tip where+  register_ :: forall m. (Functor m) => Proxy where_ -> Args (m (Regs nested)) -> Args (m (Regs tip))++instance Registrable_ Innermost a a where+  register_ _ = id++instance (Typeable b, Monoid b, Registrable_ (IsReg rest) rest tip) => Registrable_ Tup2 (b, rest) tip where+  register_ _ af =+    register_ (Proxy @(IsReg rest)) do+      tell1 <- foretellReg @b+      action <- af+      pure (action <&> \regs -> regs >>= \(b, rest) -> tell1 b *> pure rest)++instance (Typeable b, Monoid b, Typeable c, Monoid c, Registrable_ (IsReg rest) rest tip) => Registrable_ Tup3 (b, c, rest) tip where+  register_ _ af =+    register_ (Proxy @(IsReg rest)) do+      tell1 <- foretellReg @b+      tell2 <- foretellReg @c+      action <- af+      pure (action <&> \regs -> regs >>= \(b, c, rest) -> tell1 b *> tell2 c *> pure rest)++instance (Typeable b, Monoid b, Typeable c, Monoid c, Typeable d, Monoid d, Registrable_ (IsReg rest) rest tip) => Registrable_ Tup3 (b, c, d, rest) tip where+  register_ _ af =+    register_ (Proxy @(IsReg rest)) do+      tell1 <- foretellReg @b+      tell2 <- foretellReg @c+      tell3 <- foretellReg @d+      action <- af+      pure (action <&> \regs -> regs >>= \(b, c, d, rest) -> tell1 b *> tell2 c *> tell3 d *> pure rest)++-- $registrations+--+-- The 'Args' applicative has an additional feature: it lets you \"register\"+-- ahead of time the types of some values that /might/ be included in the result+-- of the 'Args', but without being reflected in the result type. It's not+-- mandatory that these values must be ultimately produced, however.+--+-- Here's an example. We have an 'Args' value that returns a 'Regs'. While+-- constructing the 'Args' value, we register the @Sum Int@ and @All@ types+-- using 'foretellReg', which also gives us the means of later writing into the+-- 'Regs'. By using 'getRegsReps', we can inspect the 'TypeRep's of the types we+-- registered without having to run the 'Args',+--+-- >>> :{+-- fun2 :: String -> Bool -> Int+-- fun2 _ _ = 5+-- args :: Args (Regs Int)+-- args = do -- Using ApplicativeDo+--   r <- fun2 <$> arg <*> arg -- could also have used 'wire'+--   tell1 <- foretellReg @(Sum Int)+--   tell2 <- foretellReg @All+--   pure $ do+--      tell1 (Sum 11)+--      tell2 (All False)+--      pure r+-- :}+--+-- >>> :{+-- let reps = getRegsReps args+--  in ( reps == Data.Set.fromList [ SomeMonoidTypeRep $ Type.Reflection.typeRep @(Sum Int)+--                                 , SomeMonoidTypeRep $ Type.Reflection.typeRep @All]+--     , args & runArgs (taste $ fromDynList [toDyn @String "foo", toDyn False])+--            & runRegs reps+--            & \(beans,_) -> (taste @(Sum Int) beans, taste @All beans)+--     )+-- :}+-- (True,(Just (Sum {getSum = 11}),Just (All {getAll = False})))++-- $setup+-- >>> :set -XBlockArguments+-- >>> :set -XOverloadedLists+-- >>> :set -XApplicativeDo+-- >>> :set -XGADTs+-- >>> :set -Wno-incomplete-uni-patterns+-- >>> import Data.Functor.Identity+-- >>> import Data.Function ((&))+-- >>> import Data.Monoid

@@ -0,0 +1,152 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoFieldSelectors #-}++-- | A map of 'Dynamic' values.+module Cauldron.Beans+  ( Beans,+    empty,+    insert,+    delete,+    restrictKeys,+    keysSet,+    singleton,+    fromDynList,+    toDynMap,++    -- * Looking for values+    taste,++    -- * Monoidal stuff+    unionBeansMonoidally,+    SomeMonoidTypeRep (..),+    someMonoidTypeRepMempty,++    -- * Re-exported+    toDyn,+  )+where++import Data.Dynamic+import Data.Function ((&))+import Data.Functor ((<&>))+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Semigroup qualified+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Typeable+import GHC.IsList+import Type.Reflection (SomeTypeRep (..), eqTypeRep)+import Type.Reflection qualified++empty :: Beans+empty = Beans Map.empty++insert :: forall bean. (Typeable bean) => bean -> Beans -> Beans+insert bean Beans {beanMap} =+  Beans {beanMap = Map.insert (typeRep (Proxy @bean)) (toDyn bean) beanMap}++delete :: TypeRep -> Beans -> Beans+delete tr Beans {beanMap} =+  Beans {beanMap = Map.delete tr beanMap}++-- | Restrict a 'Beans' map to only those 'TypeRep's found in a 'Set'.+restrictKeys :: Beans -> Set TypeRep -> Beans+restrictKeys Beans {beanMap} trs = Beans {beanMap = Map.restrictKeys beanMap trs}++singleton :: forall bean. (Typeable bean) => bean -> Beans+singleton bean = Beans do Map.singleton (typeRep (Proxy @bean)) (toDyn bean)++-- | Check if the 'Beans' map contains a value of type @bean@.+taste :: forall bean. (Typeable bean) => Beans -> Maybe bean+taste Beans {beanMap} =+  let tr = Type.Reflection.typeRep @bean+   in case Map.lookup (SomeTypeRep tr) beanMap of+        Just (Dynamic tr' v) | Just HRefl <- tr `eqTypeRep` tr' -> Just v+        _ -> Nothing++-- | A map of 'Dynamic' values, indexed by the 'TypeRep' of each 'Dynamic'.+-- Maintains the invariant that the 'TypeRep' of the key matches the 'TypeRep'+-- of the 'Dynamic'.+newtype Beans = Beans {beanMap :: Map TypeRep Dynamic}+  deriving newtype (Show)++-- | Union of two 'Beans' maps, right-biased: prefers values from the /right/+-- 'Beans' map when both contain the same 'TypeRep' key. (Note that+-- 'Data.Map.Map' is left-biased.)+instance Semigroup Beans where+  Beans {beanMap = r1} <> Beans {beanMap = r2} = Beans do Map.unionWith (flip const) r1 r2++instance Monoid Beans where+  mempty = Beans mempty++instance IsList Beans where+  type Item Beans = Dynamic+  toList (Beans {beanMap}) = Map.elems beanMap+  fromList = fromDynList++-- |+-- >>> :{+-- let beans = fromDynList [toDyn False, toDyn @Int 5]+--  in (taste @Bool beans, taste @Int beans, taste @String beans)+-- :}+-- (Just False,Just 5,Nothing)+fromDynList :: [Dynamic] -> Beans+fromDynList ds = Beans do Map.fromList do ds <&> \d -> (dynTypeRep d, d)++toDynMap :: Beans -> Map TypeRep Dynamic+toDynMap Beans {beanMap} = beanMap++-- | Like 'SomeTypeRep', but also remembering that the type has a 'Monoid' instance, which can be \"recovered\"+-- after pattern-matching on the 'SomeMonoidTypeRep'.+data SomeMonoidTypeRep where+  SomeMonoidTypeRep ::+    forall a.+    (Monoid a) =>+    Type.Reflection.TypeRep a ->+    SomeMonoidTypeRep++instance Show SomeMonoidTypeRep where+  show (SomeMonoidTypeRep tr) = show tr++instance Eq SomeMonoidTypeRep where+  (SomeMonoidTypeRep tr1) == (SomeMonoidTypeRep tr2) =+    (SomeTypeRep tr1) == (SomeTypeRep tr2)++instance Ord SomeMonoidTypeRep where+  (SomeMonoidTypeRep tr1) `compare` (SomeMonoidTypeRep tr2) =+    (SomeTypeRep tr1) `compare` (SomeTypeRep tr2)++-- | The 'mempty' value corresponding to the inner 'Type.Reflection.TypeRep'.+someMonoidTypeRepMempty :: SomeMonoidTypeRep -> Dynamic+someMonoidTypeRepMempty (SomeMonoidTypeRep tr) = Type.Reflection.withTypeable tr (go tr)+  where+    go :: forall t proxy. (Typeable t, Monoid t) => proxy t -> Dynamic+    go _ = toDyn (mempty @t)++-- | Union of to 'Beans' maps. If both share a 'TypeRep' key and the key is+-- present in the 'SomeMonoidTypeRep' 'Set', combine the values monoidally.+-- Otherwise, keep the value from the /second/ 'Beans' map.+unionBeansMonoidally :: Set SomeMonoidTypeRep -> Beans -> Beans -> Beans+unionBeansMonoidally reps (Beans beans1) (Beans beans2) =+  let d =+        reps+          & Set.map (\v@(SomeMonoidTypeRep tr) -> Data.Semigroup.Arg (SomeTypeRep tr) v)+          & Map.fromArgSet+      combine tr d1 d2 =+        case (Map.lookup tr d, d1, d2) of+          (Just (SomeMonoidTypeRep tr'), Dynamic tr1 v1, Dynamic tr2 v2)+            | Just HRefl <- tr' `eqTypeRep` tr1,+              Just HRefl <- tr' `eqTypeRep` tr2 ->+                Type.Reflection.withTypeable tr' (toDyn (v1 <> v2))+          _ -> d2+   in Beans $ Map.unionWithKey combine beans1 beans2++-- | The set of all 'TypeRep' keys of the map.+keysSet :: Beans -> Set TypeRep+keysSet Beans {beanMap} = Map.keysSet beanMap

@@ -1,3 +1,4 @@+{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingVia #-}@@ -8,7 +9,6 @@ module Main (main) where  import Cauldron-import Data.Function ((&)) import Data.Maybe (fromJust) import Test.Tasty import Test.Tasty.HUnit@@ -65,10 +65,10 @@  data Z = Z deriving (Show) -newtype Inspector = Inspector {inspect :: IO [String]}+newtype Inspector = Inspector {_inspect :: IO [String]}   deriving newtype (Semigroup, Monoid) -newtype Initializer = Initializer {runInitializer :: IO ()}+newtype Initializer = Initializer {_runInitializer :: IO ()}   deriving newtype (Semigroup, Monoid)  makeA :: A@@ -107,37 +107,43 @@ 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 IO -> Either RecipeError (IO Entrypoint) 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+  fmap (fmap (fromJust . taste @Entrypoint)) $ cook fire cauldron +cauldron :: Cauldron IO+cauldron :: Cauldron IO =+  fromRecipeList+    [ recipe $ val $ pure makeA,+      recipe $ val $ pure makeB,+      recipe $ val $ wire makeC,+      recipe $ val $ wire makeD,+      recipe $ val $ wire makeE,+      -- The type app in val checks the specificity, see val definition.+      recipe @F $ val @F $ wire makeF,+      recipe @G+        Recipe+          { bean = val $ wire makeG,+            decos =+              fromDecoList+                [ val $ wire makeGDeco1+                ]+          },+      recipe @H $ val $ wire makeH,+      recipe @Z+        Recipe+          { bean = val $ wire makeZ,+            decos =+              fromDecoList+                [ val $ wire makeZDeco1,+                  val $ wire makeZDeco2+                ]+          },+      recipe @Entrypoint $ val $ wire Entrypoint+    ]++data Entrypoint = Entrypoint Initializer Inspector Z+ tests :: TestTree tests =   testGroup@@ -149,7 +155,7 @@         pure (),       testCase "dep cycles forbidden" do         case coolWiring forbidDepCycles of-          Left (DependencyCycle _) -> pure ()+          Left (DependencyCycleError _) -> pure ()           Left _ -> assertFailure do "wrong kind of error detected"           Right _ -> assertFailure do "self dependency not detected"         pure ()

@@ -0,0 +1,72 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoFieldSelectors #-}++module Main (main) where++import Cauldron+import Cauldron.Args+import Control.Exception+import Data.Dynamic+import Data.Function ((&))+import Data.Proxy+import Data.Text (Text)+import Data.Typeable (typeRep)+import Test.Tasty+import Test.Tasty.HUnit++data A = A++data B = B++data C = C++makeC :: A -> B -> ([Text], C)+makeC _ _ = (["monoid"], C)++argsForC :: Args (Regs C)+argsForC = do+  ~(reg1, bean) <- makeC <$> arg <*> arg+  tell1 <- foretellReg+  pure do+    tell1 reg1+    pure bean++data L1 = L1++data L2 = L2++makeL2 :: L1 -> L2+makeL2 !L1 = L2++throwyArgs :: Args L2+throwyArgs = makeL2 <$> arg++tests :: TestTree+tests =+  testGroup+    "All"+    [ testCase "withRegs" do+        let (beans, C) =+              argsForC+                & runArgs (taste $ fromDynList [toDyn A, toDyn B])+                & runRegs (getRegsReps argsForC)+        Just m <- pure do taste @[Text] beans+        assertEqual+          "monoid"+          ["monoid"]+          m,+      testCase "throwy" do+        r <- try $ evaluate $ runArgs Nothing throwyArgs+        case r of+          Left (LazilyReadBeanMissing tr) | tr == (typeRep (Proxy @L1)) -> pure ()+          _ -> assertFailure "expected exception did not happen"+    ]++main :: IO ()+main = defaultMain tests

@@ -0,0 +1,161 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoFieldSelectors #-}++module Main (main) where++import Cauldron+import Data.Foldable qualified+import Data.Functor.Identity+import Data.Monoid+import Test.Tasty+import Test.Tasty.HUnit++data Foo+  = EndFoo+  | FooToBar Bar+  deriving stock (Show)++data Bar+  = EndBar+  | BarToFoo Foo+  | BarToBaz Baz+  deriving stock (Show)++data Baz+  = EndBaz+  | BazToFoo Foo+  deriving stock (Show)++newtype Serializer a = Serializer {runSerializer :: a -> String}++makeFooSerializer :: Serializer Bar -> Serializer Foo+makeFooSerializer Serializer {runSerializer = runBar} =+  Serializer+    { runSerializer = \case+        EndFoo -> ".EndFoo"+        FooToBar bar -> ".FooToBar" ++ runBar bar+    }++makeBarSerializer :: Serializer Foo -> Serializer Baz -> Serializer Bar+makeBarSerializer Serializer {runSerializer = runFoo} Serializer {runSerializer = runBaz} =+  Serializer+    { runSerializer = \case+        EndBar -> ".EndBar"+        BarToFoo foo -> ".BarToFoo" ++ runFoo foo+        BarToBaz baz -> ".BarToBar" ++ runBaz baz+    }++makeBazSerializer :: Serializer Foo -> Serializer Baz+makeBazSerializer Serializer {runSerializer = runFoo} =+  Serializer+    { runSerializer = \case+        EndBaz -> ".EndBaz"+        BazToFoo foo -> ".BazToFoo" ++ runFoo foo+    }++cauldron :: Cauldron Identity+cauldron =+  fromRecipeList+    [ recipe @(Serializer Foo) $ val $ wire makeFooSerializer,+      recipe @(Serializer Bar) $ val $ wire makeBarSerializer,+      recipe @(Serializer Baz) $ val $ wire makeBazSerializer+    ]++newtype Acc = Acc Int+  deriving stock (Show)+  deriving stock (Eq)+  deriving (Semigroup, Monoid) via Sum Int++newtype Bcc = Bcc Int+  deriving stock (Show)+  deriving stock (Eq)+  deriving (Semigroup, Monoid) via Sum Int++cauldronAccums1 :: Cauldron Identity+cauldronAccums1 =+  fromRecipeList+    [ recipe @(Serializer Foo) $ val $ wire $ \sb -> (Acc 5, makeFooSerializer sb),+      recipe @(Serializer Bar) $ val $ wire $ \sf sb -> (Acc 3, makeBarSerializer sf sb),+      recipe @(Serializer Baz) $ val $ wire $ \sf -> (Acc 7, makeBazSerializer sf)+    ]++cauldronAccums2 :: Cauldron Identity+cauldronAccums2 =+  fromRecipeList+    [ recipe @(Serializer Foo) $ val $ wire $ \(_ :: Acc) sb -> makeFooSerializer sb,+      recipe @(Serializer Bar) $ val $ wire $ \sf sb -> (Acc 3, makeBarSerializer sf sb),+      recipe @(Serializer Baz) $ val $ wire $ \sf -> (Acc 7, makeBazSerializer sf)+    ]++cauldronAccumsOops1 :: Cauldron Identity+cauldronAccumsOops1 =+  fromRecipeList+    [ recipe @(Serializer Foo) $ val $ wire $ \(_ :: Acc) sb -> (Acc 5, makeFooSerializer sb),+      recipe @(Serializer Bar) $ val $ wire $ \sf sb -> (Acc 3, makeBarSerializer sf sb),+      recipe @(Serializer Baz) $ val $ wire $ \sf -> (Acc 7, makeBazSerializer sf)+    ]++cauldronAccumsOops2 :: Cauldron Identity+cauldronAccumsOops2 =+  fromRecipeList+    [ recipe @(Serializer Foo) $ val $ wire $ \(_ :: Acc) sb -> (Bcc 5, makeFooSerializer sb),+      recipe @(Serializer Bar) $ val $ wire $ \(_ :: Bcc) sf sb -> (Acc 5, makeBarSerializer sf sb),+      recipe @(Serializer Baz) $ val $ wire $ \sf -> (Acc 7, makeBazSerializer sf)+    ]++tests :: TestTree+tests =+  testGroup+    "All"+    [ testCase "successful cyclic wiring" do+        case cook allowDepCycles cauldron of+          Left _ -> do+            -- putStrLn $ prettyRecipeError err+            assertFailure "could not wire"+          Right (Identity bs) ->+            case taste bs of+              Nothing -> assertFailure "serializer not found"+              Just (Serializer {runSerializer}) -> do+                let value = FooToBar (BarToFoo (FooToBar (BarToBaz EndBaz)))+                assertEqual "experted result" ".FooToBar.BarToFoo.FooToBar.BarToBar.EndBaz" (runSerializer value),+      testCase "should fail cycle wiring" do+        Data.Foldable.for_ @[] [("forbid", forbidDepCycles), ("selfdeps", allowSelfDeps)] \(name, fire) ->+          case cook fire cauldron of+            Left (DependencyCycleError _) -> pure ()+            Left _ -> assertFailure $ "Unexpected error when wiring" ++ name+            Right _ -> assertFailure $ "Unexpected success when wiring" ++ name,+      testCase "cyclic wiring with accums" do+        Data.Foldable.for_ @[]+          [ ("normal", cauldronAccums1, Acc 15),+            ("someConsume", cauldronAccums2, Acc 10)+          ]+          \(name, c, expected) ->+            case cook allowDepCycles c of+              Left _err -> do+                -- putStrLn $ prettyRecipeError err+                assertFailure $ "could not wire " ++ name+              Right (Identity bs) ->+                case taste bs of+                  Nothing -> assertFailure $ "accum not found " ++ name+                  Just (acc :: Acc) -> do+                    assertEqual "experted result" expected acc,+      testCase "problematic wiring with accums" do+        Data.Foldable.for_ @[]+          [ ("selfacc", cauldronAccumsOops1),+            ("indirectacc", cauldronAccumsOops2)+          ]+          \(name, c) ->+            case cook allowDepCycles c of+              Left (DependencyCycleError _) -> pure ()+              Left _ -> assertFailure $ "Unexpected error when wiring" ++ name+              Right _ -> assertFailure $ "Unexpected success when wiring" ++ name+    ]++main :: IO ()+main = defaultMain tests

@@ -8,7 +8,6 @@  import Cauldron import Cauldron.Managed-import Data.Function ((&)) import Data.IORef import Data.Maybe (fromJust) import Data.Text (Text)@@ -73,17 +72,19 @@  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 (,)+  fromRecipeList+    [ recipe @(Logger IO) $ eff $ wire $ managed (makeLogger ref),+      recipe @(Weird IO)+        Recipe+          { bean = eff do+              wire \logger self -> managed (makeSelfInvokingWeird ref logger self),+            decos =+              fromDecoList+                [ val $ wire makeWeirdDecorator+                ]+          },+      recipe @(Logger IO, Weird IO) $ val_ do wire (,)+    ]  tests :: TestTree tests =@@ -93,7 +94,7 @@         ref <- newIORef []         case cook allowSelfDeps (managedCauldron ref) of           Left _ -> assertFailure "could not wire"-          Right (_, beansAction) -> with beansAction \boiledBeans -> do+          Right beansAction -> with beansAction \boiledBeans -> do             let (Logger {logMessage}, (Weird {anotherWeirdOp}) :: Weird IO) = fromJust . taste $ boiledBeans             logMessage "foo"             anotherWeirdOp

@@ -1,15 +1,20 @@+{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingVia #-}+{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoFieldSelectors #-}  module Main (main) where +import Algebra.Graph.AdjacencyMap import Cauldron+import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Writer import Data.Function ((&))+import Data.Functor.Identity import Data.IORef import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified@@ -17,7 +22,11 @@ import Data.Map qualified as Map import Data.Maybe (fromJust) import Data.Monoid+import Data.Proxy+import Data.Set qualified import Data.Text (Text)+import Data.Tree+import Data.Typeable (typeRep) import Test.Tasty import Test.Tasty.HUnit @@ -106,51 +115,81 @@  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)+  fromRecipeList+    [ recipe @(Logger M) $ eff $ pure makeLogger,+      recipe @(Repository M) $ eff $ wire makeRepository,+      recipe @(Initializer, Repository M) $ val_ $ wire (,)+    ]  cauldronMissingDep :: Cauldron M cauldronMissingDep =   cauldron-    & delete @(Logger M)+    & delete (typeRep (Proxy @(Logger M)))  cauldronDoubleDutyBean :: Cauldron M cauldronDoubleDutyBean =   cauldron-    & insert @Initializer do makeBean do pack value do do (Initializer (pure ()))+    & insert @Initializer (val $ pure (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+    & insert @(Logger M)+      (eff $ wire \(_ :: 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)+    [ fromRecipeList+        [ recipe @(Logger M) $ eff $ pure makeLogger,+          recipe @(Weird M) $ eff $ wire makeWeird+        ],+      fromRecipeList+        [ recipe @(Repository M) $ eff $ do+            action <- wire makeRepository+            pure do+              (initializer, repo) <- action+              pure (initializer, repo),+          recipe @(Weird M)+            Recipe+              { bean = eff $ wire makeSelfInvokingWeird,+                decos =+                  fromDecoList+                    [ val $ wire (weirdDeco "inner"),+                      val $ wire (weirdDeco "outer")+                    ]+              },+          recipe @(Initializer, Repository M, Weird M) $ val_ do wire (,,)+        ]     ]  cauldronLonely :: Cauldron M-cauldronLonely = emptyCauldron & insert @(Lonely M) do makeBean do pack0 value makeLonely+cauldronLonely =+  fromRecipeList+    [ recipe @(Lonely M) $ val $ pure makeLonely+    ] +data A = A++makeA :: (Sum Int, A)+makeA = (Sum 1, A)++data B = B++makeB :: A -> (Sum Int, B)+makeB _ = (Sum 7, B)++data C = C++makeC :: A -> (Sum Int, C)+makeC _ = (Sum 11, C)++treeOfCauldrons :: Tree (Cauldron Identity)+treeOfCauldrons =+  Node+    [recipe $ val $ wire makeA]+    [Node [recipe $ val $ wire makeB] [], Node [recipe $ val $ wire makeC] []]+ tests :: TestTree tests =   testGroup@@ -158,7 +197,7 @@     [ testCase "value" do         (_, traces) <- case cook' cauldron of           Left _ -> assertFailure "could not wire"-          Right (_, beansAction) -> runWriterT do+          Right beansAction -> runWriterT do             boiledBeans <- beansAction             let (Initializer {runInitializer}, Repository {findById, store}) = fromJust . taste $ boiledBeans             runInitializer@@ -175,19 +214,20 @@           ]           traces,       testCase "value sequential" do-        (_, traces) <- case cookNonEmpty' cauldronNonEmpty of+        ((), 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 ()+          Right beansAction -> do+            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",@@ -206,11 +246,31 @@             -- note that the self-invocation used the method from 'makeSelfInvokingWeird'             "weirdOp 2"           ]-          traces,-      testCase "lonely beans get build" do+          traces+        case getDependencyGraph <$> cauldronNonEmpty of+          dg1 Data.List.NonEmpty.:| [dg2] -> do+            let _adj1 = toAdjacencyMap dg1+            let adj2 = toAdjacencyMap dg2+            unless (hasVertex (PrimaryBean (typeRep (Proxy @(Logger M)))) adj2) do+              assertFailure "cauldron 2 doesn't have the fully built logger from cauldron 1 in its dep graph"+            when (hasVertex (BarePrimaryBean (typeRep (Proxy @(Logger M)))) adj2) do+              assertFailure "cauldron 2 has the bare undecorated logger from cauldron 1 in its dep graph, despite not depending on it directly"+            pure ()+          _ -> assertFailure "should never happen, malformed test",+      testCase "tree of cauldrons" do+        case cookTree' treeOfCauldrons of+          Left err -> assertFailure $ "failed to build tree: " ++ show err+          Right (Identity beans) -> case beans of+            Node bbase [Node bbranch1 [], Node bbranch2 []] ->+              assertEqual+                "expected accs across brances"+                (Just (Sum 1), Just (Sum 8), Just (Sum 12))+                (taste @(Sum Int) bbase, taste @(Sum Int) bbranch1, taste @(Sum Int) bbranch2)+            _ -> assertFailure $ "tree has unexpected shape",+      testCase "lonely beans get built" do         (_, _) <- case cook' cauldronLonely of           Left _ -> assertFailure "could not wire"-          Right (_, beansAction) -> runWriterT do+          Right beansAction -> runWriterT do             boiledBeans <- beansAction             let Lonely {soLonely} = fromJust . taste $ boiledBeans             soLonely@@ -218,25 +278,25 @@         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"+          Left (MissingDependenciesError (MissingDependencies _ tr missingSet))+            | tr == typeRep (Proxy @(Repository M)) && missingSet == Data.Set.singleton (typeRep (Proxy @(Logger M))) -> pure ()           _ -> assertFailure "missing dependency not detected"         pure (),       testCase "cauldron with double duty bean" do         case cook' cauldronDoubleDutyBean of-          Left (DoubleDutyBeans _) -> pure ()+          Left (DoubleDutyBeansError _) -> pure ()           _ -> assertFailure "double duty beans not detected"         pure (),       testCase "cauldron with cycle" do         case cook' cauldronWithCycle of-          Left (DependencyCycle _) -> pure ()+          Left (DependencyCycleError _) -> pure ()           _ -> assertFailure "dependency cycle not detected"         pure ()     ]   where     cook' = cook allowSelfDeps     cookNonEmpty' = cookNonEmpty . fmap (allowSelfDeps,)+    cookTree' = cookTree . fmap (allowSelfDeps,)  main :: IO () main = defaultMain tests