cauldron 0.6.1.0 → 0.7.0.0

raw patch · 17 files changed

+2394/−811 lines, 17 filesdep −algebraic-graphsdep −bytestringdep −textdep ~containersPVP ok

version bump matches the API change (PVP)

Dependencies removed: algebraic-graphs, bytestring, text

Dependency ranges changed: containers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +15/−0
• README.md +15/−8
• app/Main.hs +34/−31
• cauldron.cabal +16/−6
• lib-graph/Cauldron/Graph.hs +921/−0
• lib-graph/Cauldron/Graph/Algorithm.hs +52/−0
• lib-graph/Cauldron/Graph/Export.hs +187/−0
• lib-graph/Cauldron/Graph/Export/Dot.hs +145/−0
• lib/Cauldron.hs +496/−266
• lib/Cauldron/Args.hs +1/−388
• lib/Cauldron/Args/Internal.hs +407/−0
• lib/Cauldron/Builder.hs +1/−1
• test/appTests.hs +4/−5
• test/argsTests.hs +2/−1
• test/codecTests.hs +10/−16
• test/managedTests.hs +3/−2
• test/tests.hs +85/−87

@@ -1,5 +1,20 @@ # Revision history for cauldron +## 0.7.0.0++* Remove dependency on algebraic-graphs, copying those parts of the code that we used.+* Remove `cookTree` and `cookNonEmpty`. +* Added `nest`.+* `cook` is now "typed": we pass the type of the bean we want to extract.+* `RecipeError` -> `CookingError`.+* Renamed `PrimaryBean` to `FinishedBean`.+* Renamed `SecondaryBean` to `AggregateBean`.+* Now the `Constructor`s don't depend directly on `SecondaryBean`/`AggregateBean`.+  There is a `PrimaryBean`/`FinishedBean` that points to the `SecondaryBean`/`AggregateBean`,+  and `Constructor`s depend on that.+* Rename `collapseToPrimaryBeans` to `collapseBeans`.+* Rename `removeSecondaryBeans` to `removeAggregates`.+ ## 0.6.1.0  * `ioEff` added to `Cauldron`.

@@ -67,10 +67,10 @@ wiring is *type-directed*, so there can't be any ambiguity about which bean constructor to use. -## Monoidally aggregated secondary beans+## Aggregate beans  More complex constructors can return—besides a "primary" bean as seen in the-previous section—one or more "secondary" beans. For example:+previous section—one or more secondary "aggregate" beans. For example:  ``` makeServer :: Logger -> Repository -> (Initializer, Inspector, Server)@@ -83,11 +83,12 @@ ```  These secondary outputs of a constructor, like `Initializer` and `Inspector`,-must have `Monoid` instances. Unlike with the "primary" bean the constructor produces, they+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+Constructors can depend on the final aggregated value of an aggregate 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):@@ -106,8 +107,8 @@ makeServerDecorator :: Server -> Server ``` -Like normal constructors, decorators can have their own dependencies (other than the-decorated bean), perform effects, and register secondary beans:+Like normal constructors, decorators can have their own dependencies (besides the+decorated bean itself), perform effects, and register aggregate beans:  ``` makeServerDecorator :: Logger -> Server -> IO (Initializer,Server)@@ -148,9 +149,9 @@   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. +- [context hierachies](https://docs.spring.io/spring-framework/reference/testing/testcontext-framework/ctx-management/hierarchies.html) correspond to taking an "incomplete" set of constructors where not all constructor dependencies can be satisfied inside the set, and turning it into a single constructor which takes the missing dependencies as arguments, and can be made part of a wider set of constructors. The missing dependencies will then be read from that wider set. -- [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. +- [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 aggregate bean as an argument.   Some features I'm not yet sure how to mimic: @@ -161,3 +162,9 @@ # 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).++- [Do we need effects to get abstraction? (2019)](https://hachyderm.io/@DiazCarrete/114712223474781312)++# Acknowledgement++This package contains vendored code from Andrey Mokhov's [algebraic-graphs](https://hackage.haskell.org/package/algebraic-graphs) (most of the `cauldron:graph` library).

@@ -10,7 +10,6 @@ module Main where  import Cauldron-import Data.Maybe (fromJust)  {-   HERE ARE A BUNCH OF DATATYPES.@@ -74,7 +73,7 @@ data Z = Z deriving (Show)  {--  These beans are a bit special: they are "secondary" beans which are optionally+  These beans are a bit special: they are secondary "aggregate" beans which are optionally   produced by the constructors of other beans.    They have Monoid instances. The values returned by all the constructors that@@ -96,10 +95,10 @@ makeA :: A makeA = A --- A bean with a monoidal registration.------ The registration could be some generic introspection mechanism, or perhaps--- some effectful action that sets up a worker thread.+-- A primary bean 'B' with an aggregate bean 'Inspector'.+-- +-- aggregate beans can be used to implement some generic introspection mechanism+-- for an app, or perhaps some effectful action that sets up worker threads. makeB :: (Inspector, B) makeB = (Inspector (pure ["B stuff"]), B) @@ -117,46 +116,50 @@  -- | A bean with a self-dependency! ----- We need this if we want self-invocations to be decorated.+-- We need these self-dependencies in order for self-invocations to be decorated. ----- Dependency cycles of more than one bean are forbidden, however.+-- The 'Fire' we use to 'cook' the 'Cauldron' might allow or disallow self-dependencies. makeG :: E -> F -> G -> G makeG _ _ _ = G  -- | A decorator. -----  Decorators are basically normal constructors, only that they return---  a Endo that knows how to tweak the value of a bean.+-- Decorators are basically normal constructors, only that they take+-- the bean they return as a parameter.  --+-- This is not the same as a bean self-dependency! These receive the completed+-- bean from the future, while decorators work with the in-construction version+-- of the bean.+-- -- Because they are normal constructors, they can be effectful, and they -- might have dependencies of their own. makeGDeco1 :: A -> G -> G makeGDeco1 _ g = g --- | A bean with two monoidal registrations.+-- | A primary bean 'H' with two aggregate beans 'Initializer' and 'Inspector'. makeH :: A -> D -> G -> (Initializer, Inspector, H) makeH _ _ _ = (Initializer (putStrLn "H init"), Inspector (pure ["H stuff"]), H) --- | Notice that this bean has "Inspector" as a dependency. Inspector is a--- monoidal bean which is aggregated across all the constructor that register--- it. This is OK as long as there are no dependency cycles.+-- | Notice that this bean has "Inspector" as a dependency. Inspector is an+-- aggregate bean; its value is aggregated across all the constructor that+-- produce it. ----- Why would a bean depend on such a aggregated bean? Well, for example, a--- server bean might want to publish diagnostic information collected from beans--- that register it.+-- Why would a bean depend on an aggregate bean? Well, for example, a server+-- bean might want to publish diagnostic information (exposed using an uniform+-- interface) that is collected from the constructors that register it. makeZ :: Inspector -> D -> H -> Z makeZ _ _ _ = Z  makeZDeco1 :: B -> E -> Z -> Z makeZDeco1 _ _ z = z --- | A decorator with a monoidal registration.+-- | A decorator for 'Z' which produces an aggregate bean 'Initializer'. makeZDeco2 :: (F -> Z -> (Initializer, Z)) makeZDeco2 = \_ z -> (Initializer (putStrLn "Z deco init"), z) -data Entrypoint = Entrypoint Initializer Inspector Z+data Result = Result Initializer Inspector Z -boringWiring :: IO Entrypoint+boringWiring :: IO Result boringWiring = do   let -- We have to remember to collect the monoidal registrations.       initializer = init1 <> init2@@ -179,15 +182,15 @@       z1 = makeZDeco1 b e z0       (init2, z2) = makeZDeco2 f z1       z = z2-  pure $ Entrypoint initializer inspector z+  pure $ Result 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 :: Either RecipeError (IO Entrypoint)-coolWiring = fmap (fmap (fromJust . taste @Entrypoint)) $ cook allowSelfDeps cauldron+coolWiring :: Either CookingError (IO Result)+coolWiring = cook allowSelfDeps cauldron  cauldron :: Cauldron IO cauldron :: Cauldron IO =@@ -213,14 +216,14 @@               val $ wire makeZDeco2             ]         },-    recipe @Entrypoint $ val $ wire Entrypoint+    recipe @Result $ val $ wire Result   ]  main :: IO () main = do   -- "manual" wiring   do-    Entrypoint (Initializer {runInitializer}) (Inspector {inspect}) z <- boringWiring+    Result (Initializer {runInitializer}) (Inspector {inspect}) z <- boringWiring     inspection <- inspect     print inspection     print z@@ -228,10 +231,10 @@   -- wiring with Cauldron   merr <- case coolWiring of     Left badBeans -> do-      putStrLn $ prettyRecipeError badBeans+      putStrLn $ prettyCookingError badBeans       pure $ Just badBeans     Right action -> do-      Entrypoint (Initializer {runInitializer}) (Inspector {inspect}) z <- action+      Result (Initializer {runInitializer}) (Inspector {inspect}) z <- action       inspection <- inspect       print inspection       print z@@ -239,7 +242,7 @@       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+  writeAsDot (defaultStyle merr) "beans-no-agg.dot" $ removeAggregates $ depGraph+  writeAsDot (defaultStyle merr) "beans-no-agg-no-decos.dot" $ removeDecos $ removeAggregates $ depGraph+  writeAsDot (defaultStyle merr) "beans-simple.dot" $ collapseBeans $ removeDecos $ removeAggregates $ depGraph+  writeAsDot (defaultStyle merr) "beans-simple-with-decos.dot" $ collapseBeans $ removeAggregates $ depGraph

@@ -1,6 +1,6 @@ cabal-version:      3.4 name:               cauldron-version:            0.6.1.0+version:            0.7.0.0 synopsis:           Dependency injection library description:        Dependency injection library that wires things at runtime. license:            BSD-3-Clause@@ -26,8 +26,7 @@ common common-lib     import: common-base     build-depends:-      containers >= 0.5.0 && < 0.8,-      text >= 2.0 && < 2.2,+      containers >= 0.7 && < 0.9,  common common-tests     import: common-lib@@ -35,14 +34,13 @@       tasty           ^>= 1.5,       tasty-hunit     ^>= 0.10,       transformers >= 0.5 && < 0.7,-      algebraic-graphs ^>= 0.7,       cauldron,+      cauldron:graph,  library     import:           common-lib     build-depends:-        algebraic-graphs ^>= 0.7,-        bytestring >= 0.10.0 && < 0.13,+        cauldron:graph,     hs-source-dirs:   lib     exposed-modules:           Cauldron@@ -50,6 +48,18 @@         Cauldron.Args         Cauldron.Managed         Cauldron.Builder+    other-modules:+        Cauldron.Args.Internal++library graph+    import:           common-lib+    hs-source-dirs:   lib-graph+    exposed-modules:  +        Cauldron.Graph+        Cauldron.Graph.Algorithm+        Cauldron.Graph.Export+        Cauldron.Graph.Export.Dot+    visibility: public  executable cauldron-example-wiring     import:           common-base

