cauldron 0.7.0.0 → 0.8.0.0

raw patch · 16 files changed

+661/−523 lines, 16 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +13/−0
• README.md +10/−3
• app/Main.hs +2/−2
• cauldron.cabal +1/−1
• lib-graph/Cauldron/Graph.hs +283/−225
• lib-graph/Cauldron/Graph/Algorithm.hs +31/−29
• lib-graph/Cauldron/Graph/Export.hs +45/−31
• lib-graph/Cauldron/Graph/Export/Dot.hs +54/−43
• lib/Cauldron.hs +151/−124
• lib/Cauldron/Args.hs +1/−0
• lib/Cauldron/Args/Internal.hs +5/−3
• lib/Cauldron/Managed.hs +5/−0
• test/argsTests.hs +0/−1
• test/codecTests.hs +3/−3
• test/managedTests.hs +0/−1
• test/tests.hs +57/−57

@@ -1,5 +1,18 @@ # Revision history for cauldron +## 0.8.0.0++* doc and test changes.++* re-export `arg` from Cauldron.++* breaking change: `MissingDependenciesError` now includes all the missing dependencies.++* breaking change: `DoubleDutyBeansError` is now a NonEmpty instead of a Map.++* Managed now has a MonadFail instance, like the one from the+  [managed](https://hackage.haskell.org/package/managed) library.+ ## 0.7.0.0  * Remove dependency on algebraic-graphs, copying those parts of the code that we used.

@@ -118,7 +118,7 @@  See [this example application](/app/Main.hs) with dummy components. -For a slightly more realistic example, see [here](https://github.com/danidiaz/comments-project/blob/8206c50b9af2097e2246cec0992d489029b84686/comments/lib/Comments/Main.hs#L36).+For a slightly more realistic example, see [here](https://github.com/danidiaz/comments-project/blob/f16fb09c90a851054e8e97a82b38a563ff0eea18/comments/app/Main.hs#L37).  # Similarities with the [Java Spring framework IoC container](https://docs.spring.io/spring-framework/reference/core/beans.html) @@ -165,6 +165,13 @@  - [Do we need effects to get abstraction? (2019)](https://hachyderm.io/@DiazCarrete/114712223474781312) -# Acknowledgement+- [Dependency Injection Principles, Practices, and Patterns](https://www.goodreads.com/book/show/44416307-dependency-injection-principles-practices-and-patterns). This is a good book on the general principles of DI.  -This package contains vendored code from Andrey Mokhov's [algebraic-graphs](https://hackage.haskell.org/package/algebraic-graphs) (most of the `cauldron:graph` library).+# Acknowledgements++This package contains vendored code from Grabriella Gonzalez's+[managed](https://hackage.haskell.org/package/managed) library.++Also vendored code from Andrey Mokhov's+[algebraic-graphs](https://hackage.haskell.org/package/algebraic-graphs) (most+of the `cauldron:graph` library).

@@ -96,7 +96,7 @@ makeA = A  -- 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)@@ -125,7 +125,7 @@ -- | A decorator. -- -- Decorators are basically normal constructors, only that they take--- the bean they return as a parameter. +-- 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

@@ -1,6 +1,6 @@ cabal-version:      3.4 name:               cauldron-version:            0.7.0.0+version:            0.8.0.0 synopsis:           Dependency injection library description:        Dependency injection library that wires things at runtime. license:            BSD-3-Clause

