diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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`. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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). diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/cauldron.cabal b/cauldron.cabal --- a/cauldron.cabal +++ b/cauldron.cabal @@ -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 diff --git a/lib-graph/Cauldron/Graph.hs b/lib-graph/Cauldron/Graph.hs new file mode 100644 --- /dev/null +++ b/lib-graph/Cauldron/Graph.hs @@ -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 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 ] diff --git a/lib-graph/Cauldron/Graph/Algorithm.hs b/lib-graph/Cauldron/Graph/Algorithm.hs new file mode 100644 --- /dev/null +++ b/lib-graph/Cauldron/Graph/Algorithm.hs @@ -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) diff --git a/lib-graph/Cauldron/Graph/Export.hs b/lib-graph/Cauldron/Graph/Export.hs new file mode 100644 --- /dev/null +++ b/lib-graph/Cauldron/Graph/Export.hs @@ -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 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) diff --git a/lib-graph/Cauldron/Graph/Export/Dot.hs b/lib-graph/Cauldron/Graph/Export/Dot.hs new file mode 100644 --- /dev/null +++ b/lib-graph/Cauldron/Graph/Export/Dot.hs @@ -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 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 diff --git a/lib/Cauldron.hs b/lib/Cauldron.hs --- a/lib/Cauldron.hs +++ b/lib/Cauldron.hs @@ -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) + diff --git a/lib/Cauldron/Args.hs b/lib/Cauldron/Args.hs --- a/lib/Cauldron/Args.hs +++ b/lib/Cauldron/Args.hs @@ -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 diff --git a/lib/Cauldron/Args/Internal.hs b/lib/Cauldron/Args/Internal.hs new file mode 100644 --- /dev/null +++ b/lib/Cauldron/Args/Internal.hs @@ -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) diff --git a/lib/Cauldron/Builder.hs b/lib/Cauldron/Builder.hs --- a/lib/Cauldron/Builder.hs +++ b/lib/Cauldron/Builder.hs @@ -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. -- -- >>> :{ diff --git a/test/appTests.hs b/test/appTests.hs --- a/test/appTests.hs +++ b/test/appTests.hs @@ -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 = diff --git a/test/argsTests.hs b/test/argsTests.hs --- a/test/argsTests.hs +++ b/test/argsTests.hs @@ -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 diff --git a/test/codecTests.hs b/test/codecTests.hs --- a/test/codecTests.hs +++ b/test/codecTests.hs @@ -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) diff --git a/test/managedTests.hs b/test/managedTests.hs --- a/test/managedTests.hs +++ b/test/managedTests.hs @@ -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 () diff --git a/test/tests.hs b/test/tests.hs --- a/test/tests.hs +++ b/test/tests.hs @@ -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