@@ -0,0 +1,921 @@+-----------------------------------------------------------------------------+-- |+-- Module     : Algebra.Graph.AdjacencyMap+-- Copyright  : (c) Andrey Mokhov 2016-2024+-- License    : MIT (see the file LICENSE)+-- Maintainer : andrey.mokhov@gmail.com+-- Stability  : experimental+--+-- __Alga__ is a library for algebraic construction and manipulation of graphs+-- in Haskell. See <https://github.com/snowleopard/alga-paper this paper> for the+-- motivation behind the library, the underlying theory, and implementation details.+--+-- This module defines the 'AdjacencyMap' data type and associated functions.+-- See "Algebra.Graph.AdjacencyMap.Algorithm" for basic graph algorithms.+-- 'AdjacencyMap' is an instance of the 'C.Graph' type class, which can be used+-- for polymorphic graph construction and manipulation.+-- "Algebra.Graph.AdjacencyIntMap" defines adjacency maps specialised to graphs+-- with @Int@ vertices.+-----------------------------------------------------------------------------+module Cauldron.Graph (+    -- * Data structure+    AdjacencyMap, adjacencyMap,++    -- * Basic graph construction primitives+    empty, vertex, edge, overlay, connect, vertices, edges, overlays, connects,++    -- * Relations on graphs+    isSubgraphOf,++    -- * Graph properties+    isEmpty, hasVertex, hasEdge, vertexCount, edgeCount, vertexList, edgeList,+    adjacencyList, vertexSet, edgeSet, preSet, postSet,++    -- * Standard families of graphs+    path, circuit, clique, biclique, star, stars, fromAdjacencySets, tree,+    forest,++    -- * Graph transformation+    removeVertex, removeEdge, replaceVertex, mergeVertices, transpose, gmap,+    induce, induceJust,++    -- * Graph composition+    compose, box,++    -- * Relational operations+    closure, reflexiveClosure, symmetricClosure, transitiveClosure,++    -- * Miscellaneous+    consistent+    ) where++import Data.List ((\\))+import Data.Map.Strict (Map)+import Data.Monoid+import Data.Set (Set)+import Data.String+import Data.Tree hiding (edges)+import GHC.Generics++import qualified Data.Map.Strict as Map+import qualified Data.Maybe      as Maybe+import qualified Data.Set        as Set++{-| The 'AdjacencyMap' data type represents a graph by a map of vertices to+their adjacency sets. We define a 'Num' instance as a convenient notation for+working with graphs:++@+0           == 'vertex' 0+1 + 2       == 'overlay' ('vertex' 1) ('vertex' 2)+1 * 2       == 'connect' ('vertex' 1) ('vertex' 2)+1 + 2 * 3   == 'overlay' ('vertex' 1) ('connect' ('vertex' 2) ('vertex' 3))+1 * (2 + 3) == 'connect' ('vertex' 1) ('overlay' ('vertex' 2) ('vertex' 3))+@++__Note:__ the 'Num' instance does not satisfy several "customary laws" of 'Num',+which dictate that 'fromInteger' @0@ and 'fromInteger' @1@ should act as+additive and multiplicative identities, and 'negate' as additive inverse.+Nevertheless, overloading 'fromInteger', '+' and '*' is very convenient when+working with algebraic graphs; we hope that in future Haskell's Prelude will+provide a more fine-grained class hierarchy for algebraic structures, which we+would be able to utilise without violating any laws.++The 'Show' instance is defined using basic graph construction primitives:++@show (empty     :: AdjacencyMap Int) == "empty"+show (1         :: AdjacencyMap Int) == "vertex 1"+show (1 + 2     :: AdjacencyMap Int) == "vertices [1,2]"+show (1 * 2     :: AdjacencyMap Int) == "edge 1 2"+show (1 * 2 * 3 :: AdjacencyMap Int) == "edges [(1,2),(1,3),(2,3)]"+show (1 * 2 + 3 :: AdjacencyMap Int) == "overlay (vertex 3) (edge 1 2)"@++The 'Eq' instance satisfies all axioms of algebraic graphs:++    * 'overlay' is commutative and associative:++        >       x + y == y + x+        > x + (y + z) == (x + y) + z++    * 'connect' is associative and has 'empty' as the identity:++        >   x * empty == x+        >   empty * x == x+        > x * (y * z) == (x * y) * z++    * 'connect' distributes over 'overlay':++        > x * (y + z) == x * y + x * z+        > (x + y) * z == x * z + y * z++    * 'connect' can be decomposed:++        > x * y * z == x * y + x * z + y * z++The following useful theorems can be proved from the above set of axioms.++    * 'overlay' has 'empty' as the identity and is idempotent:++        >   x + empty == x+        >   empty + x == x+        >       x + x == x++    * Absorption and saturation of 'connect':++        > x * y + x + y == x * y+        >     x * x * x == x * x++When specifying the time and memory complexity of graph algorithms, /n/ and /m/+will denote the number of vertices and edges in the graph, respectively.++The total order on graphs is defined using /size-lexicographic/ comparison:++* Compare the number of vertices. In case of a tie, continue.+* Compare the sets of vertices. In case of a tie, continue.+* Compare the number of edges. In case of a tie, continue.+* Compare the sets of edges.++Here are a few examples:++@'vertex' 1 < 'vertex' 2+'vertex' 3 < 'edge' 1 2+'vertex' 1 < 'edge' 1 1+'edge' 1 1 < 'edge' 1 2+'edge' 1 2 < 'edge' 1 1 + 'edge' 2 2+'edge' 1 2 < 'edge' 1 3@++Note that the resulting order refines the 'isSubgraphOf' relation and is+compatible with 'overlay' and 'connect' operations:++@'isSubgraphOf' x y ==> x <= y@++@'empty' <= x+x     <= x + y+x + y <= x * y@+-}+newtype AdjacencyMap a = AM {+    -- | The /adjacency map/ of a graph: each vertex is associated with a set of+    -- its direct successors. Complexity: /O(1)/ time and memory.+    --+    -- @+    -- adjacencyMap 'empty'      == Map.'Map.empty'+    -- adjacencyMap ('vertex' x) == Map.'Map.singleton' x Set.'Set.empty'+    -- adjacencyMap ('edge' 1 1) == Map.'Map.singleton' 1 (Set.'Set.singleton' 1)+    -- adjacencyMap ('edge' 1 2) == Map.'Map.fromList' [(1,Set.'Set.singleton' 2), (2,Set.'Set.empty')]+    -- @+    adjacencyMap :: Map a (Set a) } deriving (Eq, Generic)++instance Ord a => Ord (AdjacencyMap a) where+    compare x y = mconcat+        [ compare (vertexCount x) (vertexCount  y)+        , compare (vertexSet   x) (vertexSet    y)+        , compare (edgeCount   x) (edgeCount    y)+        , compare (edgeSet     x) (edgeSet      y) ]++instance (Ord a, Show a) => Show (AdjacencyMap a) where+    showsPrec p am@(AM m)+        | null vs    = showString "empty"+        | null es    = showParen (p > 10) $ vshow vs+        | vs == used = showParen (p > 10) $ eshow es+        | otherwise  = showParen (p > 10) $ showString "overlay ("+                     . vshow (vs \\ used) . showString ") ("+                     . eshow es . showString ")"+      where+        vs             = vertexList am+        es             = edgeList am+        vshow [x]      = showString "vertex "   . showsPrec 11 x+        vshow xs       = showString "vertices " . showsPrec 11 xs+        eshow [(x, y)] = showString "edge "     . showsPrec 11 x .+                         showString " "         . showsPrec 11 y+        eshow xs       = showString "edges "    . showsPrec 11 xs+        used           = Set.toAscList (referredToVertexSet m)++-- | __Note:__ this does not satisfy the usual ring laws; see 'AdjacencyMap'+-- for more details.+instance (Ord a, Num a) => Num (AdjacencyMap a) where+    fromInteger = vertex . fromInteger+    (+)         = overlay+    (*)         = connect+    signum      = const empty+    abs         = id+    negate      = id++instance IsString a => IsString (AdjacencyMap a) where+    fromString = vertex . fromString++-- | Defined via 'overlay'.+instance Ord a => Semigroup (AdjacencyMap a) where+    (<>) = overlay++-- | Defined via 'overlay' and 'empty'.+instance Ord a => Monoid (AdjacencyMap a) where+    mempty = empty++-- | Construct the /empty graph/.+--+-- @+-- 'isEmpty'     empty == True+-- 'hasVertex' x empty == False+-- 'vertexCount' empty == 0+-- 'edgeCount'   empty == 0+-- @+empty :: AdjacencyMap a+empty = AM Map.empty+{-# NOINLINE [1] empty #-}++-- | Construct the graph comprising /a single isolated vertex/.+--+-- @+-- 'isEmpty'     (vertex x) == False+-- 'hasVertex' x (vertex y) == (x == y)+-- 'vertexCount' (vertex x) == 1+-- 'edgeCount'   (vertex x) == 0+-- @+vertex :: a -> AdjacencyMap a+vertex x = AM $ Map.singleton x Set.empty+{-# NOINLINE [1] vertex #-}++-- | Construct the graph comprising /a single edge/.+--+-- @+-- edge x y               == 'connect' ('vertex' x) ('vertex' y)+-- 'hasEdge' x y (edge x y) == True+-- 'edgeCount'   (edge x y) == 1+-- 'vertexCount' (edge 1 1) == 1+-- 'vertexCount' (edge 1 2) == 2+-- @+edge :: Ord a => a -> a -> AdjacencyMap a+edge x y | x == y    = AM $ Map.singleton x (Set.singleton y)+         | otherwise = AM $ Map.fromList [(x, Set.singleton y), (y, Set.empty)]++-- | /Overlay/ two graphs. This is a commutative, associative and idempotent+-- operation with the identity 'empty'.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- 'isEmpty'     (overlay x y) == 'isEmpty'   x   && 'isEmpty'   y+-- 'hasVertex' z (overlay x y) == 'hasVertex' z x || 'hasVertex' z y+-- 'vertexCount' (overlay x y) >= 'vertexCount' x+-- 'vertexCount' (overlay x y) <= 'vertexCount' x + 'vertexCount' y+-- 'edgeCount'   (overlay x y) >= 'edgeCount' x+-- 'edgeCount'   (overlay x y) <= 'edgeCount' x   + 'edgeCount' y+-- 'vertexCount' (overlay 1 2) == 2+-- 'edgeCount'   (overlay 1 2) == 0+-- @+overlay :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a+overlay (AM x) (AM y) = AM $ Map.unionWith Set.union x y+{-# NOINLINE [1] overlay #-}++-- | /Connect/ two graphs. This is an associative operation with the identity+-- 'empty', which distributes over 'overlay' and obeys the decomposition axiom.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. Note that the+-- number of edges in the resulting graph is quadratic with respect to the number+-- of vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/.+--+-- @+-- 'isEmpty'     (connect x y) == 'isEmpty'   x   && 'isEmpty'   y+-- 'hasVertex' z (connect x y) == 'hasVertex' z x || 'hasVertex' z y+-- 'vertexCount' (connect x y) >= 'vertexCount' x+-- 'vertexCount' (connect x y) <= 'vertexCount' x + 'vertexCount' y+-- 'edgeCount'   (connect x y) >= 'edgeCount' x+-- 'edgeCount'   (connect x y) >= 'edgeCount' y+-- 'edgeCount'   (connect x y) >= 'vertexCount' x * 'vertexCount' y+-- 'edgeCount'   (connect x y) <= 'vertexCount' x * 'vertexCount' y + 'edgeCount' x + 'edgeCount' y+-- 'vertexCount' (connect 1 2) == 2+-- 'edgeCount'   (connect 1 2) == 1+-- @+connect :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a+connect (AM x) (AM y) = AM $ Map.unionsWith Set.union+    [ x, y, Map.fromSet (const $ Map.keysSet y) (Map.keysSet x) ]+{-# NOINLINE [1] connect #-}++-- | Construct the graph comprising a given list of isolated vertices.+-- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the length+-- of the given list.+--+-- @+-- vertices []            == 'empty'+-- vertices [x]           == 'vertex' x+-- vertices               == 'overlays' . map 'vertex'+-- 'hasVertex' x . vertices == 'elem' x+-- 'vertexCount' . vertices == 'length' . 'Data.List.nub'+-- 'vertexSet'   . vertices == Set.'Set.fromList'+-- @+vertices :: Ord a => [a] -> AdjacencyMap a+vertices = AM . Map.fromList . map (, Set.empty)+{-# NOINLINE [1] vertices #-}++-- | Construct the graph from a list of edges.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- edges []          == 'empty'+-- edges [(x,y)]     == 'edge' x y+-- edges             == 'overlays' . 'map' ('uncurry' 'edge')+-- 'edgeCount' . edges == 'length' . 'Data.List.nub'+-- 'edgeList' . edges  == 'Data.List.nub' . 'Data.List.sort'+-- @+edges :: Ord a => [(a, a)] -> AdjacencyMap a+edges = fromAdjacencySets . map (fmap Set.singleton)++-- | Overlay a given list of graphs.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- overlays []        == 'empty'+-- overlays [x]       == x+-- overlays [x,y]     == 'overlay' x y+-- overlays           == 'foldr' 'overlay' 'empty'+-- 'isEmpty' . overlays == 'all' 'isEmpty'+-- @+overlays :: Ord a => [AdjacencyMap a] -> AdjacencyMap a+overlays = AM . Map.unionsWith Set.union . map adjacencyMap+{-# NOINLINE overlays #-}++-- | Connect a given list of graphs.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- connects []        == 'empty'+-- connects [x]       == x+-- connects [x,y]     == 'connect' x y+-- connects           == 'foldr' 'connect' 'empty'+-- 'isEmpty' . connects == 'all' 'isEmpty'+-- @+connects :: Ord a => [AdjacencyMap a] -> AdjacencyMap a+connects = foldr connect empty+{-# NOINLINE connects #-}++-- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the+-- first graph is a /subgraph/ of the second.+-- Complexity: /O((n + m) * log(n))/ time.+--+-- @+-- isSubgraphOf 'empty'         x             ==  True+-- isSubgraphOf ('vertex' x)    'empty'         ==  False+-- isSubgraphOf x             ('overlay' x y) ==  True+-- isSubgraphOf ('overlay' x y) ('connect' x y) ==  True+-- isSubgraphOf ('path' xs)     ('circuit' xs)  ==  True+-- isSubgraphOf x y                         ==> x <= y+-- @+isSubgraphOf :: Ord a => AdjacencyMap a -> AdjacencyMap a -> Bool+isSubgraphOf (AM x) (AM y) = Map.isSubmapOfBy Set.isSubsetOf x y++-- | Check if a graph is empty.+-- Complexity: /O(1)/ time.+--+-- @+-- isEmpty 'empty'                       == True+-- isEmpty ('overlay' 'empty' 'empty')       == True+-- isEmpty ('vertex' x)                  == False+-- isEmpty ('removeVertex' x $ 'vertex' x) == True+-- isEmpty ('removeEdge' x y $ 'edge' x y) == False+-- @+isEmpty :: AdjacencyMap a -> Bool+isEmpty = Map.null . adjacencyMap++-- | Check if a graph contains a given vertex.+-- Complexity: /O(log(n))/ time.+--+-- @+-- hasVertex x 'empty'            == False+-- hasVertex x ('vertex' y)       == (x == y)+-- hasVertex x . 'removeVertex' x == 'const' False+-- @+hasVertex :: Ord a => a -> AdjacencyMap a -> Bool+hasVertex x = Map.member x . adjacencyMap++-- | Check if a graph contains a given edge.+-- Complexity: /O(log(n))/ time.+--+-- @+-- hasEdge x y 'empty'            == False+-- hasEdge x y ('vertex' z)       == False+-- hasEdge x y ('edge' x y)       == True+-- hasEdge x y . 'removeEdge' x y == 'const' False+-- hasEdge x y                  == 'elem' (x,y) . 'edgeList'+-- @+hasEdge :: Ord a => a -> a -> AdjacencyMap a -> Bool+hasEdge u v (AM m) = case Map.lookup u m of+    Nothing -> False+    Just vs -> Set.member v vs++-- | The number of vertices in a graph.+-- Complexity: /O(1)/ time.+--+-- @+-- vertexCount 'empty'             ==  0+-- vertexCount ('vertex' x)        ==  1+-- vertexCount                   ==  'length' . 'vertexList'+-- vertexCount x \< vertexCount y ==> x \< y+-- @+vertexCount :: AdjacencyMap a -> Int+vertexCount = Map.size . adjacencyMap++-- | The number of edges in a graph.+-- Complexity: /O(n)/ time.+--+-- @+-- edgeCount 'empty'      == 0+-- edgeCount ('vertex' x) == 0+-- edgeCount ('edge' x y) == 1+-- edgeCount            == 'length' . 'edgeList'+-- @+edgeCount :: AdjacencyMap a -> Int+edgeCount = getSum . foldMap (Sum . Set.size) . adjacencyMap++-- | The sorted list of vertices of a given graph.+-- Complexity: /O(n)/ time and memory.+--+-- @+-- vertexList 'empty'      == []+-- vertexList ('vertex' x) == [x]+-- vertexList . 'vertices' == 'Data.List.nub' . 'Data.List.sort'+-- @+vertexList :: AdjacencyMap a -> [a]+vertexList = Map.keys . adjacencyMap++-- | The sorted list of edges of a graph.+-- Complexity: /O(n + m)/ time and /O(m)/ memory.+--+-- @+-- edgeList 'empty'          == []+-- edgeList ('vertex' x)     == []+-- edgeList ('edge' x y)     == [(x,y)]+-- edgeList ('star' 2 [3,1]) == [(2,1), (2,3)]+-- edgeList . 'edges'        == 'Data.List.nub' . 'Data.List.sort'+-- edgeList . 'transpose'    == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . edgeList+-- @+edgeList :: AdjacencyMap a -> [(a, a)]+edgeList (AM m) = [ (x, y) | (x, ys) <- Map.toAscList m, y <- Set.toAscList ys ]+{-# INLINE edgeList #-}++-- | The set of vertices of a given graph.+-- Complexity: /O(n)/ time and memory.+--+-- @+-- vertexSet 'empty'      == Set.'Set.empty'+-- vertexSet . 'vertex'   == Set.'Set.singleton'+-- vertexSet . 'vertices' == Set.'Set.fromList'+-- @+vertexSet :: AdjacencyMap a -> Set a+vertexSet = Map.keysSet . adjacencyMap++-- | The set of edges of a given graph.+-- Complexity: /O((n + m) * log(m))/ time and /O(m)/ memory.+--+-- @+-- edgeSet 'empty'      == Set.'Set.empty'+-- edgeSet ('vertex' x) == Set.'Set.empty'+-- edgeSet ('edge' x y) == Set.'Set.singleton' (x,y)+-- edgeSet . 'edges'    == Set.'Set.fromList'+-- @+edgeSet :: Eq a => AdjacencyMap a -> Set (a, a)+edgeSet = Set.fromAscList . edgeList++-- | The sorted /adjacency list/ of a graph.+-- Complexity: /O(n + m)/ time and memory.+--+-- @+-- adjacencyList 'empty'          == []+-- adjacencyList ('vertex' x)     == [(x, [])]+-- adjacencyList ('edge' 1 2)     == [(1, [2]), (2, [])]+-- adjacencyList ('star' 2 [3,1]) == [(1, []), (2, [1,3]), (3, [])]+-- 'stars' . adjacencyList        == id+-- @+adjacencyList :: AdjacencyMap a -> [(a, [a])]+adjacencyList = map (fmap Set.toAscList) . Map.toAscList . adjacencyMap++-- | The /preset/ of an element @x@ is the set of its /direct predecessors/.+-- Complexity: /O(n * log(n))/ time and /O(n)/ memory.+--+-- @+-- preSet x 'empty'      == Set.'Set.empty'+-- preSet x ('vertex' x) == Set.'Set.empty'+-- preSet 1 ('edge' 1 2) == Set.'Set.empty'+-- preSet y ('edge' x y) == Set.'Set.fromList' [x]+-- @+preSet :: Ord a => a -> AdjacencyMap a -> Set a+preSet x = Set.fromAscList . map fst . filter p  . Map.toAscList . adjacencyMap+  where+    p (_, set) = x `Set.member` set++-- | The /postset/ of a vertex is the set of its /direct successors/.+-- Complexity: /O(log(n))/ time and /O(1)/ memory.+--+-- @+-- postSet x 'empty'      == Set.'Set.empty'+-- postSet x ('vertex' x) == Set.'Set.empty'+-- postSet x ('edge' x y) == Set.'Set.fromList' [y]+-- postSet 2 ('edge' 1 2) == Set.'Set.empty'+-- @+postSet :: Ord a => a -> AdjacencyMap a -> Set a+postSet x = Map.findWithDefault Set.empty x . adjacencyMap++-- | The /path/ on a list of vertices.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- path []        == 'empty'+-- path [x]       == 'vertex' x+-- path [x,y]     == 'edge' x y+-- path . 'reverse' == 'transpose' . path+-- @+path :: Ord a => [a] -> AdjacencyMap a+path xs = case xs of []     -> empty+                     [x]    -> vertex x+                     (_:ys) -> edges (zip xs ys)++-- | The /circuit/ on a list of vertices.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- circuit []        == 'empty'+-- circuit [x]       == 'edge' x x+-- circuit [x,y]     == 'edges' [(x,y), (y,x)]+-- circuit . 'reverse' == 'transpose' . circuit+-- @+circuit :: Ord a => [a] -> AdjacencyMap a+circuit []     = empty+circuit (x:xs) = path $ [x] ++ xs ++ [x]++-- | The /clique/ on a list of vertices.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- clique []         == 'empty'+-- clique [x]        == 'vertex' x+-- clique [x,y]      == 'edge' x y+-- clique [x,y,z]    == 'edges' [(x,y), (x,z), (y,z)]+-- clique (xs '++' ys) == 'connect' (clique xs) (clique ys)+-- clique . 'reverse'  == 'transpose' . clique+-- @+clique :: Ord a => [a] -> AdjacencyMap a+clique = fromAdjacencySets . fst . go+  where+    go []     = ([], Set.empty)+    go (x:xs) = let (res, set) = go xs in ((x, set) : res, Set.insert x set)+{-# NOINLINE [1] clique #-}++-- | The /biclique/ on two lists of vertices.+-- Complexity: /O(n * log(n) + m)/ time and /O(n + m)/ memory.+--+-- @+-- biclique []      []      == 'empty'+-- biclique [x]     []      == 'vertex' x+-- biclique []      [y]     == 'vertex' y+-- biclique [x1,x2] [y1,y2] == 'edges' [(x1,y1), (x1,y2), (x2,y1), (x2,y2)]+-- biclique xs      ys      == 'connect' ('vertices' xs) ('vertices' ys)+-- @+biclique :: Ord a => [a] -> [a] -> AdjacencyMap a+biclique xs ys = AM $ Map.fromSet adjacent (x `Set.union` y)+  where+    x = Set.fromList xs+    y = Set.fromList ys+    adjacent v = if v `Set.member` x then y else Set.empty++-- TODO: Optimise.+-- | The /star/ formed by a centre vertex connected to a list of leaves.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- star x []    == 'vertex' x+-- star x [y]   == 'edge' x y+-- star x [y,z] == 'edges' [(x,y), (x,z)]+-- star x ys    == 'connect' ('vertex' x) ('vertices' ys)+-- @+star :: Ord a => a -> [a] -> AdjacencyMap a+star x [] = vertex x+star x ys = connect (vertex x) (vertices ys)+{-# INLINE star #-}++-- | The /stars/ formed by overlaying a list of 'star's. An inverse of+-- 'adjacencyList'.+-- Complexity: /O(L * log(n))/ time, memory and size, where /L/ is the total+-- size of the input.+--+-- @+-- stars []                      == 'empty'+-- stars [(x, [])]               == 'vertex' x+-- stars [(x, [y])]              == 'edge' x y+-- stars [(x, ys)]               == 'star' x ys+-- stars                         == 'overlays' . 'map' ('uncurry' 'star')+-- stars . 'adjacencyList'         == id+-- 'overlay' (stars xs) (stars ys) == stars (xs '++' ys)+-- @+stars :: Ord a => [(a, [a])] -> AdjacencyMap a+stars = fromAdjacencySets . map (fmap Set.fromList)++-- | Construct a graph from a list of adjacency sets; a variation of 'stars'.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- fromAdjacencySets []                                  == 'empty'+-- fromAdjacencySets [(x, Set.'Set.empty')]                    == 'vertex' x+-- fromAdjacencySets [(x, Set.'Set.singleton' y)]              == 'edge' x y+-- fromAdjacencySets . 'map' ('fmap' Set.'Set.fromList')           == 'stars'+-- 'overlay' (fromAdjacencySets xs) (fromAdjacencySets ys) == fromAdjacencySets (xs '++' ys)+-- @+fromAdjacencySets :: Ord a => [(a, Set a)] -> AdjacencyMap a+fromAdjacencySets ss = AM $ Map.unionWith Set.union vs es+  where+    vs = Map.fromSet (const Set.empty) . Set.unions $ map snd ss+    es = Map.fromListWith Set.union ss++-- | The /tree graph/ constructed from a given 'Tree' data structure.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- tree (Node x [])                                         == 'vertex' x+-- tree (Node x [Node y [Node z []]])                       == 'path' [x,y,z]+-- tree (Node x [Node y [], Node z []])                     == 'star' x [y,z]+-- tree (Node 1 [Node 2 [], Node 3 [Node 4 [], Node 5 []]]) == 'edges' [(1,2), (1,3), (3,4), (3,5)]+-- @+tree :: Ord a => Tree a -> AdjacencyMap a+tree (Node x []) = vertex x+tree (Node x f ) = star x (map rootLabel f)+    `overlay` forest (filter (not . null . subForest) f)++-- | The /forest graph/ constructed from a given 'Forest' data structure.+-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- forest []                                                  == 'empty'+-- forest [x]                                                 == 'tree' x+-- forest [Node 1 [Node 2 [], Node 3 []], Node 4 [Node 5 []]] == 'edges' [(1,2), (1,3), (4,5)]+-- forest                                                     == 'overlays' . 'map' 'tree'+-- @+forest :: Ord a => Forest a -> AdjacencyMap a+forest = overlays . map tree++-- | Remove a vertex from a given graph.+-- Complexity: /O(n*log(n))/ time.+--+-- @+-- removeVertex x ('vertex' x)       == 'empty'+-- removeVertex 1 ('vertex' 2)       == 'vertex' 2+-- removeVertex x ('edge' x x)       == 'empty'+-- removeVertex 1 ('edge' 1 2)       == 'vertex' 2+-- removeVertex x . removeVertex x == removeVertex x+-- @+removeVertex :: Ord a => a -> AdjacencyMap a -> AdjacencyMap a+removeVertex x = AM . Map.map (Set.delete x) . Map.delete x . adjacencyMap++-- | Remove an edge from a given graph.+-- Complexity: /O(log(n))/ time.+--+-- @+-- removeEdge x y ('edge' x y)       == 'vertices' [x,y]+-- removeEdge x y . removeEdge x y == removeEdge x y+-- removeEdge x y . 'removeVertex' x == 'removeVertex' x+-- removeEdge 1 1 (1 * 1 * 2 * 2)  == 1 * 2 * 2+-- removeEdge 1 2 (1 * 1 * 2 * 2)  == 1 * 1 + 2 * 2+-- @+removeEdge :: Ord a => a -> a -> AdjacencyMap a -> AdjacencyMap a+removeEdge x y = AM . Map.adjust (Set.delete y) x . adjacencyMap++-- | The function @'replaceVertex' x y@ replaces vertex @x@ with vertex @y@ in a+-- given 'AdjacencyMap'. If @y@ already exists, @x@ and @y@ will be merged.+-- Complexity: /O((n + m) * log(n))/ time.+--+-- @+-- replaceVertex x x            == id+-- replaceVertex x y ('vertex' x) == 'vertex' y+-- replaceVertex x y            == 'mergeVertices' (== x) y+-- @+replaceVertex :: Ord a => a -> a -> AdjacencyMap a -> AdjacencyMap a+replaceVertex u v = gmap $ \w -> if w == u then v else w++-- | Merge vertices satisfying a given predicate into a given vertex.+-- Complexity: /O((n + m) * log(n))/ time, assuming that the predicate takes+-- constant time.+--+-- @+-- mergeVertices ('const' False) x    == id+-- mergeVertices (== x) y           == 'replaceVertex' x y+-- mergeVertices 'even' 1 (0 * 2)     == 1 * 1+-- mergeVertices 'odd'  1 (3 + 4 * 5) == 4 * 1+-- @+mergeVertices :: Ord a => (a -> Bool) -> a -> AdjacencyMap a -> AdjacencyMap a+mergeVertices p v = gmap $ \u -> if p u then v else u++-- | Transpose a given graph.+-- Complexity: /O(m * log(n))/ time, /O(n + m)/ memory.+--+-- @+-- transpose 'empty'       == 'empty'+-- transpose ('vertex' x)  == 'vertex' x+-- transpose ('edge' x y)  == 'edge' y x+-- transpose . transpose == id+-- 'edgeList' . transpose  == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . 'edgeList'+-- @+transpose :: Ord a => AdjacencyMap a -> AdjacencyMap a+transpose (AM m) = AM $ Map.foldrWithKey combine vs m+  where+    combine v es = Map.unionWith Set.union (Map.fromSet (const $ Set.singleton v) es)+    vs           = Map.fromSet (const Set.empty) (Map.keysSet m)+{-# NOINLINE [1] transpose #-}++{-# RULES+"transpose/empty"    transpose empty = empty+"transpose/vertex"   forall x. transpose (vertex x) = vertex x+"transpose/overlay"  forall g1 g2. transpose (overlay g1 g2) = overlay (transpose g1) (transpose g2)+"transpose/connect"  forall g1 g2. transpose (connect g1 g2) = connect (transpose g2) (transpose g1)++"transpose/overlays" forall xs. transpose (overlays xs) = overlays (map transpose xs)+"transpose/connects" forall xs. transpose (connects xs) = connects (reverse (map transpose xs))++"transpose/vertices" forall xs. transpose (vertices xs) = vertices xs+"transpose/clique"   forall xs. transpose (clique xs)   = clique (reverse xs)+ #-}++-- | Transform a graph by applying a function to each of its vertices. This is+-- similar to @Functor@'s 'fmap' but can be used with non-fully-parametric+-- 'AdjacencyMap'.+-- Complexity: /O((n + m) * log(n))/ time.+--+-- @+-- gmap f 'empty'      == 'empty'+-- gmap f ('vertex' x) == 'vertex' (f x)+-- gmap f ('edge' x y) == 'edge' (f x) (f y)+-- gmap 'id'           == 'id'+-- gmap f . gmap g   == gmap (f . g)+-- @+gmap :: (Ord a, Ord b) => (a -> b) -> AdjacencyMap a -> AdjacencyMap b+gmap f = AM . Map.map (Set.map f) . Map.mapKeysWith Set.union f . adjacencyMap++-- | Construct the /induced subgraph/ of a given graph by removing the+-- vertices that do not satisfy a given predicate.+-- Complexity: /O(n + m)/ time, assuming that the predicate takes constant time.+--+-- @+-- induce ('const' True ) x      == x+-- induce ('const' False) x      == 'empty'+-- induce (/= x)               == 'removeVertex' x+-- induce p . induce q         == induce (\\x -> p x && q x)+-- 'isSubgraphOf' (induce p x) x == True+-- @+induce :: (a -> Bool) -> AdjacencyMap a -> AdjacencyMap a+induce p = AM . Map.map (Set.filter p) . Map.filterWithKey (\k _ -> p k) . adjacencyMap++-- | Construct the /induced subgraph/ of a given graph by removing the vertices+-- that are 'Nothing'.+-- Complexity: /O(n + m)/ time.+--+-- @+-- induceJust ('vertex' 'Nothing')                               == 'empty'+-- induceJust ('edge' ('Just' x) 'Nothing')                        == 'vertex' x+-- induceJust . 'gmap' 'Just'                                    == 'id'+-- induceJust . 'gmap' (\\x -> if p x then 'Just' x else 'Nothing') == 'induce' p+-- @+induceJust :: Ord a => AdjacencyMap (Maybe a) -> AdjacencyMap a+induceJust = AM . Map.map catMaybesSet . catMaybesMap . adjacencyMap+    where+      catMaybesSet = Set.mapMonotonic     Maybe.fromJust . Set.delete Nothing+      catMaybesMap = Map.mapKeysMonotonic Maybe.fromJust . Map.delete Nothing++-- | Left-to-right /relational composition/ of graphs: vertices @x@ and @z@ are+-- connected in the resulting graph if there is a vertex @y@, such that @x@ is+-- connected to @y@ in the first graph, and @y@ is connected to @z@ in the+-- second graph. There are no isolated vertices in the result. This operation is+-- associative, has 'empty' and single-'vertex' graphs as /annihilating zeroes/,+-- and distributes over 'overlay'.+-- Complexity: /O(n * m * log(n))/ time and /O(n + m)/ memory.+--+-- @+-- compose 'empty'            x                == 'empty'+-- compose x                'empty'            == 'empty'+-- compose ('vertex' x)       y                == 'empty'+-- compose x                ('vertex' y)       == 'empty'+-- compose x                (compose y z)    == compose (compose x y) z+-- compose x                ('overlay' y z)    == 'overlay' (compose x y) (compose x z)+-- compose ('overlay' x y)    z                == 'overlay' (compose x z) (compose y z)+-- compose ('edge' x y)       ('edge' y z)       == 'edge' x z+-- compose ('path'    [1..5]) ('path'    [1..5]) == 'edges' [(1,3), (2,4), (3,5)]+-- compose ('circuit' [1..5]) ('circuit' [1..5]) == 'circuit' [1,3,5,2,4]+-- @+compose :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a+compose x y = fromAdjacencySets+    [ (t, ys) | v <- Set.toList vs, let ys = postSet v y, not (Set.null ys)+              , t <- Set.toList (postSet v tx) ]+  where+    tx = transpose x+    vs = vertexSet x `Set.union` vertexSet y++-- | Compute the /Cartesian product/ of graphs.+-- Complexity: /O((n + m) * log(n))/ time and O(n + m) memory.+--+-- @+-- box ('path' [0,1]) ('path' "ab") == 'edges' [ ((0,\'a\'), (0,\'b\'))+--                                       , ((0,\'a\'), (1,\'a\'))+--                                       , ((0,\'b\'), (1,\'b\'))+--                                       , ((1,\'a\'), (1,\'b\')) ]+-- @+--+-- Up to isomorphism between the resulting vertex types, this operation is+-- /commutative/, /associative/, /distributes/ over 'overlay', has singleton+-- graphs as /identities/ and 'empty' as the /annihilating zero/. Below @~~@+-- stands for equality up to an isomorphism, e.g. @(x,@ @()) ~~ x@.+--+-- @+-- box x y               ~~ box y x+-- box x (box y z)       ~~ box (box x y) z+-- box x ('overlay' y z)   == 'overlay' (box x y) (box x z)+-- box x ('vertex' ())     ~~ x+-- box x 'empty'           ~~ 'empty'+-- 'transpose'   (box x y) == box ('transpose' x) ('transpose' y)+-- 'vertexCount' (box x y) == 'vertexCount' x * 'vertexCount' y+-- 'edgeCount'   (box x y) <= 'vertexCount' x * 'edgeCount' y + 'edgeCount' x * 'vertexCount' y+-- @+box :: (Ord a, Ord b) => AdjacencyMap a -> AdjacencyMap b -> AdjacencyMap (a, b)+box (AM x) (AM y) = overlay (AM $ Map.fromAscList xs) (AM $ Map.fromAscList ys)+  where+    xs = do (a, as) <- Map.toAscList x+            b       <- Set.toAscList (Map.keysSet y)+            return ((a, b), Set.mapMonotonic (,b) as)+    ys = do a       <- Set.toAscList (Map.keysSet x)+            (b, bs) <- Map.toAscList y+            return ((a, b), Set.mapMonotonic (a,) bs)++-- | Compute the /reflexive and transitive closure/ of a graph.+-- Complexity: /O(n * m * log(n)^2)/ time.+--+-- @+-- closure 'empty'           == 'empty'+-- closure ('vertex' x)      == 'edge' x x+-- closure ('edge' x x)      == 'edge' x x+-- closure ('edge' x y)      == 'edges' [(x,x), (x,y), (y,y)]+-- closure ('path' $ 'Data.List.nub' xs) == 'reflexiveClosure' ('clique' $ 'Data.List.nub' xs)+-- closure                 == 'reflexiveClosure' . 'transitiveClosure'+-- closure                 == 'transitiveClosure' . 'reflexiveClosure'+-- closure . closure       == closure+-- 'postSet' x (closure y)   == Set.'Set.fromList' ('Algebra.Graph.ToGraph.reachable' y x)+-- @+closure :: Ord a => AdjacencyMap a -> AdjacencyMap a+closure = reflexiveClosure . transitiveClosure++-- | Compute the /reflexive closure/ of a graph by adding a self-loop to every+-- vertex.+-- Complexity: /O(n * log(n))/ time.+--+-- @+-- reflexiveClosure 'empty'              == 'empty'+-- reflexiveClosure ('vertex' x)         == 'edge' x x+-- reflexiveClosure ('edge' x x)         == 'edge' x x+-- reflexiveClosure ('edge' x y)         == 'edges' [(x,x), (x,y), (y,y)]+-- reflexiveClosure . reflexiveClosure == reflexiveClosure+-- @+reflexiveClosure :: Ord a => AdjacencyMap a -> AdjacencyMap a+reflexiveClosure (AM m) = AM $ Map.mapWithKey Set.insert m++-- | Compute the /symmetric closure/ of a graph by overlaying it with its own+-- transpose.+-- Complexity: /O((n + m) * log(n))/ time.+--+-- @+-- symmetricClosure 'empty'              == 'empty'+-- symmetricClosure ('vertex' x)         == 'vertex' x+-- symmetricClosure ('edge' x y)         == 'edges' [(x,y), (y,x)]+-- symmetricClosure x                  == 'overlay' x ('transpose' x)+-- symmetricClosure . symmetricClosure == symmetricClosure+-- @+symmetricClosure :: Ord a => AdjacencyMap a -> AdjacencyMap a+symmetricClosure m = overlay m (transpose m)++-- | Compute the /transitive closure/ of a graph.+-- Complexity: /O(n * m * log(n)^2)/ time.+--+-- @+-- transitiveClosure 'empty'               == 'empty'+-- transitiveClosure ('vertex' x)          == 'vertex' x+-- transitiveClosure ('edge' x y)          == 'edge' x y+-- transitiveClosure ('path' $ 'Data.List.nub' xs)     == 'clique' ('Data.List.nub' xs)+-- transitiveClosure . transitiveClosure == transitiveClosure+-- @+transitiveClosure :: Ord a => AdjacencyMap a -> AdjacencyMap a+transitiveClosure old+    | old == new = old+    | otherwise  = transitiveClosure new+  where+    new = overlay old (old `compose` old)++-- | Check that the internal graph representation is consistent, i.e. that all+-- edges refer to existing vertices. It should be impossible to create an+-- inconsistent adjacency map, and we use this function in testing.+--+-- @+-- consistent 'empty'         == True+-- consistent ('vertex' x)    == True+-- consistent ('overlay' x y) == True+-- consistent ('connect' x y) == True+-- consistent ('edge' x y)    == True+-- consistent ('edges' xs)    == True+-- consistent ('stars' xs)    == True+-- @+consistent :: Ord a => AdjacencyMap a -> Bool+consistent (AM m) = referredToVertexSet m `Set.isSubsetOf` Map.keysSet m++-- The set of vertices that are referred to by the edges of an adjacency map.+referredToVertexSet :: Ord a => Map a (Set a) -> Set a+referredToVertexSet m = Set.fromList $ concat+    [ [x, y] | (x, ys) <- Map.toAscList m, y <- Set.toAscList ys ]