@@ -1,4 +1,7 @@ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module     : Algebra.Graph.AdjacencyMap -- Copyright  : (c) Andrey Mokhov 2016-2024@@ -16,145 +19,179 @@ -- 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,+module Cauldron.Graph+  ( -- * Data structure+    AdjacencyMap,+    adjacencyMap,      -- * Basic graph construction primitives-    empty, vertex, edge, overlay, connect, vertices, edges, overlays, connects,+    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,+    isEmpty,+    hasVertex,+    hasEdge,+    vertexCount,+    edgeCount,+    vertexList,+    edgeList,+    adjacencyList,+    vertexSet,+    edgeSet,+    preSet,+    postSet,      -- * Standard families of graphs-    path, circuit, clique, biclique, star, stars, fromAdjacencySets, tree,+    path,+    circuit,+    clique,+    biclique,+    star,+    stars,+    fromAdjacencySets,+    tree,     forest,      -- * Graph transformation-    removeVertex, removeEdge, replaceVertex, mergeVertices, transpose, gmap,-    induce, induceJust,+    removeVertex,+    removeEdge,+    replaceVertex,+    mergeVertices,+    transpose,+    gmap,+    induce,+    induceJust,      -- * Graph composition-    compose, box,+    compose,+    box,      -- * Relational operations-    closure, reflexiveClosure, symmetricClosure, transitiveClosure,+    closure,+    reflexiveClosure,+    symmetricClosure,+    transitiveClosure,      -- * Miscellaneous-    consistent-    ) where+    consistent,+  )+where  import Data.List ((\\)) import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe qualified as Maybe import Data.Monoid import Data.Set (Set)+import Data.Set qualified as Set import Data.String-import Data.Tree hiding (edges)+import Data.Tree (Tree(..), Forest) 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+-- | 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.     --     -- @@@ -163,53 +200,64 @@     -- 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)+    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) => 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)+  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+  fromInteger = vertex . fromInteger+  (+) = overlay+  (*) = connect+  signum = const empty+  abs = id+  negate = id -instance IsString a => IsString (AdjacencyMap a) where-    fromString = vertex . fromString+instance (IsString a) => IsString (AdjacencyMap a) where+  fromString = vertex . fromString  -- | Defined via 'overlay'.-instance Ord a => Semigroup (AdjacencyMap a) where-    (<>) = overlay+instance (Ord a) => Semigroup (AdjacencyMap a) where+  (<>) = overlay  -- | Defined via 'overlay' and 'empty'.-instance Ord a => Monoid (AdjacencyMap a) where-    mempty = empty+instance (Ord a) => Monoid (AdjacencyMap a) where+  mempty = empty  -- | Construct the /empty graph/. --@@ -244,9 +292,10 @@ -- '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)]+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'.@@ -262,7 +311,7 @@ -- 'vertexCount' (overlay 1 2) == 2 -- 'edgeCount'   (overlay 1 2) == 0 -- @-overlay :: Ord a => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a+overlay :: (Ord a) => AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a overlay (AM x) (AM y) = AM $ Map.unionWith Set.union x y {-# NOINLINE [1] overlay #-} @@ -284,9 +333,12 @@ -- '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) ]+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.@@ -301,8 +353,8 @@ -- 'vertexCount' . vertices == 'length' . 'Data.List.nub' -- 'vertexSet'   . vertices == Set.'Set.fromList' -- @-vertices :: Ord a => [a] -> AdjacencyMap a-vertices = AM . Map.fromList . map (, Set.empty)+vertices :: (Ord a) => [a] -> AdjacencyMap a+vertices = AM . Map.fromList . map (,Set.empty) {-# NOINLINE [1] vertices #-}  -- | Construct the graph from a list of edges.@@ -315,7 +367,7 @@ -- 'edgeCount' . edges == 'length' . 'Data.List.nub' -- 'edgeList' . edges  == 'Data.List.nub' . 'Data.List.sort' -- @-edges :: Ord a => [(a, a)] -> AdjacencyMap a+edges :: (Ord a) => [(a, a)] -> AdjacencyMap a edges = fromAdjacencySets . map (fmap Set.singleton)  -- | Overlay a given list of graphs.@@ -328,7 +380,7 @@ -- overlays           == 'foldr' 'overlay' 'empty' -- 'isEmpty' . overlays == 'all' 'isEmpty' -- @-overlays :: Ord a => [AdjacencyMap a] -> AdjacencyMap a+overlays :: (Ord a) => [AdjacencyMap a] -> AdjacencyMap a overlays = AM . Map.unionsWith Set.union . map adjacencyMap {-# NOINLINE overlays #-} @@ -342,7 +394,7 @@ -- connects           == 'foldr' 'connect' 'empty' -- 'isEmpty' . connects == 'all' 'isEmpty' -- @-connects :: Ord a => [AdjacencyMap a] -> AdjacencyMap a+connects :: (Ord a) => [AdjacencyMap a] -> AdjacencyMap a connects = foldr connect empty {-# NOINLINE connects #-} @@ -358,7 +410,7 @@ -- isSubgraphOf ('path' xs)     ('circuit' xs)  ==  True -- isSubgraphOf x y                         ==> x <= y -- @-isSubgraphOf :: Ord a => AdjacencyMap a -> AdjacencyMap a -> Bool+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.@@ -382,7 +434,7 @@ -- hasVertex x ('vertex' y)       == (x == y) -- hasVertex x . 'removeVertex' x == 'const' False -- @-hasVertex :: Ord a => a -> AdjacencyMap a -> Bool+hasVertex :: (Ord a) => a -> AdjacencyMap a -> Bool hasVertex x = Map.member x . adjacencyMap  -- | Check if a graph contains a given edge.@@ -395,10 +447,10 @@ -- hasEdge x y . 'removeEdge' x y == 'const' False -- hasEdge x y                  == 'elem' (x,y) . 'edgeList' -- @-hasEdge :: Ord a => a -> a -> AdjacencyMap a -> Bool+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+  Nothing -> False+  Just vs -> Set.member v vs  -- | The number of vertices in a graph. -- Complexity: /O(1)/ time.@@ -447,7 +499,7 @@ -- 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 ]+edgeList (AM m) = [(x, y) | (x, ys) <- Map.toAscList m, y <- Set.toAscList ys] {-# INLINE edgeList #-}  -- | The set of vertices of a given graph.@@ -470,7 +522,7 @@ -- edgeSet ('edge' x y) == Set.'Set.singleton' (x,y) -- edgeSet . 'edges'    == Set.'Set.fromList' -- @-edgeSet :: Eq a => AdjacencyMap a -> Set (a, a)+edgeSet :: (Eq a) => AdjacencyMap a -> Set (a, a) edgeSet = Set.fromAscList . edgeList  -- | The sorted /adjacency list/ of a graph.@@ -495,8 +547,8 @@ -- 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+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 @@ -509,7 +561,7 @@ -- 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 :: (Ord a) => a -> AdjacencyMap a -> Set a postSet x = Map.findWithDefault Set.empty x . adjacencyMap  -- | The /path/ on a list of vertices.@@ -521,10 +573,11 @@ -- 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)+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.@@ -535,9 +588,9 @@ -- 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]+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.@@ -550,11 +603,11 @@ -- clique (xs '++' ys) == 'connect' (clique xs) (clique ys) -- clique . 'reverse'  == 'transpose' . clique -- @-clique :: Ord a => [a] -> AdjacencyMap a+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)+    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.@@ -567,7 +620,7 @@ -- 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 :: (Ord a) => [a] -> [a] -> AdjacencyMap a biclique xs ys = AM $ Map.fromSet adjacent (x `Set.union` y)   where     x = Set.fromList xs@@ -575,6 +628,7 @@     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. --@@ -584,7 +638,7 @@ -- 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 :: (Ord a) => a -> [a] -> AdjacencyMap a star x [] = vertex x star x ys = connect (vertex x) (vertices ys) {-# INLINE star #-}@@ -603,7 +657,7 @@ -- stars . 'adjacencyList'         == id -- 'overlay' (stars xs) (stars ys) == stars (xs '++' ys) -- @-stars :: Ord a => [(a, [a])] -> AdjacencyMap a+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'.@@ -616,7 +670,7 @@ -- fromAdjacencySets . 'map' ('fmap' Set.'Set.fromList')           == 'stars' -- 'overlay' (fromAdjacencySets xs) (fromAdjacencySets ys) == fromAdjacencySets (xs '++' ys) -- @-fromAdjacencySets :: Ord a => [(a, Set a)] -> AdjacencyMap a+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@@ -631,9 +685,10 @@ -- 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 :: (Ord a) => Tree a -> AdjacencyMap a tree (Node x []) = vertex x-tree (Node x f ) = star x (map rootLabel f)+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.@@ -645,7 +700,7 @@ -- 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 :: (Ord a) => Forest a -> AdjacencyMap a forest = overlays . map tree  -- | Remove a vertex from a given graph.@@ -658,7 +713,7 @@ -- removeVertex 1 ('edge' 1 2)       == 'vertex' 2 -- removeVertex x . removeVertex x == removeVertex x -- @-removeVertex :: Ord a => a -> AdjacencyMap a -> AdjacencyMap a+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.@@ -671,7 +726,7 @@ -- 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 :: (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@@ -683,7 +738,7 @@ -- replaceVertex x y ('vertex' x) == 'vertex' y -- replaceVertex x y            == 'mergeVertices' (== x) y -- @-replaceVertex :: Ord a => a -> a -> AdjacencyMap a -> AdjacencyMap a+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.@@ -696,7 +751,7 @@ -- 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 :: (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.@@ -709,25 +764,23 @@ -- transpose . transpose == id -- 'edgeList' . transpose  == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . 'edgeList' -- @-transpose :: Ord a => AdjacencyMap a -> AdjacencyMap a+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)+    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/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)- #-}+"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@@ -768,11 +821,11 @@ -- 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 :: (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+  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@@ -794,10 +847,11 @@ -- 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) ]+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@@ -830,12 +884,14 @@ 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)+    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.@@ -851,7 +907,7 @@ -- closure . closure       == closure -- 'postSet' x (closure y)   == Set.'Set.fromList' ('Algebra.Graph.ToGraph.reachable' y x) -- @-closure :: Ord a => AdjacencyMap a -> AdjacencyMap a+closure :: (Ord a) => AdjacencyMap a -> AdjacencyMap a closure = reflexiveClosure . transitiveClosure  -- | Compute the /reflexive closure/ of a graph by adding a self-loop to every@@ -865,7 +921,7 @@ -- reflexiveClosure ('edge' x y)         == 'edges' [(x,x), (x,y), (y,y)] -- reflexiveClosure . reflexiveClosure == reflexiveClosure -- @-reflexiveClosure :: Ord a => AdjacencyMap a -> AdjacencyMap a+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@@ -879,7 +935,7 @@ -- symmetricClosure x                  == 'overlay' x ('transpose' x) -- symmetricClosure . symmetricClosure == symmetricClosure -- @-symmetricClosure :: Ord a => AdjacencyMap a -> AdjacencyMap a+symmetricClosure :: (Ord a) => AdjacencyMap a -> AdjacencyMap a symmetricClosure m = overlay m (transpose m)  -- | Compute the /transitive closure/ of a graph.@@ -892,10 +948,10 @@ -- transitiveClosure ('path' $ 'Data.List.nub' xs)     == 'clique' ('Data.List.nub' xs) -- transitiveClosure . transitiveClosure == transitiveClosure -- @-transitiveClosure :: Ord a => AdjacencyMap a -> AdjacencyMap a+transitiveClosure :: (Ord a) => AdjacencyMap a -> AdjacencyMap a transitiveClosure old-    | old == new = old-    | otherwise  = transitiveClosure new+  | old == new = old+  | otherwise = transitiveClosure new   where     new = overlay old (old `compose` old) @@ -912,10 +968,12 @@ -- consistent ('edges' xs)    == True -- consistent ('stars' xs)    == True -- @-consistent :: Ord a => AdjacencyMap a -> Bool+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 ]+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]

@@ -1,51 +1,53 @@-{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-}-module Cauldron.Graph.Algorithm (-    reverseTopSort-    ) where+{-# LANGUAGE ViewPatterns #-} +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 ((&))+import Data.Graph qualified+import Data.List.NonEmpty+import Data.Map.Strict qualified+import Data.Sequence qualified+import Data.Set qualified -reverseTopSort :: Ord a => AdjacencyMap a -> Either (NonEmpty a) [a] +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]+  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 :: (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 = +    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+        Just (child : _) -> child     go current visited cycleAcc =-        let child = firstChildOf current-         in if child `Data.Set.member` visited+      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

@@ -1,5 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module     : Algebra.Graph.Export -- Copyright  : (c) Andrey Mokhov 2016-2024@@ -13,24 +17,30 @@ -- -- 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,+module Cauldron.Graph.Export+  ( -- * Constructing and exporting documents+    Doc,+    isEmpty,+    literal,+    render,      -- * Common combinators for text documents-    (<+>), brackets, doubleQuotes, indent, unlines,+    (<+>),+    brackets,+    doubleQuotes,+    indent,+    unlines,      -- * Generic graph export-    export-    ) where+    export,+  )+where +import Cauldron.Graph (AdjacencyMap, edgeList, vertexList) 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@@ -55,21 +65,23 @@ newtype Doc s = Doc [s] deriving (Monoid, Semigroup)  instance (Monoid s, Show s) => Show (Doc s) where-    show = show . render+  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+  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)+  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+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@@@ -104,7 +116,7 @@ -- render 'mempty'                         == 'mempty' -- render . 'literal'                      == 'id' -- @-render :: Monoid s => Doc s -> s+render :: (Monoid s) => Doc s -> s render (Doc x) = fold x  -- | Concatenate two documents, separated by a single space, unless one of the@@ -116,10 +128,11 @@ -- 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+(<+>) :: (IsString s) => Doc s -> Doc s -> Doc s+x <+> y+  | isEmpty x = y+  | isEmpty y = x+  | otherwise = x <> " " <> y  infixl 7 <+> @@ -129,7 +142,7 @@ -- brackets "i"    == "[i]" -- brackets 'mempty' == "[]" -- @-brackets :: IsString s => Doc s -> Doc s+brackets :: (IsString s) => Doc s -> Doc s brackets x = "[" <> x <> "]"  -- | Wrap a document into double quotes.@@ -138,7 +151,7 @@ -- doubleQuotes "\/path\/with spaces"   == "\\"\/path\/with spaces\\"" -- doubleQuotes (doubleQuotes 'mempty') == "\\"\\"\\"\\"" -- @-doubleQuotes :: IsString s => Doc s -> Doc s+doubleQuotes :: (IsString s) => Doc s -> Doc s doubleQuotes x = "\"" <> x <> "\""  -- | Prepend a given number of spaces to a document.@@ -147,7 +160,7 @@ -- indent 0        == 'id' -- indent 1 'mempty' == " " -- @-indent :: IsString s => Int -> Doc s -> Doc s+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.@@ -157,11 +170,12 @@ -- 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+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)@.@@ -183,5 +197,5 @@ 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)+    vDoc = mconcat $ map v (vertexList adjMap)+    eDoc = mconcat $ map (uncurry e) (edgeList adjMap)

