diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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). diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/cauldron.cabal b/cauldron.cabal --- a/cauldron.cabal +++ b/cauldron.cabal @@ -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 diff --git a/lib/Cauldron.hs b/lib/Cauldron.hs --- a/lib/Cauldron.hs +++ b/lib/Cauldron.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) diff --git a/lib/Cauldron/Args.hs b/lib/Cauldron/Args.hs new file mode 100644 --- /dev/null +++ b/lib/Cauldron/Args.hs @@ -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 diff --git a/lib/Cauldron/Beans.hs b/lib/Cauldron/Beans.hs new file mode 100644 --- /dev/null +++ b/lib/Cauldron/Beans.hs @@ -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 diff --git a/test/appTests.hs b/test/appTests.hs --- a/test/appTests.hs +++ b/test/appTests.hs @@ -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 () diff --git a/test/argsTests.hs b/test/argsTests.hs new file mode 100644 --- /dev/null +++ b/test/argsTests.hs @@ -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 diff --git a/test/codecTests.hs b/test/codecTests.hs new file mode 100644 --- /dev/null +++ b/test/codecTests.hs @@ -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 diff --git a/test/managedTests.hs b/test/managedTests.hs --- a/test/managedTests.hs +++ b/test/managedTests.hs @@ -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 diff --git a/test/tests.hs b/test/tests.hs --- a/test/tests.hs +++ b/test/tests.hs @@ -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