@@ -0,0 +1,52 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE LambdaCase #-}+module Cauldron.Graph.Algorithm (+    reverseTopSort+    ) where++import Cauldron.Graph+import Data.List.NonEmpty+import Data.Graph qualified+import Data.Foldable (for_)+import Data.Sequence qualified+import Data.Set qualified+import Data.Map.Strict qualified+import Data.Foldable qualified+import Data.Function ((&))++reverseTopSort :: Ord a => AdjacencyMap a -> Either (NonEmpty a) [a] +reverseTopSort g = do+    let theEdges = do+            (i,o) <- adjacencyList g +            [(i,i,o)]+        sccs = Data.Graph.stronglyConnComp theEdges+    for_ sccs $ \case+        Data.Graph.AcyclicSCC _  -> pure ()+        Data.Graph.NECyclicSCC vs -> do+                let aCycle = findCycleInSCC g vs+                Left aCycle+    let (g',nodeFromVertex,_) = Data.Graph.graphFromEdges theEdges+    Right $ do+            ves <- Data.Graph.reverseTopSort g'+            let (v,_,_) = nodeFromVertex ves+            [v]++findCycleInSCC :: Ord a => AdjacencyMap a -> NonEmpty a -> NonEmpty a+findCycleInSCC g scc@(start :| _) = go start (Data.Set.singleton start) (Data.Sequence.singleton start)+  where+    sccSet = Data.Set.fromList . Data.Foldable.toList $ scc+    isInScc = (`Data.Set.member` sccSet)+    am = adjacencyMap $ Cauldron.Graph.induce isInScc g+    firstChildOf v = +      case Data.Set.toList <$> Data.Map.Strict.lookup v am of+        Nothing -> error "findCycleInSCC: node not in adjacency map"+        -- In a SCC, all vertices should have at least one outgoing edge!+        Just [] -> error "findCycleInSCC: SCC node with no outgoing edge"+        Just (child:_) -> child+    go current visited cycleAcc =+        let child = firstChildOf current+         in if child `Data.Set.member` visited+            then+              Data.List.NonEmpty.fromList $ Data.Foldable.toList $ Data.Sequence.dropWhileL (/= child) cycleAcc+            else+              go child (visited & Data.Set.insert child) (cycleAcc Data.Sequence.|> child)