@@ -1,5 +1,10 @@-{-# LANGUAGE OverloadedStrings, RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+ -----------------------------------------------------------------------------++-----------------------------------------------------------------------------+ -- | -- Module     : Algebra.Graph.Export.Dot -- Copyright  : (c) Andrey Mokhov 2016-2024@@ -12,22 +17,26 @@ -- 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,+module Cauldron.Graph.Export.Dot+  ( -- * Graph attributes and style+    Attribute (..),+    Quoting (..),+    Style (..),+    defaultStyle,+    defaultStyleViaShow,      -- * Export functions-    export-    ) where+    export,+  )+where +import Cauldron.Graph+import Cauldron.Graph.Export hiding (export)+import Cauldron.Graph.Export qualified as E 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.@@ -35,6 +44,7 @@  -- 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@@ -46,29 +56,29 @@ -- '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.-    }+  { -- | Name of the graph.+    graphName :: s,+    -- | Preamble (a list of lines) is added at the beginning of the DOT file body.+    preamble :: [s],+    -- | Graph style, e.g. @["bgcolor" := "azure"]@.+    graphAttributes :: [Attribute s],+    -- | Default vertex style, e.g. @["shape" := "diamond"]@.+    defaultVertexAttributes :: [Attribute s],+    -- | Default edge style, e.g. @["style" := "dashed"]@.+    defaultEdgeAttributes :: [Attribute s],+    -- | Compute a vertex name.+    vertexName :: a -> s,+    -- | Attributes of a specific vertex.+    vertexAttributes :: a -> [Attribute s],+    -- | Attributes of a specific edge.+    edgeAttributes :: a -> a -> [Attribute s],+    -- | The quoting style used for attributes.+    attributeQuoting :: Quoting+  }  -- | 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 :: (Monoid s) => (a -> s) -> Style a s defaultStyle v = Style mempty [] [] [] [] v (const []) (\_ _ -> []) DoubleQuotes  -- | Default style for exporting graphs with 'Show'-able vertices. The@@ -120,26 +130,27 @@ 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"+    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)+    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 :: (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+      DoubleQuotes -> doubleQuotes+      NoQuotes -> id

@@ -3,13 +3,13 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# 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@@ -42,6 +42,15 @@ -- makeC = \_ _ -> pure C -- :} --+-- The basic idea is to fill up the 'Cauldron' with 'recipe's. 'Recipe's are+-- built by 'wire'ing the arguments of a constructor function, and then using+-- functions like 'val' or 'eff' depending on whether the constructor is+-- effectful or not. More sophisticated 'Recipe's can also have decorators.+--+-- The we 'cook' the 'Cauldron' passing as a type argument the type of the bean+-- that we want to extract, along with a 'Fire' argument that regulates what+-- dependency cycles are allowed (if allowed at all).+-- -- >>> :{ -- do --   let cauldron :: Cauldron IO@@ -54,6 +63,11 @@ --   action -- :} -- C+--+-- __Note__: It's better to avoid having beans whose types are functions or+-- tuples, because those types are given special treatment. See the docs for+-- 'wire', 'val', and 'eff'.+-- module Cauldron   ( -- * Filling the cauldron     Cauldron,@@ -89,6 +103,8 @@     -- * Constructors     -- $constructors     Constructor,+    arg,+    wire,     val_,     val,     val',@@ -97,7 +113,6 @@     eff,     ioEff,     eff',-    wire,     getConstructorArgs,     getConstructorCallStack,     hoistConstructor,@@ -119,7 +134,7 @@     -- ** When things go wrong     CookingError (..),     MissingDependencies (..),-    DoubleDutyBeans (..),+    DoubleDutyBean (..),     DependencyCycle (..),     prettyCookingError,     prettyCookingErrorLines,@@ -141,14 +156,15 @@   ) where +import Cauldron.Args+import Cauldron.Args.Internal (Args (..))+import Cauldron.Beans (SomeMonoidTypeRep (..))+import Cauldron.Beans qualified 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.Applicative ((<|>)) import Control.Exception (Exception (..)) import Control.Monad.Fix import Control.Monad.IO.Class@@ -170,15 +186,14 @@ import Data.Sequence qualified import Data.Set (Set) import Data.Set qualified as Set+import Data.String (IsString (..)) 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 ((<|>))+import Type.Reflection qualified  -- | A map of bean recipes, indexed by the 'TypeRep' of the bean each recipe -- ultimately produces. Only one recipe is allowed for each bean type.@@ -341,6 +356,8 @@ -- -- The order of the decorators in the sequence is the order in which they modify -- the underlying bean. First decorator wraps first, last decorator wraps last.+-- Think of it as there being an implicit 'Data.Function.&' between the bean and the+-- subsequent decorators, and between the decorators themselves. -- -- >>> :{ -- newtype Foo = Foo { sayFoo :: IO () }@@ -364,7 +381,7 @@ --               ] --           } --         ]---   action <- cook @Foo forbidDepCycles cauldron & either throwIO pure +--   action <- cook @Foo forbidDepCycles cauldron & either throwIO pure --   Foo {sayFoo} <- action --   sayFoo -- :}@@ -377,7 +394,17 @@  -- $constructors ----- Bean-producing and bean-decorating functions need to be coaxed into 'Constructor's in order to be used in 'Cauldron's.+-- Bean-producing and bean-decorating functions need to be coaxed into+-- 'Constructor's in order to be used in 'Cauldron's.+-- +-- First we fill the arguments of the function in an 'Args' context, either one+-- by one using 'arg's and 'Applicative' operators, or all in a single swoop,+-- using 'wire'.+--+-- Then, depending on whether the function produces the desired bean directly,+-- or through an effect, we use functions like 'val', 'val_', 'eff' or 'eff_' on+-- the 'Args' value.+--  data ConstructorReps where   ConstructorReps ::@@ -438,7 +465,7 @@   { shouldEnforceDependency :: (BeanConstructionStep, BeanConstructionStep) -> Bool,     followPlanCauldron ::       Cauldron m ->-      BeanGetter -> +      BeanGetter ->       Beans ->       Plan ->       m Beans@@ -459,7 +486,7 @@ -- >>> :{ --   cook @A forbidDepCycles ([ --       recipe @A $ val $ wire loopyA---       ] :: Cauldron IO) +--       ] :: Cauldron IO) --       & \case Left (DependencyCycleError _) -> "self dep is forbidden"; _ -> "oops" -- :} -- "self dep is forbidden"@@ -498,7 +525,7 @@ -- >>> :{ --   cook @A allowSelfDeps ([ --       recipe @A $ val $ wire loopyA---       ] :: Cauldron IO) +--       ] :: Cauldron IO) --       & \case Left (DependencyCycleError _) -> "oops"; _ -> "self dep is ok" -- :} -- "self dep is ok"@@ -516,7 +543,7 @@ --   cook @U allowSelfDeps ([ --       recipe @U $ val $ wire loopyU, --       recipe @V $ val $ wire loopyV---       ] :: Cauldron IO) +--       ] :: Cauldron IO) --       & \case Left (DependencyCycleError _) -> "cycle between 2 deps"; _ -> "oops" -- :} -- "cycle between 2 deps"@@ -553,7 +580,7 @@ --   cook @U allowDepCycles ([ --       recipe @U $ val $ wire loopyU, --       recipe @V $ val $ wire loopyV---       ] :: Cauldron IO) +--       ] :: Cauldron IO) --       & \case Left (DependencyCycleError _) -> "oops"; _ -> "cycles are ok" -- :} -- "cycles are ok"@@ -563,20 +590,19 @@     { shouldEnforceDependency = \case         (BarePrimaryBean _, FinishedBean _) -> False         (PrimaryBeanDeco _ _, FinishedBean _) -> False-        (AggregateBean _ , FinishedBean _) -> False+        (AggregateBean _, FinishedBean _) -> False         _ -> True,       followPlanCauldron = fixyFollowPlanCauldron     } --fixyFollowPlanCauldron :: MonadFix m => Cauldron m -> BeanGetter -> Beans -> [BeanConstructionStep] -> m Beans+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, +      -- \*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@@ -584,7 +610,6 @@         initial         plan - -- https://discord.com/channels/280033776820813825/280036215477239809/1147832555828162594 -- https://github.com/ghc-proposals/ghc-proposals/pull/126#issuecomment-1363403330 @@ -624,7 +649,7 @@ -- :} -- -- >>> :{--- cook @A forbidDepCycles (mempty :: Cauldron IO) +-- cook @A forbidDepCycles (mempty :: Cauldron IO) --  & \case Left (MissingResultBeanError _) -> "no recipe for requested bean"; _ -> "oops" -- :} -- "no recipe for requested bean"@@ -635,11 +660,10 @@ -- :} -- -- >>> :{--- cook @B forbidDepCycles ([recipe $ val $ wire B] :: Cauldron IO) +-- cook @B forbidDepCycles ([recipe $ val $ wire B] :: Cauldron IO) --  & \case Left (MissingDependenciesError _) -> "no recipe for A"; _ -> "oops" -- :} -- "no recipe for A"---  cook ::   forall {m} bean.   (Monad m, Typeable bean) =>@@ -652,13 +676,13 @@   (mdeps, c) <- nest' fire cauldron   _ <- case mdeps of     [] -> Right ()-    d : _ -> Left $ MissingDependenciesError d+    d : ds -> Left $ MissingDependenciesError $ d Data.List.NonEmpty.:| ds   Right $ do     (_, bean) <- runConstructor (mempty @BeanGetter) c     pure bean --- | --- +-- |+-- -- 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@@ -746,44 +770,48 @@   () <- 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-      }-    })+  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 =  +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))+data DoubleDutyBean = DoubleDutyBean TypeRep CallStack CallStack   deriving stock (Show)  -- | Get a graph of dependencies between 'BeanConstructionStep's. The graph can -- be obtained even if the 'Cauldron' can't be 'cook'ed successfully. getDependencyGraph :: Cauldron m -> DependencyGraph getDependencyGraph cauldron =-   let (_, deps) = buildDepsCauldron cauldron+  let (_, deps) = buildDepsCauldron cauldron    in DependencyGraph {graph = Graph.edges deps}  checkNoDoubleDutyBeans ::   Cauldron m ->-  Either DoubleDutyBeans (Map TypeRep Dynamic)+  Either (NonEmpty DoubleDutyBean) (Map TypeRep Dynamic) 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+  let common = do+        (tr, (cs1,cs2)) <- Map.toList $ Map.intersectionWith (,) (fst <$> accumMap) beanSet+        [DoubleDutyBean tr cs1 cs2]+  case common of+    ddb : ddbs -> Left $ ddb Data.List.NonEmpty.:| ddbs+    [] -> Right $ snd <$> accumMap  cauldronRegs :: Cauldron m -> (Map TypeRep (CallStack, Dynamic), Map TypeRep CallStack) cauldronRegs Cauldron {recipeMap} =@@ -798,15 +826,16 @@   extractRegReps bean     <> foldMap extractRegReps decos +-- | Missing depencencies for a 'Constructor'. data MissingDependencies = MissingDependencies CallStack TypeRep (Set TypeRep)   deriving stock (Show) -missingDepsToArgReps ::-  [MissingDependencies] ->+missingDepsToArgReps :: (Functor f, Foldable f) => +  f MissingDependencies ->   Set TypeRep-missingDepsToArgReps = Set.unions . fmap (\(MissingDependencies _ _ missing) ->  missing)+missingDepsToArgReps = Set.unions . fmap (\(MissingDependencies _ _ missing) -> missing) -collectMissingDeps :: +collectMissingDeps ::   -- | accums   Set TypeRep ->   -- | available at this level@@ -834,7 +863,6 @@ newtype DependencyCycle = DependencyCycle (NonEmpty (BeanConstructionStep, Maybe CallStack))   deriving stock (Show) - buildPlan :: ((BeanConstructionStep, BeanConstructionStep) -> Bool) -> Cauldron m -> Either DependencyCycle Plan buildPlan shouldEnforceDependency cauldron = do   let (locations, deps) = buildDepsCauldron cauldron@@ -904,44 +932,41 @@       let argStep = FinishedBean argRep       [(item, argStep)]   )-    ++-    -    ( do-        (regRep, _) <- Map.toList regReps-        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) ]-    )+    ++ ( do+           (regRep, _) <- Map.toList regReps+           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)+             ]+       ) -data BeanGetter = BeanGetter { _run :: forall t. (Typeable t) => Maybe t } +data BeanGetter = BeanGetter {_run :: forall t. (Typeable t) => Maybe t}  instance Semigroup BeanGetter where-  BeanGetter { _run = run1 } <> BeanGetter { _run = run2 } =-    BeanGetter { _run = run1 <|> run2 }+  BeanGetter {_run = run1} <> BeanGetter {_run = run2} =+    BeanGetter {_run = run1 <|> run2}  instance Monoid BeanGetter where-  mempty = BeanGetter { _run = Nothing }+  mempty = BeanGetter {_run = Nothing} -runBeanGetter :: BeanGetter -> forall t. (Typeable t) => Maybe t -runBeanGetter BeanGetter { _run } = _run+runBeanGetter :: BeanGetter -> forall t. (Typeable t) => Maybe t+runBeanGetter BeanGetter {_run} = _run  beansBeanGetter :: Beans -> BeanGetter-beansBeanGetter beans = BeanGetter (taste beans) +beansBeanGetter beans = BeanGetter (taste beans)  restrict :: BeanGetter -> Set TypeRep -> BeanGetter-restrict (BeanGetter { _run }) allowed =-  BeanGetter { _run = _run' }+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-+    _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 ::@@ -989,15 +1014,13 @@  -- | Sometimes the 'cook'ing process goes wrong. 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+    MissingResultBeanError TypeRep+  | -- | A 'Constructor' depends on beans that can't be found in the 'Cauldron'.+    MissingDependenciesError (NonEmpty MissingDependencies)   | -- | Beans that work both as primary beans and as secondary beans     -- are disallowed.-    DoubleDutyBeansError DoubleDutyBeans+    DoubleDutyBeansError (NonEmpty DoubleDutyBean)   | -- | Dependency cycles are disallowed by some 'Fire's.     DependencyCycleError DependencyCycle   deriving stock (Show)@@ -1011,9 +1034,9 @@ prettyCookingErrorLines :: CookingError -> [String] prettyCookingErrorLines = \case   MissingResultBeanError tr ->-     ["No recipe found that produces requested bean " ++ show tr]-  MissingDependenciesError-    (MissingDependencies constructorCallStack constructorResultRep missingDependenciesReps) ->+    ["No recipe found that produces requested bean " ++ show tr]+  MissingDependenciesError missingDeps ->+    missingDeps & foldMap \(MissingDependencies constructorCallStack constructorResultRep missingDependenciesReps) ->       [ "This constructor for a value of type "           ++ show constructorResultRep           ++ ":"@@ -1024,10 +1047,10 @@         ++ do           rep <- Data.Foldable.toList missingDependenciesReps           ["- " ++ show rep]-  DoubleDutyBeansError (DoubleDutyBeans doubleDutyMap) ->+  DoubleDutyBeansError doubleDutyBeans ->     [ "The following beans work both as primary beans and secondary beans:"     ]-      ++ ( flip Map.foldMapWithKey doubleDutyMap \rep (secCS, primCS) ->+      ++ ( doubleDutyBeans & foldMap \(DoubleDutyBean rep secCS primCS) ->              [ "- " ++ show rep ++ " is a secondary bean in this constructor:"              ]                ++ (("\t" ++) <$> prettyCallStackLines secCS)@@ -1056,10 +1079,7 @@ newtype DependencyGraph = DependencyGraph {graph :: AdjacencyMap BeanConstructionStep}   deriving newtype (Show, Eq, Ord, Semigroup, Monoid) --- | Conversion to a graph type--- from the--- [algebraic-graphs](https://hackage.haskell.org/package/algebraic-graphs-0.7/docs/Algebra-Graph-AdjacencyMap.html)--- library for further processing.+-- | Conversion to a graph type for further processing. toAdjacencyMap :: DependencyGraph -> AdjacencyMap BeanConstructionStep toAdjacencyMap DependencyGraph {graph} = graph @@ -1091,12 +1111,12 @@       vertices = Graph.vertexList simplified       edges = Graph.edgeList simplified       edgesWithoutSelfLoops =-        edges &-        filter-          ( \case-              (FinishedBean source, FinishedBean target) -> if source == target then False else True-              _ -> True-          )+        edges+          & filter+            ( \case+                (FinishedBean source, FinishedBean target) -> if source == target then False else True+                _ -> True+            )   DependencyGraph {graph = Graph.vertices vertices `Graph.overlay` Graph.edges edgesWithoutSelfLoops}  -- | See the [DOT format](https://graphviz.org/doc/info/lang.html).@@ -1104,7 +1124,7 @@ writeAsDot style filepath DependencyGraph {graph} = do   let dot = Dot.export style graph   System.IO.withFile filepath System.IO.WriteMode $ \handle -> do-    System.IO.hSetEncoding handle System.IO.utf8  +    System.IO.hSetEncoding handle System.IO.utf8     System.IO.hPutStrLn handle dot  -- | Default DOT rendering style to use with 'writeAsDot'.@@ -1117,8 +1137,10 @@     { Dot.vertexAttributes = \step -> case merr of         Nothing -> []         Just (MissingResultBeanError _) ->-            []-        Just (MissingDependenciesError (MissingDependencies _ _ missing)) ->+          []+        Just (MissingDependenciesError missingDeps) ->+          let missing = missingDepsToArgReps missingDeps+           in           case step of             FinishedBean rep               | Set.member rep missing ->@@ -1126,7 +1148,11 @@                     fromString "color" Dot.:= fromString "red"                   ]             _ -> []-        Just (DoubleDutyBeansError (DoubleDutyBeans (Map.keysSet -> bs))) ->+        Just (DoubleDutyBeansError doubleDutyBeans) ->+          let bs =  Set.fromList $ do+                      DoubleDutyBean ddb _ _ <- Data.List.NonEmpty.toList doubleDutyBeans+                      [ddb]+          in           case step of             FinishedBean rep               | Set.member rep bs ->@@ -1149,10 +1175,10 @@     }  -- | Change the default way of how 'BeanConstructionStep's are rendered to text.-setVertexName :: IsString s => (BeanConstructionStep -> s) -> Dot.Style BeanConstructionStep s -> Dot.Style BeanConstructionStep s+setVertexName :: (IsString s) => (BeanConstructionStep -> s) -> Dot.Style BeanConstructionStep s -> Dot.Style BeanConstructionStep s setVertexName vertexName style = style {Dot.vertexName} -defaultStepToText :: IsString s => BeanConstructionStep -> s+defaultStepToText :: (IsString s) => BeanConstructionStep -> s defaultStepToText =   let p rep = show rep    in \case@@ -1161,7 +1187,6 @@         AggregateBean rep -> fromString $ p rep ++ "#agg"         FinishedBean rep -> fromString $ p rep - -- | A way of building value of type @bean@, potentially requiring some -- dependencies, potentially returning some secondary aggregate beans -- along the primary @bean@ result, and also potentially requiring some@@ -1192,11 +1217,10 @@ -- data A = A -- data B = B -- makeB :: A -> B--- makeB _ = 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 @@ -1205,11 +1229,15 @@ -- rightmost-innermost one are registered as aggregate beans (if they have -- 'Monoid' instances, otherwise 'val' won't compile). --+-- Because this function gives a special meaning to tuples, it shouldn't be used+-- to wire beans that have themselves a tuple type. Better define a+-- special-purpose bean datatype instead.+-- -- >>> :{ -- data A = A -- data B = B -- makeB :: A -> (Sum Int, Any, B)--- makeB _ = (Sum 0, Any False, B) +-- makeB _ = (Sum 0, Any False, B) -- c :: Constructor IO B -- c = val $ wire $ makeB -- makeB' :: A -> (Sum Int, (Any, B))@@ -1217,13 +1245,11 @@ -- 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 @@ -1236,11 +1262,10 @@ -- data A = A -- data B = B -- makeB :: A -> IO B--- makeB _ = pure 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 @@ -1253,11 +1278,15 @@ -- components except the rightmost-innermost one are registered as aggregate -- beans (if they have 'Monoid' instances, otherwise 'eff' won't compile). --+-- Because this function gives a special meaning to tuples, it shouldn't be used+-- to wire beans that have themselves a tuple type. Better define a+-- special-purpose bean datatype instead.+-- -- >>> :{ -- data A = A -- data B = B -- makeB :: A -> IO (Sum Int, Any, B)--- makeB _ = pure (Sum 0, Any False, B) +-- makeB _ = pure (Sum 0, Any False, B) -- c :: Constructor IO B -- c = eff $ wire $ makeB -- makeB' :: A -> IO (Sum Int, (Any, B))@@ -1265,7 +1294,6 @@ -- 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) @@ -1278,10 +1306,11 @@ eff' :: forall bean m. (HasCallStack) => Args (m (Regs bean)) -> Constructor m bean eff' = Constructor callStack -runConstructor :: (Monad m) => -    BeanGetter ->-    Constructor m bean -> -      m (Beans, bean)+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)@@ -1406,11 +1435,10 @@ --   cook @X forbidDepCycles ([ --       recipe @X $ val $ wire makeX, --       recipe @(Sum Int) $ val $ wire makeAgg---       ] :: Cauldron IO) +--       ] :: Cauldron IO) --       & \case Left (DoubleDutyBeansError _) -> "Sum Int is aggregate and primary"; _ -> "oops" -- :} -- "Sum Int is aggregate and primary"---  -- $setup -- >>> :set -XBlockArguments@@ -1421,4 +1449,3 @@ -- >>> import Data.Monoid -- >>> import Data.Either (either, isLeft) -- >>> import Control.Exception (throwIO)-

@@ -19,6 +19,7 @@     runArgs,     getArgsReps,     contramapArgs,+     -- ** Reducing 'arg' boilerplate with 'wire'     Wireable (wire), 

@@ -12,9 +12,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoFieldSelectors #-} -module Cauldron.Args.Internal-  -where+module Cauldron.Args.Internal where  import Cauldron.Beans (Beans, SomeMonoidTypeRep (..), fromDynList) import Cauldron.Beans qualified@@ -228,6 +226,10 @@ 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.+  --+  -- This function assumes that the @tip@ is not a function, in order to know+  -- when to stop collecting arguments. If your intended @tip@ is a function,+  -- you might need to wrap it in a newtype in order to disambiguate.   --   -- >>> :{   -- fun0 :: Int

@@ -75,3 +75,8 @@     a <- m     return_ a   {-# INLINE liftIO #-}++instance MonadFail Managed where+    fail s = Managed (\return_ -> do+        a <- fail @IO s+        return_ a )

@@ -9,7 +9,6 @@  module Main (main) where -import Cauldron import Cauldron.Args import Control.Exception import Data.Dynamic

@@ -180,7 +180,7 @@                 -- putStrLn $ prettyRecipeError err                 assertFailure $ "could not wire " ++ name               Right (Identity acc) ->-                    assertEqual "experted result" expected acc,+                assertEqual "experted result" expected acc,       testCase "wiring with accums" do         Data.Foldable.for_ @[]           [ ("aggcyle", cauldronAccumsOops1),@@ -200,8 +200,8 @@           -- putStrLn $ prettyRecipeError err           assertFailure "could not wire"         Right (Identity (Serializer {runSerializer})) -> do-              let value = FooToBar (BarToFoo (FooToBar (BarToBaz EndBaz)))-              assertEqual "experted result" ".FooToBar.BarToFoo.FooToBar.BarToBar.EndBaz" (runSerializer value)+          let value = FooToBar (BarToFoo (FooToBar (BarToBaz EndBaz)))+          assertEqual "experted result" ".FooToBar.BarToFoo.FooToBar.BarToBar.EndBaz" (runSerializer value)  main :: IO () main = defaultMain tests

@@ -9,7 +9,6 @@ import Cauldron import Cauldron.Managed import Data.IORef-import Data.Maybe (fromJust) import Test.Tasty import Test.Tasty.HUnit 

@@ -11,6 +11,7 @@ import Cauldron import Control.Monad.IO.Class import Control.Monad.Trans.Writer+import Data.Foldable qualified import Data.Function ((&)) import Data.IORef import Data.Map (Map)@@ -21,7 +22,7 @@ import Data.Typeable (typeRep) import Test.Tasty import Test.Tasty.HUnit-import Data.Foldable qualified+import Data.List (sort)  type Text = String @@ -134,37 +135,36 @@  cauldronX1 :: Cauldron M cauldronX1 =-    fromRecipeList-        [ recipe @(Logger M) $ eff $ pure makeLogger, -          recipe @(Weird M) $ eff $ wire makeWeird -- overwritten-        ]+  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-            pure do-              (initializer, repo) <- action-              pure (initializer, repo),-          recipe @(Weird M)-            Recipe-              { bean = eff $ wire makeSelfInvokingWeird,-                decos =-                  fromDecoList-                    [ val $ wire (weirdDeco "inner"),-                      val $ wire (weirdDeco "outer")-                    ]-              },-          recipe @Result $ val_ do wire Result-        ]+  fromRecipeList+    [ recipe @(Repository M) $ eff $ do+        action <- wire makeRepository+        pure do+          (initializer, repo) <- action+          pure (initializer, repo),+      recipe @(Weird M)+        Recipe+          { bean = eff $ wire makeSelfInvokingWeird,+            decos =+              fromDecoList+                [ val $ wire (weirdDeco "inner"),+                  val $ wire (weirdDeco "outer")+                ]+          },+      recipe @Result $ val_ do wire Result+    ]  data Result = Result Initializer (Repository M) (Weird M)  cauldronX :: Cauldron M cauldronX = cauldronX1 <> cauldronX2 - cauldronLonely :: Cauldron M cauldronLonely =   fromRecipeList@@ -208,8 +208,7 @@               pure ()         assertEqual           "traces"-          [ -            -- "weird constructor", -- not happens, because overwritten+          (sort [ -- "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",@@ -225,21 +224,22 @@             "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 ()-          ,+          ])+          (sort 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 "value nested" do-        ((), traces) <- case (-              do constructorX2 <- nest allowSelfDeps cauldronX2-                 cook @Result allowSelfDeps (cauldronX1 & Cauldron.insert @Result constructorX2)) of+        ((), 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@@ -252,8 +252,7 @@               pure ()         assertEqual           "traces"-          [ -            -- the order of the traces here is a bit too overspecified. several orders could be valid.+          (sort [ -- 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@@ -270,17 +269,17 @@             "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 ()-          ,+          ])+          (sort 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 allowSelfDeps cauldronLonely of           Left _ -> assertFailure "could not wire"@@ -292,8 +291,9 @@         pure (),       testCase "cauldron missing dep" do         case cook' cauldronMissingDep of-          Left (MissingDependenciesError (MissingDependencies _ tr missingSet))-            | tr == typeRep (Proxy @(Repository M)) && missingSet == Data.Set.singleton (typeRep (Proxy @(Logger M))) -> pure ()+          Left (MissingDependenciesError missingDeps )+            | [MissingDependencies _ tr missingSet]  <- Data.Foldable.toList missingDeps,+              tr == typeRep (Proxy @(Repository M)) && missingSet == Data.Set.singleton (typeRep (Proxy @(Logger M))) -> pure ()           _ -> assertFailure "missing dependency not detected"         pure (),       testCase "cauldron with double duty bean" do@@ -303,9 +303,9 @@         pure (),       testCase "cauldron with cycle" do         case cook' cauldronWithCycle of-          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)+          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 ()     ]