@@ -0,0 +1,187 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module     : Algebra.Graph.Export+-- Copyright  : (c) Andrey Mokhov 2016-2024+-- License    : MIT (see the file LICENSE)+-- Maintainer : andrey.mokhov@gmail.com+-- Stability  : experimental+--+-- __Alga__ is a library for algebraic construction and manipulation of graphs+-- in Haskell. See <https://github.com/snowleopard/alga-paper this paper> for the+-- motivation behind the library, the underlying theory, and implementation details.+--+-- This module defines basic functionality for exporting graphs in textual and+-- binary formats. "Algebra.Graph.Export.Dot" provides DOT-specific functions.+-----------------------------------------------------------------------------+module Cauldron.Graph.Export (+    -- * Constructing and exporting documents+    Doc, isEmpty, literal, render,++    -- * Common combinators for text documents+    (<+>), brackets, doubleQuotes, indent, unlines,++    -- * Generic graph export+    export+    ) where++import Data.Foldable (fold)+import Data.String hiding (unlines)+import Prelude hiding (unlines)++import Cauldron.Graph (AdjacencyMap, vertexList, edgeList)++-- | An abstract document data type with /O(1)/ time concatenation (the current+-- implementation uses difference lists). Here @s@ is the type of abstract+-- symbols or strings (text or binary). 'Doc' @s@ is a 'Monoid', therefore+-- 'mempty' corresponds to the /empty document/ and two documents can be+-- concatenated with 'mappend' (or operator 'Data.Semigroup.<>'). Documents+-- comprising a single symbol or string can be constructed using the function+-- 'literal'. Alternatively, you can construct documents as string literals,+-- e.g. simply as @"alga"@, by using the @OverloadedStrings@ GHC extension. To+-- extract the document contents use the function 'render'.+--+-- Note that the document comprising a single empty string is considered to be+-- different from the empty document. This design choice is motivated by the+-- desire to support string types @s@ that have no 'Eq' instance, such as+-- "Data.ByteString.Builder", for which there is no way to check whether a+-- string is empty or not. As a consequence, the 'Eq' and 'Ord' instances are+-- defined as follows:+--+-- @+-- 'mempty' /= 'literal' ""+-- 'mempty' <  'literal' ""+-- @+newtype Doc s = Doc [s] deriving (Monoid, Semigroup)++instance (Monoid s, Show s) => Show (Doc s) where+    show = show . render++instance (Monoid s, Eq s) => Eq (Doc s) where+    x == y | isEmpty x = isEmpty y+           | isEmpty y = False+           | otherwise = render x == render y++-- | The empty document is smallest.+instance (Monoid s, Ord s) => Ord (Doc s) where+    compare x y | isEmpty x = if isEmpty y then EQ else LT+                | isEmpty y = GT+                | otherwise = compare (render x) (render y)++instance IsString s => IsString (Doc s) where+    fromString = literal . fromString++-- | Check if a document is empty. The result is the same as when comparing the+-- given document to 'mempty', but this function does not require the 'Eq' @s@+-- constraint. Note that the document comprising a single empty string is+-- considered to be different from the empty document.+--+-- @+-- isEmpty 'mempty'       == True+-- isEmpty ('literal' \"\") == False+-- isEmpty x            == (x == 'mempty')+-- @+isEmpty :: Doc s -> Bool+isEmpty (Doc xs) = null xs++-- | Construct a document comprising a single symbol or string. If @s@ is an+-- instance of class 'IsString', then documents of type 'Doc' @s@ can be+-- constructed directly from string literals (see the second example below).+--+-- @+-- literal "Hello, " 'Data.Semigroup.<>' literal "World!" == literal "Hello, World!"+-- literal "I am just a string literal"  == "I am just a string literal"+-- 'render' . literal                      == 'id'+-- @+literal :: s -> Doc s+literal = Doc . pure++-- | Render the document as a single string. An inverse of the function 'literal'.+--+-- @+-- render ('literal' "al" 'Data.Semigroup.<>' 'literal' "ga") :: ('IsString' s, 'Monoid' s) => s+-- render ('literal' "al" 'Data.Semigroup.<>' 'literal' "ga") == "alga"+-- render 'mempty'                         == 'mempty'+-- render . 'literal'                      == 'id'+-- @+render :: Monoid s => Doc s -> s+render (Doc x) = fold x++-- | Concatenate two documents, separated by a single space, unless one of the+-- documents is empty. The operator \<+\> is associative with identity 'mempty'.+--+-- @+-- x \<+\> 'mempty'         == x+-- 'mempty' \<+\> x         == x+-- x \<+\> (y \<+\> z)      == (x \<+\> y) \<+\> z+-- "name" \<+\> "surname" == "name surname"+-- @+(<+>) :: IsString s => Doc s -> Doc s -> Doc s+x <+> y | isEmpty x = y+        | isEmpty y = x+        | otherwise = x <> " " <> y++infixl 7 <+>++-- | Wrap a document in square brackets.+--+-- @+-- brackets "i"    == "[i]"+-- brackets 'mempty' == "[]"+-- @+brackets :: IsString s => Doc s -> Doc s+brackets x = "[" <> x <> "]"++-- | Wrap a document into double quotes.+--+-- @+-- doubleQuotes "\/path\/with spaces"   == "\\"\/path\/with spaces\\""+-- doubleQuotes (doubleQuotes 'mempty') == "\\"\\"\\"\\""+-- @+doubleQuotes :: IsString s => Doc s -> Doc s+doubleQuotes x = "\"" <> x <> "\""++-- | Prepend a given number of spaces to a document.+--+-- @+-- indent 0        == 'id'+-- indent 1 'mempty' == " "+-- @+indent :: IsString s => Int -> Doc s -> Doc s+indent spaces x = fromString (replicate spaces ' ') <> x++-- | Concatenate documents after appending a terminating newline symbol to each.+--+-- @+-- unlines []                    == 'mempty'+-- unlines ['mempty']              == "\\n"+-- unlines ["title", "subtitle"] == "title\\nsubtitle\\n"+-- @+unlines :: IsString s => [Doc s] -> Doc s+unlines []     = mempty+unlines (x:xs) = x <> "\n" <> unlines xs++-- TODO: Avoid round-trip graph conversion if g :: AdjacencyMap a.+-- | Export a graph into a document given two functions that construct documents+-- for individual vertices and edges. The order of export is: vertices, sorted+-- by 'Ord' @a@, and then edges, sorted by 'Ord' @(a, a)@.+--+-- For example:+--+-- @+-- vDoc x   = 'literal' ('show' x) <> "\\n"+-- eDoc x y = 'literal' ('show' x) <> " -> " <> 'literal' ('show' y) <> "\\n"+-- > putStrLn $ 'render' $ export vDoc eDoc (1 + 2 * (3 + 4) :: 'Algebra.Graph.Graph' Int)+--+-- 1+-- 2+-- 3+-- 4+-- 2 -> 3+-- 2 -> 4+-- @+export :: (Ord a) => (a -> Doc s) -> (a -> a -> Doc s) -> AdjacencyMap a -> Doc s+export v e adjMap = vDoc <> eDoc+  where+    vDoc   = mconcat $ map  v          (vertexList adjMap)+    eDoc   = mconcat $ map (uncurry e) (edgeList   adjMap)

@@ -0,0 +1,145 @@+{-# LANGUAGE OverloadedStrings, RecordWildCards #-}+-----------------------------------------------------------------------------+-- |+-- Module     : Algebra.Graph.Export.Dot+-- Copyright  : (c) Andrey Mokhov 2016-2024+-- License    : MIT (see the file LICENSE)+-- Maintainer : andrey.mokhov@gmail.com+-- Stability  : experimental+--+-- __Alga__ is a library for algebraic construction and manipulation of graphs+-- in Haskell. See <https://github.com/snowleopard/alga-paper this paper> for the+-- motivation behind the library, the underlying theory, and implementation details.+--+-- This module defines functions for exporting graphs in the DOT file format.+-----------------------------------------------------------------------------+module Cauldron.Graph.Export.Dot (+    -- * Graph attributes and style+    Attribute (..), Quoting (..), Style (..), defaultStyle, defaultStyleViaShow,++    -- * Export functions+    export+    ) where++import Data.List (intersperse)+import Data.Monoid+import Data.String hiding (unlines)+import Prelude hiding (unlines)+import Cauldron.Graph+import Cauldron.Graph.Export hiding (export)+import Cauldron.Graph.Export qualified as E++-- | An attribute is just a key-value pair, for example @"shape" := "box"@.+-- Attributes are used to specify the style of graph elements during export.+data Attribute s = (:=) s s++-- TODO: Do we need other quoting styles, for example, 'SingleQuotes'?+-- TODO: Shall we use 'Quoting' for vertex names too?+-- | The style of quoting used when exporting attributes; 'DoubleQuotes' is the+-- default.+data Quoting = DoubleQuotes | NoQuotes++-- | The record 'Style' @a@ @s@ specifies the style to use when exporting a+-- graph in the DOT format. Here @a@ is the type of the graph vertices, and @s@+-- is the type of string to represent the resulting DOT document (e.g. String,+-- Text, etc.). The only field that has no obvious default value is+-- 'vertexName', which holds a function of type @a -> s@ to compute vertex+-- names. See the function 'export' for an example.+data Style a s = Style+    { graphName :: s+    -- ^ Name of the graph.+    , preamble :: [s]+    -- ^ Preamble (a list of lines) is added at the beginning of the DOT file body.+    , graphAttributes :: [Attribute s]+    -- ^ Graph style, e.g. @["bgcolor" := "azure"]@.+    , defaultVertexAttributes :: [Attribute s]+    -- ^ Default vertex style, e.g. @["shape" := "diamond"]@.+    , defaultEdgeAttributes :: [Attribute s]+    -- ^ Default edge style, e.g. @["style" := "dashed"]@.+    , vertexName :: a -> s+    -- ^ Compute a vertex name.+    , vertexAttributes :: a -> [Attribute s]+    -- ^ Attributes of a specific vertex.+    , edgeAttributes   :: a -> a -> [Attribute s]+    -- ^ Attributes of a specific edge.+    , attributeQuoting :: Quoting+    -- ^ The quoting style used for attributes.+    }++-- | Default style for exporting graphs. The 'vertexName' field is provided as+-- the only argument; the other fields are set to trivial defaults.+defaultStyle :: Monoid s => (a -> s) -> Style a s+defaultStyle v = Style mempty [] [] [] [] v (const []) (\_ _ -> []) DoubleQuotes++-- | Default style for exporting graphs with 'Show'-able vertices. The+-- 'vertexName' field is computed using 'show'; the other fields are set to+-- trivial defaults.+--+-- @+-- defaultStyleViaShow = 'defaultStyle' ('fromString' . 'show')+-- @+defaultStyleViaShow :: (Show a, IsString s, Monoid s) => Style a s+defaultStyleViaShow = defaultStyle (fromString . show)++-- | Export a graph with a given style.+--+-- For example:+--+-- @+-- style :: 'Style' Int String+-- style = 'Style'+--     { 'graphName'               = \"Example\"+--     , 'preamble'                = ["  // This is an example", ""]+--     , 'graphAttributes'         = ["label" := \"Example\", "labelloc" := "top"]+--     , 'defaultVertexAttributes' = ["shape" := "circle"]+--     , 'defaultEdgeAttributes'   = 'mempty'+--     , 'vertexName'              = \\x   -> "v" ++ 'show' x+--     , 'vertexAttributes'        = \\x   -> ["color" := "blue"   | 'odd' x      ]+--     , 'edgeAttributes'          = \\x y -> ["style" := "dashed" | 'odd' (x * y)]+--     , 'attributeQuoting'        = 'DoubleQuotes' }+--+-- > putStrLn $ export style (1 * 2 + 3 * 4 * 5 :: 'Graph' Int)+--+-- digraph Example+-- {+--   // This is an example+--+--   graph [label=\"Example\" labelloc="top"]+--   node [shape="circle"]+--   "v1" [color="blue"]+--   "v2"+--   "v3" [color="blue"]+--   "v4"+--   "v5" [color="blue"]+--   "v1" -> "v2"+--   "v3" -> "v4"+--   "v3" -> "v5" [style="dashed"]+--   "v4" -> "v5"+-- }+-- @+export :: (IsString s, Monoid s, Ord a) => Style a s -> AdjacencyMap a -> s+export Style {..} g = E.render $ header <> body <> "}\n"+  where+    header    = "digraph" <+> literal graphName <> "\n{\n"+    with x as = if null as then mempty else line (x <+> attributes attributeQuoting as)+    line s    = indent 2 s <> "\n"+    body      = unlines (map literal preamble)+             <> ("graph" `with` graphAttributes)+             <> ("node"  `with` defaultVertexAttributes)+             <> ("edge"  `with` defaultEdgeAttributes)+             <> E.export vDoc eDoc g+    label     = doubleQuotes . literal . vertexName+    vDoc x    = line $ label x <+>                      attributes attributeQuoting (vertexAttributes x)+    eDoc x y  = line $ label x <> " -> " <> label y <+> attributes attributeQuoting (edgeAttributes x y)++-- | Export a list of attributes using a specified quoting style.+-- Example: @attributes DoubleQuotes ["label" := "A label", "shape" := "box"]@+-- corresponds to document: @[label="A label" shape="box"]@.+attributes :: IsString s => Quoting -> [Attribute s] -> Doc s+attributes _ [] = mempty+attributes q as = brackets . mconcat . intersperse " " $ map dot as+  where+    dot (k := v) = literal k <> "=" <> quote (literal v)+    quote = case q of+        DoubleQuotes -> doubleQuotes+        NoQuotes     -> id

@@ -9,6 +9,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE DuplicateRecordFields #-}  -- | This is a library for performing dependency injection. It's an alternative -- to manually wiring your functions and passing all required parameters@@ -49,11 +50,10 @@ --           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+--   action <- cook @C forbidDepCycles cauldron & either throwIO pure+--   action -- :}--- Just C+-- C module Cauldron   ( -- * Filling the cauldron     Cauldron,@@ -103,13 +103,12 @@     hoistConstructor,     hoistConstructor', -    -- ** Registering secondary beans+    -- ** Registering aggregate beans     -- $secondarybeans      -- * Cooking the beans     cook,-    cookNonEmpty,-    cookTree,+    nest,      -- ** How loopy can we get?     Fire,@@ -117,17 +116,13 @@     allowSelfDeps,     allowDepCycles, -    -- ** Tasting the results-    Beans,-    taste,-     -- ** When things go wrong-    RecipeError (..),+    CookingError (..),     MissingDependencies (..),     DoubleDutyBeans (..),     DependencyCycle (..),-    prettyRecipeError,-    prettyRecipeErrorLines,+    prettyCookingError,+    prettyCookingErrorLines,      -- ** Visualizing dependencies between beans.     getDependencyGraph,@@ -140,24 +135,24 @@      -- *** Simplifying the dep graph     -- $simplifygraph-    removeSecondaryBeans,+    removeAggregates,     removeDecos,-    collapseToPrimaryBeans,+    collapseBeans,   ) 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.Graph (AdjacencyMap)+import Cauldron.Graph qualified as Graph+import Cauldron.Graph.Algorithm qualified as Graph+import Cauldron.Graph.Export.Dot qualified as Dot import Cauldron.Args+import Cauldron.Args.Internal (Args(..)) import Cauldron.Beans (SomeMonoidTypeRep (..)) import Cauldron.Beans qualified import Control.Exception (Exception (..)) import Control.Monad.Fix import Control.Monad.IO.Class import Data.Bifunctor (first)-import Data.ByteString qualified import Data.Dynamic import Data.Foldable qualified import Data.Function ((&))@@ -175,15 +170,15 @@ 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+import Data.String (IsString(..))+import System.IO qualified+import Control.Applicative ((<|>))  -- | 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.@@ -369,9 +364,8 @@ --               ] --           } --         ]---   action <- either throwIO pure $ cook forbidDepCycles cauldron---   beans <- action---   let Just Foo {sayFoo} = taste beans+--   action <- cook @Foo forbidDepCycles cauldron & either throwIO pure +--   Foo {sayFoo} <- action --   sayFoo -- :} -- deco2 init@@ -441,10 +435,10 @@ -- -- (The name is admittedly uninformative; the culinary metaphor was stretched too far.) data Fire m = Fire-  { shouldOmitDependency :: (BeanConstructionStep, BeanConstructionStep) -> Bool,+  { shouldEnforceDependency :: (BeanConstructionStep, BeanConstructionStep) -> Bool,     followPlanCauldron ::       Cauldron m ->-      Set TypeRep ->+      BeanGetter ->        Beans ->       Plan ->       m Beans@@ -455,13 +449,29 @@   ConstructorReps {argReps = Set.delete beanRep argReps, regReps, beanRep}  -- | Forbid any kind of cyclic dependencies between beans. This is probably what you want.+--+-- >>> :{+-- data A = A+-- loopyA :: A -> A+-- loopyA _ = A+-- :}+--+-- >>> :{+--   cook @A forbidDepCycles ([+--       recipe @A $ val $ wire loopyA+--       ] :: Cauldron IO) +--       & \case Left (DependencyCycleError _) -> "self dep is forbidden"; _ -> "oops"+-- :}+-- "self dep is forbidden" forbidDepCycles :: (Monad m) => Fire m forbidDepCycles =   Fire-    { shouldOmitDependency = \_ -> False,-      followPlanCauldron = \cauldron _secondaryBeanReps initial plan ->+    { shouldEnforceDependency = \_ -> True,+      followPlanCauldron = \cauldron previous initial plan -> do+        let makeBareView _ beans = beansBeanGetter beans <> previous+        let makeDecoView _ beans = beansBeanGetter beans <> previous         Data.Foldable.foldlM-          do followPlanStep (\_ -> id) (\_ -> id) cauldron mempty+          do followPlanStep makeBareView makeDecoView cauldron           initial           plan     }@@ -477,19 +487,46 @@ -- __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.+--+--+-- >>> :{+-- data A = A+-- loopyA :: A -> A+-- loopyA _ = A+-- :}+--+-- >>> :{+--   cook @A allowSelfDeps ([+--       recipe @A $ val $ wire loopyA+--       ] :: Cauldron IO) +--       & \case Left (DependencyCycleError _) -> "oops"; _ -> "self dep is ok"+-- :}+-- "self dep is ok"+--+-- >>> :{+-- data U = U+-- data V = V+-- loopyU :: V -> U+-- loopyU _ = U+-- loopyV :: U -> V+-- loopyV _ = V+-- :}+--+-- >>> :{+--   cook @U allowSelfDeps ([+--       recipe @U $ val $ wire loopyU,+--       recipe @V $ val $ wire loopyV+--       ] :: Cauldron IO) +--       & \case Left (DependencyCycleError _) -> "cycle between 2 deps"; _ -> "oops"+-- :}+-- "cycle between 2 deps" 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+    { shouldEnforceDependency = \case+        (BarePrimaryBean bean, FinishedBean anotherBean) | bean == anotherBean -> False+        _ -> True,+      followPlanCauldron = fixyFollowPlanCauldron     }  -- | Allow /any/ kind of dependency cycles.@@ -502,24 +539,52 @@ -- __BEWARE__: Pattern-matching too eagerly on argument beans during -- construction will cause infinite loops or, if you are lucky, throw -- 'Control.Exception.FixIOException's.+--+-- >>> :{+-- data U = U+-- data V = V+-- loopyU :: V -> U+-- loopyU _ = U+-- loopyV :: U -> V+-- loopyV _ = V+-- :}+--+-- >>> :{+--   cook @U allowDepCycles ([+--       recipe @U $ val $ wire loopyU,+--       recipe @V $ val $ wire loopyV+--       ] :: Cauldron IO) +--       & \case Left (DependencyCycleError _) -> "oops"; _ -> "cycles are ok"+-- :}+-- "cycles are ok" 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+    { shouldEnforceDependency = \case+        (BarePrimaryBean _, FinishedBean _) -> False+        (PrimaryBeanDeco _ _, FinishedBean _) -> False+        (AggregateBean _ , FinishedBean _) -> False+        _ -> True,+      followPlanCauldron = fixyFollowPlanCauldron     } ++fixyFollowPlanCauldron :: MonadFix m => Cauldron m -> BeanGetter -> Beans -> [BeanConstructionStep] -> m Beans+fixyFollowPlanCauldron = \cauldron previous initial plan -> do+  mfix do+    \final -> do+      -- We prefer the final beans.+      let makeBareView _ _ = beansBeanGetter final <> previous+      -- We prefer the final beans,+      -- *except* when the bean being decorated, +      -- because the decorator needs the in-construction version.+      let makeDecoView tr beans = (beansBeanGetter beans `restrict` Set.singleton tr) <> beansBeanGetter final <> previous+      Data.Foldable.foldlM+        do followPlanStep makeBareView makeDecoView cauldron+        initial+        plan++ -- https://discord.com/channels/280033776820813825/280036215477239809/1147832555828162594 -- https://github.com/ghc-proposals/ghc-proposals/pull/126#issuecomment-1363403330 @@ -545,57 +610,161 @@   | -- | 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+    FinishedBean TypeRep   | -- | Beans that are secondary registrations of a 'Constructor' and which are aggregated monoidally.-    SecondaryBean TypeRep+    AggregateBean TypeRep   deriving stock (Show, Eq, Ord) --- | Build the beans using the recipeMap stored in the 'Cauldron'.+-- | Build the requested @bean@ using the 'Recipe's stored in the 'Cauldron'.+-- The 'Cauldron' must contain a 'Recipe' for the requested bean, as well as+-- 'Recipe's for producing all of its transitive dependencies. ----- Any secondary beans that are registered by constructors are aggregated--- monoidally.+-- >>> :{+-- data A = A deriving Show+-- :}+--+-- >>> :{+-- cook @A forbidDepCycles (mempty :: Cauldron IO) +--  & \case Left (MissingResultBeanError _) -> "no recipe for requested bean"; _ -> "oops"+-- :}+-- "no recipe for requested bean"+--+-- >>> :{+-- data A = A deriving Show+-- data B = B A deriving Show+-- :}+--+-- >>> :{+-- cook @B forbidDepCycles ([recipe $ val $ wire B] :: Cauldron IO) +--  & \case Left (MissingDependenciesError _) -> "no recipe for A"; _ -> "oops"+-- :}+-- "no recipe for A"+--  cook ::-  forall m.-  (Monad m) =>+  forall {m} bean.+  (Monad m, Typeable bean) =>+  -- | The types of dependency cycles that are allowed between beans.   Fire m ->+  -- | A 'Cauldron' containing the necessary 'Recipe's.   Cauldron m ->-  Either RecipeError (m Beans)-cook fire cauldron =-  fmap @(Either RecipeError) (fmap @m rootLabel) $-    cookTree (Node (fire, cauldron) [])+  Either CookingError (m bean)+cook fire cauldron = do+  (mdeps, c) <- nest' fire cauldron+  _ <- case mdeps of+    [] -> Right ()+    d : _ -> Left $ MissingDependenciesError d+  Right $ do+    (_, bean) <- runConstructor (mempty @BeanGetter) c+    pure bean --- | Cook a nonempty list of 'Cauldron's.+-- | +-- +-- Takes a 'Cauldron' converts it into a 'Constructor' where any unfilled+-- dependencies are taken as the arguments of the 'Constructor'.  The+-- 'Constructor' can later be included in a bigger 'Cauldron', which will+-- provide the missing dependencies. ----- 'Cauldron's later in the list can see the beans in all previous 'Cauldron's,--- but not vice versa.+-- This function never fails with 'MissingDependenciesError'. ----- 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.+-- This is an advanced function for when you want limited scopes for some beans.+-- Usually 'cook' is enough. ----- 'Cauldron's down in the branches can see the beans of their ancestor--- 'Cauldron's, but not vice versa.+-- Consider these example definitions: ----- 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)+-- >>> :{+-- data A = A (IO ())+-- data B = B (IO ())+-- data C = C (IO ())+-- makeA :: A+-- makeA = A (putStrLn "A constructor")+-- makeA2 :: A+-- makeA2 = A (putStrLn "A2 constructor")+-- makeB :: A -> B+-- makeB (A a) = B (a >> putStrLn "B constructor")+-- makeC :: A -> B -> C+-- makeC = \(A a) (B b) -> C  (a >> b >> putStrLn "C constructor")+-- :}+--+-- This is a wiring that uses 'nest' to create an scope that gives a local+-- meaning to the bean @A@:+--+-- >>> :{+-- do+--   nested :: Constructor IO C <- nest @C forbidDepCycles [+--       recipe @A $ val $ wire makeA2, -- this will be used by makeC+--       recipe @C $ val $ wire makeC -- takes B from outside+--       ] & either throwIO pure+--   action <- cook @C forbidDepCycles [+--       recipe @A $ val $ wire makeA,+--       recipe @B $ val $ wire makeB,+--       recipe @C $ nested+--       ] & either throwIO pure+--   C c <- action+--   c+-- :}+-- A2 constructor+-- A constructor+-- B constructor+-- C constructor+--+-- compare with this other wiring that uses a single 'Cauldron':+--+-- >>> :{+-- do+--   action <- cook @C forbidDepCycles [+--       recipe @A $ val $ wire makeA,+--       recipe @B $ val $ wire makeB,+--       recipe @C $ val $ wire makeC+--       ] & either throwIO pure+--   C c <- action+--   c+-- :}+-- A constructor+-- A constructor+-- B constructor+-- C constructor+nest ::+  forall {m} bean.+  (Monad m, Typeable bean, HasCallStack) =>+  -- | The types of dependency cycles that are allowed between beans.+  Fire m ->+  -- | A 'Cauldron', possibly with unfilled dependencies.+  Cauldron m ->+  Either CookingError (Constructor m bean)+nest fire cauldron = withFrozenCallStack do+  (_, c) <- nest' fire cauldron+  pure c +nest' ::+  forall {m} bean.+  (Monad m, Typeable bean, HasCallStack) =>+  Fire m ->+  Cauldron m ->+  Either CookingError ([MissingDependencies], Constructor m bean)+nest' Fire {shouldEnforceDependency, followPlanCauldron} cauldron = withFrozenCallStack do+  accumMap <- first DoubleDutyBeansError do checkNoDoubleDutyBeans cauldron+  () <- first MissingResultBeanError do checkEntryPointPresent (typeRep (Proxy @bean)) (Map.keysSet accumMap) cauldron+  plan <- first DependencyCycleError do buildPlan shouldEnforceDependency cauldron+  let missingDeps = collectMissingDeps (Map.keysSet accumMap) (Cauldron.keysSet cauldron) cauldron+  Right $ (missingDeps, Constructor+    {+      _constructorCallStack = callStack,+      _args = Args {+        _argReps = missingDepsToArgReps missingDeps,+        _regReps = Set.empty,+        _runArgs = \previous -> do+          beans <- followPlanCauldron cauldron (BeanGetter previous) (fromDynList (Data.Foldable.toList accumMap)) plan+          pure $ pure $ fromJust $ taste @bean beans+      }+    })++checkEntryPointPresent :: TypeRep -> Set TypeRep -> Cauldron m -> Either TypeRep ()+checkEntryPointPresent tr secondary cauldron =  +  if Set.member tr (Cauldron.keysSet cauldron `Set.union` secondary)+    then Right ()+    else Left tr++ newtype DoubleDutyBeans = DoubleDutyBeans (Map TypeRep (CallStack, CallStack))   deriving stock (Show) @@ -603,23 +772,19 @@ -- 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+   let (_, deps) = buildDepsCauldron cauldron    in DependencyGraph {graph = Graph.edges deps}  checkNoDoubleDutyBeans ::-  Tree (Cauldron m) ->+  Cauldron m ->   Either DoubleDutyBeans (Map TypeRep Dynamic)-checkNoDoubleDutyBeans treecipes = do-  let (accumMap, beanSet) = cauldronTreeRegs treecipes+checkNoDoubleDutyBeans cauldron = do+  let (accumMap, beanSet) = cauldronRegs cauldron   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@@ -636,44 +801,24 @@ 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)+missingDepsToArgReps ::+  [MissingDependencies] ->+  Set TypeRep+missingDepsToArgReps = Set.unions . fmap (\(MissingDependencies _ _ missing) ->  missing) -checkMissingDepsCauldron ::+collectMissingDeps ::    -- | 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) ->+  [MissingDependencies]+collectMissingDeps accums available cauldron =+  demandsByConstructorsInCauldron cauldron & Data.Foldable.foldMap \(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+          then []+          else [MissingDependencies stack tr missing]  demandsByConstructorsInCauldron :: Cauldron m -> [(CallStack, TypeRep, Set TypeRep)] demandsByConstructorsInCauldron Cauldron {recipeMap} = do@@ -689,26 +834,20 @@ 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++buildPlan :: ((BeanConstructionStep, BeanConstructionStep) -> Bool) -> Cauldron m -> Either DependencyCycle Plan+buildPlan shouldEnforceDependency cauldron = do+  let (locations, deps) = buildDepsCauldron 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+  let graph = Graph.edges $ filter shouldEnforceDependency deps+  case Graph.reverseTopSort graph of     Left recipeCycle ->       Left $ DependencyCycle $ recipeCycle <&> \step -> (step, Map.lookup step locations)-    Right (reverse -> plan) -> do-      Right (plan, fire, cauldron)+    Right plan -> do+      Right plan -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+buildDepsCauldron :: Cauldron m -> (Map BeanConstructionStep CallStack, [(BeanConstructionStep, BeanConstructionStep)])+buildDepsCauldron Cauldron {recipeMap} = do   recipeMap     & Map.foldMapWithKey       \beanRep@@ -722,25 +861,25 @@          } ->           do             let bareBean = BarePrimaryBean beanRep-                boiledBean = PrimaryBean beanRep+                boiledBean = FinishedBean beanRep                 decoSteps = do                   (decoIndex, decoCon) <- zip [0 :: Int ..] (Data.Foldable.toList decos)                   [(PrimaryBeanDeco beanRep decoIndex, decoCon)]                 beanDeps = do-                  constructorEdges makeTargetStep bareBean (constructorReps bean)+                  constructorEdges 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)+                  constructorEdges 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)+                  (FinishedBean beanRep, BarePrimaryBean beanRep)                     :                     -- The dep chain of completed bean -> decorators -> bare bean.                     zip (Data.List.NonEmpty.tail innerSteps) (Data.List.NonEmpty.toList innerSteps)@@ -755,72 +894,83 @@               )  constructorEdges ::-  (TypeRep -> BeanConstructionStep) ->   BeanConstructionStep ->   ConstructorReps ->   [(BeanConstructionStep, BeanConstructionStep)]-constructorEdges makeTargetStep item (ConstructorReps {argReps, regReps}) =+constructorEdges item (ConstructorReps {argReps, regReps}) =   -- consumers depend on their args   ( do       argRep <- Set.toList argReps-      let argStep = makeTargetStep argRep+      let argStep = FinishedBean argRep       [(item, argStep)]   )     ++-    -- secondary beans depend on their producers+         ( do         (regRep, _) <- Map.toList regReps-        let repStep = SecondaryBean regRep-        [(repStep, item)]+        let repStep = AggregateBean regRep+        [+         -- aggregate beans depend on their producers     +         (repStep, item), +         -- The finished version of the aggregate bean depends on the aggregation step.+         (FinishedBean regRep, repStep) ]     ) -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)+data BeanGetter = BeanGetter { _run :: forall t. (Typeable t) => Maybe t }  +instance Semigroup BeanGetter where+  BeanGetter { _run = run1 } <> BeanGetter { _run = run2 } =+    BeanGetter { _run = run1 <|> run2 }++instance Monoid BeanGetter where+  mempty = BeanGetter { _run = Nothing }++runBeanGetter :: BeanGetter -> forall t. (Typeable t) => Maybe t +runBeanGetter BeanGetter { _run } = _run++beansBeanGetter :: Beans -> BeanGetter+beansBeanGetter beans = BeanGetter (taste beans) ++restrict :: BeanGetter -> Set TypeRep -> BeanGetter+restrict (BeanGetter { _run }) allowed =+  BeanGetter { _run = _run' }+  where+  _run' :: forall bean. (Typeable bean) => Maybe bean+  _run' =+    let tr = typeRep (Proxy @bean)+     in if tr `Set.member` allowed+          then _run+          else Nothing+++-- | Builds the transition function for a 'foldM'. followPlanStep ::   (Monad m) =>-  (TypeRep -> Beans -> Beans) ->-  (TypeRep -> Beans -> Beans) ->+  (TypeRep -> Beans -> BeanGetter) ->+  (TypeRep -> Beans -> BeanGetter) ->   Cauldron m ->   Beans ->-  Beans ->   BeanConstructionStep ->   m Beans-followPlanStep makeBareView makeDecoView Cauldron {recipeMap} final super item =+followPlanStep makeBareView makeDecoView Cauldron {recipeMap} 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)+        inserter <- followConstructor bean (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)+        inserter <- followConstructor deco (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+    AggregateBean {} -> pure super+    -- \| We do nothing here, the work has been done in previous 'BarePrimaryBean' and+    -- 'PrimaryBeanDeco' steps.+    FinishedBean {} -> pure super  -- | Build a bean out of already built beans. -- This can only work without blowing up if there aren't dependecy cycles@@ -828,18 +978,22 @@ followConstructor ::   (Monad m, Typeable bean) =>   Constructor m bean ->-  Beans ->-  Beans ->+  BeanGetter ->   m (Beans -> Beans)-followConstructor c final super = do-  (regs, bean) <- runConstructor [super, final] c+followConstructor c getter = do+  --   (regs, bean) <- runConstructor [super, final] c+  (regs, bean) <- runConstructor getter c   pure \bs ->     Cauldron.Beans.unionBeansMonoidally (getRegsReps (getConstructorArgs c)) bs regs       & Cauldron.Beans.insert bean  -- | Sometimes the 'cook'ing process goes wrong.-data RecipeError-  = -- | A 'Constructor' depends on beans that can't be found either in the current 'Cauldron' or its ancestors.+data CookingError+    +  = -- | The bean that was demanded from the 'Cauldron' doesn't have a 'Recipe' that produces it.+    MissingResultBeanError TypeRep +  |  +    -- | A 'Constructor' depends on beans that can't be found in the 'Cauldron'.     MissingDependenciesError MissingDependencies   | -- | Beans that work both as primary beans and as secondary beans     -- are disallowed.@@ -848,14 +1002,16 @@     DependencyCycleError DependencyCycle   deriving stock (Show) -instance Exception RecipeError where-  displayException = prettyRecipeError+instance Exception CookingError where+  displayException = prettyCookingError -prettyRecipeError :: RecipeError -> String-prettyRecipeError = Data.List.intercalate "\n" . prettyRecipeErrorLines+prettyCookingError :: CookingError -> String+prettyCookingError = Data.List.intercalate "\n" . prettyCookingErrorLines -prettyRecipeErrorLines :: RecipeError -> [String]-prettyRecipeErrorLines = \case+prettyCookingErrorLines :: CookingError -> [String]+prettyCookingErrorLines = \case+  MissingResultBeanError tr ->+     ["No recipe found that produces requested bean " ++ show tr]   MissingDependenciesError     (MissingDependencies constructorCallStack constructorResultRep missingDependenciesReps) ->       [ "This constructor for a value of type "@@ -886,8 +1042,8 @@              [ "- " ++ 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+                 FinishedBean rep -> "Complete bean " ++ show rep+                 AggregateBean rep -> "Secondary bean " ++ show rep              ]                ++ case mstack of                  Nothing -> []@@ -908,9 +1064,9 @@ 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}+removeAggregates :: DependencyGraph -> DependencyGraph+removeAggregates DependencyGraph {graph} =+  DependencyGraph {graph = Graph.induce (\case AggregateBean {} -> False; _ -> True) graph}  -- | Remove all vertices and edges related to bean decorators. removeDecos :: DependencyGraph -> DependencyGraph@@ -920,105 +1076,105 @@ -- | Unifies 'PrimaryBean's with their respective 'BarePrimaryBean's and 'PrimaryBeanDeco's. -- -- Also removes any self-loops.-collapseToPrimaryBeans :: DependencyGraph -> DependencyGraph-collapseToPrimaryBeans DependencyGraph {graph} = do+collapseBeans :: DependencyGraph -> DependencyGraph+collapseBeans DependencyGraph {graph} = do   let simplified =         Graph.gmap           ( \case-              BarePrimaryBean rep -> PrimaryBean rep-              PrimaryBeanDeco rep _ -> PrimaryBean rep-              other -> other+              BarePrimaryBean rep -> FinishedBean rep+              PrimaryBeanDeco rep _ -> FinishedBean rep+              AggregateBean rep -> FinishedBean rep+              FinishedBean rep -> FinishedBean rep           )           graph       -- Is there a simpler way to removoe self-loops?       vertices = Graph.vertexList simplified       edges = Graph.edgeList simplified       edgesWithoutSelfLoops =+        edges &         filter           ( \case-              (PrimaryBean source, PrimaryBean target) -> if source == target then False else True+              (FinishedBean source, FinishedBean 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 :: Dot.Style BeanConstructionStep String -> FilePath -> DependencyGraph -> IO () writeAsDot style filepath DependencyGraph {graph} = do   let dot = Dot.export style graph-  Data.ByteString.writeFile filepath (Data.Text.Encoding.encodeUtf8 dot)+  System.IO.withFile filepath System.IO.WriteMode $ \handle -> do+    System.IO.hSetEncoding handle System.IO.utf8  +    System.IO.hPutStrLn handle 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+-- When a 'CookingError' exists, is highlights the problematic 'BeanConstructionStep's.+defaultStyle :: (Monoid s, IsString s) => Maybe CookingError -> Dot.Style BeanConstructionStep s 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 (MissingResultBeanError _) ->+            []         Just (MissingDependenciesError (MissingDependencies _ _ missing)) ->           case step of-            PrimaryBean rep+            FinishedBean rep               | Set.member rep missing ->-                  [ Data.Text.pack "style" Dot.:= Data.Text.pack "dashed",-                    Data.Text.pack "color" Dot.:= Data.Text.pack "red"+                  [ fromString "style" Dot.:= fromString "dashed",+                    fromString "color" Dot.:= fromString "red"                   ]             _ -> []         Just (DoubleDutyBeansError (DoubleDutyBeans (Map.keysSet -> bs))) ->           case step of-            PrimaryBean rep+            FinishedBean rep               | Set.member rep bs ->-                  [ Data.Text.pack "style" Dot.:= Data.Text.pack "bold",-                    Data.Text.pack "color" Dot.:= Data.Text.pack "green"+                  [ fromString "style" Dot.:= fromString "bold",+                    fromString "color" Dot.:= fromString "green"                   ]-            SecondaryBean rep+            AggregateBean rep               | Set.member rep bs ->-                  [ Data.Text.pack "style" Dot.:= Data.Text.pack "bold",-                    Data.Text.pack "color" Dot.:= Data.Text.pack "green"+                  [ fromString "style" Dot.:= fromString "bold",+                    fromString "color" Dot.:= fromString "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"+              [ fromString "style" Dot.:= fromString "bold",+                fromString "color" Dot.:= fromString "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 :: IsString s => (BeanConstructionStep -> s) -> Dot.Style BeanConstructionStep s -> Dot.Style BeanConstructionStep s setVertexName vertexName style = style {Dot.vertexName} -defaultStepToText :: BeanConstructionStep -> Data.Text.Text+defaultStepToText :: IsString s => BeanConstructionStep -> s defaultStepToText =-  let p rep = Data.Text.pack do show rep+  let p rep = 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"+        BarePrimaryBean rep -> fromString $ p rep ++ "#bare"+        PrimaryBeanDeco rep index -> fromString $ p rep ++ "#deco#" ++ show index+        AggregateBean rep -> fromString $ p rep ++ "#agg"+        FinishedBean rep -> fromString $ p rep -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+-- dependencies, potentially returning some secondary aggregate 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.+-- 'Constructor' type. Those of the dependencies and aggregate beans are not. --+-- 'Constructor' doesn't have a 'Functor' instance. This is beause sometimes a+-- 'Constructor' may depend on the same type of bean it produces, but the+-- 'Functor' instance would only change the output type, leading to confusing+-- wiring errors.+-- -- 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@@ -1031,18 +1187,43 @@ -- | Create a 'Constructor' from an 'Args' value that returns a 'bean'. -- -- Usually, the 'Args' value will be created by 'wire'ing a constructor function.+--+-- >>> :{+-- data A = A+-- data B = B+-- makeB :: A -> B+-- makeB _ = B +-- c :: Constructor IO B+-- c = val_ $ wire $ makeB+-- :}+--  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+-- rightmost-innermost one are registered as aggregate beans (if they have -- 'Monoid' instances, otherwise 'val' won't compile).+--+-- >>> :{+-- data A = A+-- data B = B+-- makeB :: A -> (Sum Int, Any, B)+-- makeB _ = (Sum 0, Any False, B) +-- c :: Constructor IO B+-- c = val $ wire $ makeB+-- makeB' :: A -> (Sum Int, (Any, B))+-- makeB' _ = (Sum 0, (Any False, B))+-- c' :: Constructor IO B+-- c' = val $ wire $ makeB+-- :}+--  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. Likely not what you want.+-- val' :: forall bean m. (Applicative m, HasCallStack) => Args (Regs bean) -> Constructor m bean val' x = Constructor callStack $ fmap pure x @@ -1050,6 +1231,16 @@ -- effect that produces 'bean'. -- -- Usually, the 'Args' value will be created by 'wire'ing an effectul constructor function.+--+-- >>> :{+-- data A = A+-- data B = B+-- makeB :: A -> IO B+-- makeB _ = pure B +-- c :: Constructor IO B+-- c = eff_ $ wire $ makeB+-- :}+--  eff_ :: forall bean m. (Functor m, HasCallStack) => Args (m bean) -> Constructor m bean eff_ x = Constructor callStack $ fmap (fmap pure) x @@ -1059,8 +1250,22 @@  -- | 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+-- components except the rightmost-innermost one are registered as aggregate -- beans (if they have 'Monoid' instances, otherwise 'eff' won't compile).+--+-- >>> :{+-- data A = A+-- data B = B+-- makeB :: A -> IO (Sum Int, Any, B)+-- makeB _ = pure (Sum 0, Any False, B) +-- c :: Constructor IO B+-- c = eff $ wire $ makeB+-- makeB' :: A -> IO (Sum Int, (Any, B))+-- makeB' _ = pure (Sum 0, (Any False, B))+-- c' :: Constructor IO B+-- c' = eff $ wire $ makeB+-- :}+--  eff :: forall {nested} bean m. (Registrable nested bean, Monad m, HasCallStack) => Args (m nested) -> Constructor m bean eff x = withFrozenCallStack (eff' $ register x) @@ -1073,9 +1278,13 @@ 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))+runConstructor :: (Monad m) => +    BeanGetter ->+    Constructor m bean -> +      m (Beans, bean)+runConstructor getter (Constructor {_args}) = do+  -- regs <- _args & runArgs (Data.Foldable.asum (taste <$> bss))+  regs <- _args & runArgs (runBeanGetter getter)   pure (runRegs (getRegsReps _args) regs)  -- | Change the monad in which the 'Constructor'\'s effects take place.@@ -1124,32 +1333,32 @@ -- 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.+-- secondary \"aggregate\" beans that are not reflected in the 'Constructor' signature. -- Multiple constructors across different 'Recipe's can produce secondary beans of the -- same type. ----- Secondary beans are a bit special, in that:+-- Aggregate 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.+-- * The value that is \"seen"\ by a 'Constructor' that depends on an aggregate bean+--   is the aggregation of /all/ values produced for that bean in the 'Cauldron'. Therefore,+--   these beans must have 'Monoid' instances. ----- * 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.+-- * When calculating build plan order for a 'Cauldron', 'Constructor's that depend on a+--   aggregate bean come after /all/ of the 'Constructor's that produce that aggregate bean. ----- * Secondary beans can't be decorated.+-- * Aggregate beans can't be decorated. ----- * A bean type can't be primary and secondary at the same time. See 'DoubleDutyBeansError'.+-- * A bean type can't be primary and aggregate at the same time. See 'DoubleDutyBeansError'. ----- What are secondary beans useful for?+-- What are aggregate 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+-- The simplest way of registering aggregate 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:+-- of the tuple other than the rightmost component are considered aggregate beans: -- -- >>> :{ -- con :: Constructor Identity String@@ -1158,7 +1367,7 @@ -- effCon = eff $ pure $ pure @IO (Sum @Int, All False, "foo") -- :} ----- Example of how secondary bean values are accumulated:+-- Example of how aggregate bean values are aggregated: -- -- >>> :{ -- data U = U deriving Show@@ -1167,7 +1376,7 @@ -- 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+-- newtype W = W (Sum Int) deriving Show -- depends on the aggregate bean -- :} -- -- >>> :{@@ -1178,10 +1387,30 @@ --           recipe @V $ val $ wire makeV, --           recipe @W $ val $ wire W --         ]---   Identity beans <- either throwIO pure $ cook forbidDepCycles cauldron---   pure $ taste @W beans+--   Identity w <- cook @W forbidDepCycles cauldron & either throwIO pure+--   pure w -- :}--- Just (W (Sum {getSum = 8}))+-- W (Sum {getSum = 8})+--+-- Example of how aggregate beans can't also be primary beans:+--+-- >>> :{+-- data X = X deriving Show+-- makeX :: (Sum Int, X)+-- makeX = (Sum 1, X)+-- makeAgg :: Sum Int+-- makeAgg = Sum 7+-- :}+--+-- >>> :{+--   cook @X forbidDepCycles ([+--       recipe @X $ val $ wire makeX,+--       recipe @(Sum Int) $ val $ wire makeAgg+--       ] :: Cauldron IO) +--       & \case Left (DoubleDutyBeansError _) -> "Sum Int is aggregate and primary"; _ -> "oops"+-- :}+-- "Sum Int is aggregate and primary"+--  -- $setup -- >>> :set -XBlockArguments@@ -1190,5 +1419,6 @@ -- >>> import Data.Functor.Identity -- >>> import Data.Function ((&)) -- >>> import Data.Monoid--- >>> import Data.Either (either)+-- >>> import Data.Either (either, isLeft) -- >>> import Control.Exception (throwIO)+

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

@@ -0,0 +1,407 @@+{-# 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.Internal+  +where++import Cauldron.Beans (Beans, SomeMonoidTypeRep (..), fromDynList)+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+-- >>> import Cauldron.Beans (taste)

@@ -128,7 +128,7 @@         then Left $ DuplicateBeans beanDefinitions         else Right c --- | Because cauldron inject dependencies based on their types, a do-notation block which+-- | Because 'Cauldron's inject dependencies based on their types, a do-notation block which -- binds two or more values of the same type would be ambiguous. -- -- >>> :{

@@ -9,7 +9,6 @@ module Main (main) where  import Cauldron-import Data.Maybe (fromJust) import Test.Tasty import Test.Tasty.HUnit @@ -107,9 +106,9 @@ makeZDeco2 :: F -> Z -> (Initializer, Z) makeZDeco2 = \_ z -> (Initializer (putStrLn "Z deco init"), z) -coolWiring :: Fire IO -> Either RecipeError (IO Entrypoint)+coolWiring :: Fire IO -> Either CookingError (IO Result) coolWiring fire = do-  fmap (fmap (fromJust . taste @Entrypoint)) $ cook fire cauldron+  cook fire cauldron  cauldron :: Cauldron IO cauldron :: Cauldron IO =@@ -139,10 +138,10 @@                   val $ wire makeZDeco2                 ]           },-      recipe @Entrypoint $ val $ wire Entrypoint+      recipe @Result $ val $ wire Result     ] -data Entrypoint = Entrypoint Initializer Inspector Z+data Result = Result Initializer Inspector Z  tests :: TestTree tests =

@@ -15,10 +15,11 @@ import Data.Dynamic import Data.Function ((&)) import Data.Proxy-import Data.Text (Text) import Data.Typeable (typeRep) import Test.Tasty import Test.Tasty.HUnit++type Text = String  data A = A 

@@ -165,7 +165,7 @@           Right _ -> assertFailure "Builder should have failed with duplicate beans error",       testCase "should fail cycle wiring" do         Data.Foldable.for_ @[] [("forbid", forbidDepCycles), ("selfdeps", allowSelfDeps)] \(name, fire) ->-          case cook fire cauldron of+          case cook @(Serializer Foo) fire cauldron of             Left (DependencyCycleError _) -> pure ()             Left _ -> assertFailure $ "Unexpected error when wiring" ++ name             Right _ -> assertFailure $ "Unexpected success when wiring" ++ name,@@ -175,25 +175,22 @@             ("someConsume", cauldronAccums2, Acc 10)           ]           \(name, c, expected) ->-            case cook allowDepCycles c of+            case cook @Acc 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+              Right (Identity acc) ->                     assertEqual "experted result" expected acc,-      testCase "problematic wiring with accums" do+      testCase "wiring with accums" do         Data.Foldable.for_ @[]-          [ ("selfacc", cauldronAccumsOops1),-            ("indirectacc", cauldronAccumsOops2)+          [ ("aggcyle", cauldronAccumsOops1),+            ("indirectagg", cauldronAccumsOops2)           ]           \(name, c) ->-            case cook allowDepCycles c of-              Left (DependencyCycleError _) -> pure ()+            case cook @(Serializer Foo) allowDepCycles c of+              Left (DependencyCycleError _) -> assertFailure $ "We should be able to wire cycles with accs"               Left _ -> assertFailure $ "Unexpected error when wiring" ++ name-              Right _ -> assertFailure $ "Unexpected success when wiring" ++ name+              Right _ -> pure ()     ]   where     makeBasicTest :: Cauldron Identity -> IO ()@@ -202,10 +199,7 @@         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+        Right (Identity (Serializer {runSerializer})) -> do               let value = FooToBar (BarToFoo (FooToBar (BarToBaz EndBaz)))               assertEqual "experted result" ".FooToBar.BarToFoo.FooToBar.BarToBar.EndBaz" (runSerializer value) 

@@ -10,10 +10,11 @@ import Cauldron.Managed import Data.IORef import Data.Maybe (fromJust)-import Data.Text (Text) import Test.Tasty import Test.Tasty.HUnit +type Text = String+ newtype Logger m = Logger   { logMessage :: Text -> m ()   }@@ -95,7 +96,7 @@         case cook allowSelfDeps (managedCauldron ref) of           Left _ -> assertFailure "could not wire"           Right beansAction -> with beansAction \boiledBeans -> do-            let (Logger {logMessage}, (Weird {anotherWeirdOp}) :: Weird IO) = fromJust . taste $ boiledBeans+            let (Logger {logMessage}, (Weird {anotherWeirdOp}) :: Weird IO) = boiledBeans             logMessage "foo"             anotherWeirdOp             pure ()

@@ -8,28 +8,23 @@  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 import Data.Map (Map) 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+import Data.Foldable qualified +type Text = String+ type M = WriterT [Text] IO  -- | And initialization action which some beans might register.@@ -137,13 +132,15 @@     & insert @(Logger M)       (eff $ wire \(_ :: Repository M) -> makeLogger) -cauldronNonEmpty :: NonEmpty (Cauldron M)-cauldronNonEmpty =-  Data.List.NonEmpty.fromList-    [ fromRecipeList-        [ recipe @(Logger M) $ eff $ pure makeLogger,-          recipe @(Weird M) $ eff $ wire makeWeird-        ],+cauldronX1 :: Cauldron M+cauldronX1 =+    fromRecipeList+        [ recipe @(Logger M) $ eff $ pure makeLogger, +          recipe @(Weird M) $ eff $ wire makeWeird -- overwritten+        ]++cauldronX2 :: Cauldron M+cauldronX2 =       fromRecipeList         [ recipe @(Repository M) $ eff $ do             action <- wire makeRepository@@ -159,48 +156,21 @@                       val $ wire (weirdDeco "outer")                     ]               },-          recipe @(Initializer, Repository M, Weird M) $ val_ do wire (,,)+          recipe @Result $ val_ do wire Result         ]-    ] -cauldronNonEmptyWrongOrder :: NonEmpty (Cauldron M)-cauldronNonEmptyWrongOrder = do-  Data.List.NonEmpty.fromList-    [ fromRecipeList-        [ recipe @(Weird M) $ eff $ wire makeWeird-        ],-      fromRecipeList-        [ recipe @(Logger M) $ eff $ pure makeLogger-        ]-    ]+data Result = Result Initializer (Repository M) (Weird M) +cauldronX :: Cauldron M+cauldronX = cauldronX1 <> cauldronX2++ cauldronLonely :: Cauldron M 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@@ -210,7 +180,7 @@           Left _ -> assertFailure "could not wire"           Right beansAction -> runWriterT do             boiledBeans <- beansAction-            let (Initializer {runInitializer}, Repository {findById, store}) = fromJust . taste $ boiledBeans+            let (Initializer {runInitializer}, Repository {findById, store}) = boiledBeans             runInitializer             store 1 "foo"             _ <- findById 1@@ -225,15 +195,12 @@           ]           traces,       testCase "value sequential" do-        ((), traces) <- case cookNonEmpty' cauldronNonEmpty of+        ((), traces) <- case cook @Result allowSelfDeps cauldronX of           Left _ -> assertFailure "could not wire"           Right beansAction -> do             runWriterT do-              _ Data.List.NonEmpty.:| [boiledBeans] <- beansAction-              let ( Initializer {runInitializer},-                    Repository {findById, store},-                    Weird {anotherWeirdOp}-                    ) = fromJust . taste $ boiledBeans+              boiledBeans <- beansAction+              let Result (Initializer {runInitializer}) (Repository {findById, store}) (Weird {anotherWeirdOp}) = boiledBeans               runInitializer               store 1 "foo"               _ <- findById 1@@ -241,8 +208,10 @@               pure ()         assertEqual           "traces"-          [ "logger constructor",-            "weird constructor",+          [ +            -- "weird constructor", -- not happens, because overwritten+            -- the order of the traces here is a bit too overspecified. several orders could be valid.+            "logger constructor",             "self-invoking weird constructor",             "logger init",             "repo init invoking logger",@@ -258,37 +227,66 @@             "weirdOp 2"           ]           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 "value sequential - parents can't see beans in children" do-        case cookNonEmpty' cauldronNonEmptyWrongOrder of-          Left (MissingDependenciesError _) -> pure ()-          Left _ -> assertFailure "Unexpected error"-          Right _ -> assertFailure "parent cauldron sees bean in child cauldron",-      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 branches"-                (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",+        --case getDependencyGraph cauldronNonEmpty of+        --  dg2  -> do+        --    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 ()+          ,+      testCase "value nested" do+        ((), traces) <- case (+              do constructorX2 <- nest allowSelfDeps cauldronX2+                 cook @Result allowSelfDeps (cauldronX1 & Cauldron.insert @Result constructorX2)) of+          Left _ -> assertFailure "could not wire"+          Right beansAction -> do+            runWriterT do+              boiledBeans <- beansAction+              let Result (Initializer {runInitializer}) (Repository {findById, store}) (Weird {anotherWeirdOp}) = boiledBeans+              runInitializer+              store 1 "foo"+              _ <- findById 1+              anotherWeirdOp+              pure ()+        assertEqual+          "traces"+          [ +            -- the order of the traces here is a bit too overspecified. several orders could be valid.+            "logger constructor",+            "self-invoking weird constructor",+            "weird constructor", -- note that this is present. Overwritten by nested, but still built+            -- The absence of the logger init is because we are only getting the aggregate beans from the nested.+            -- "logger init",+            "repo init invoking logger",+            "store",+            "findById",+            -- the deco is applied! The outer the deco, the earliest is invoked.+            "deco for anotherWeirdOp outer",+            "deco for anotherWeirdOp inner",+            "another weirdOp 2",+            "deco for weirdOp outer",+            "deco for weirdOp inner",+            -- note that the self-invocation used the method from 'makeSelfInvokingWeird'+            "weirdOp 2"+          ]+          traces+        --case getDependencyGraph cauldronNonEmpty of+        --  dg2  -> do+        --    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 ()+          ,       testCase "lonely beans get built" do-        (_, _) <- case cook' cauldronLonely of+        (_, _) <- case cook allowSelfDeps cauldronLonely of           Left _ -> assertFailure "could not wire"           Right beansAction -> runWriterT do             boiledBeans <- beansAction-            let Lonely {soLonely} = fromJust . taste $ boiledBeans+            let Lonely {soLonely} = boiledBeans             soLonely             pure ()         pure (),@@ -305,14 +303,14 @@         pure (),       testCase "cauldron with cycle" do         case cook' cauldronWithCycle of-          Left (DependencyCycleError _) -> pure ()+          Left (DependencyCycleError (DependencyCycle vs)) -> +              -- Why not a cycle of length 3? Because there also are bare versions for each bean.+              assertEqual "cycle of the expected length" 4 (Data.Foldable.length vs)           _ -> assertFailure "dependency cycle not detected"         pure ()     ]   where     cook' = cook allowSelfDeps-    cookNonEmpty' = cookNonEmpty . fmap (allowSelfDeps,)-    cookTree' = cookTree . fmap (allowSelfDeps,)  main :: IO () main = defaultMain tests