input-output-hk / constrained-generators / 416

Committed 21 Nov 2025 08:35AM UTC coverage: 76.66% (+0.2%) from 76.458%

Build # 416

Build Type

push

github

Committed by

web-flow

Commit Message

fourmolu (#60)

Run Details

179 of 191 new or added lines in 14 files covered. (93.72%)

10 existing lines in 4 files now uncovered.

3948 of 5150 relevant lines covered (76.66%)

1.45 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

85.0

/src/Constrained/Graph.hs

{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

-- | This module provides a dependency graph implementation.
module Constrained.Graph (
  Graph,
  edges,
  opEdges,
  opGraph,
  mkGraph,
  nodes,
  deleteNode,
  subtractGraph,
  dependency,
  findCycle,
  dependsOn,
  dependencies,
  noDependencies,
  topsort,
  transitiveClosure,
  transitiveDependencies,
  irreflexiveDependencyOn,
) where

import Control.Monad
import Data.Foldable
-- TODO: consider using more of this
import Data.Graph qualified as G
import Data.List (nub)
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Maybe
import Data.Set (Set)
import Data.Set qualified as Set
import Prettyprinter
import Test.QuickCheck

-- | A graph with unlabeled edges for keeping track of dependencies
data Graph node = Graph
  { edges :: !(Map node (Set node))
  , opEdges :: !(Map node (Set node))
  }
  deriving (Show, Eq)

instance Ord node => Semigroup (Graph node) where
  Graph e o <> Graph e' o' =
    Graph
      (Map.unionWith (<>) e e')
      (Map.unionWith (<>) o o')

instance Ord node => Monoid (Graph node) where
  mempty = Graph mempty mempty

instance Pretty n => Pretty (Graph n) where
  pretty gr =
    fold $
      punctuate
        hardline
        [ nest 4 $ pretty n <> " <- " <> brackets (fillSep (map pretty (Set.toList ns)))
        | (n, ns) <- Map.toList (edges gr)
        ]

-- | Construct a graph
mkGraph :: Ord node => Map node (Set node) -> Graph node
mkGraph e0 =
  Graph e $
    Map.unionsWith
      (<>)
      [ Map.fromList $
          (p, mempty)
            : [ (c, Set.singleton p)
              | c <- Set.toList cs
              ]
      | (p, cs) <- Map.toList e
      ]
  where
    e =
      Map.unionWith
        (<>)
        e0
        ( Map.fromList
            [ (c, mempty)
            | (_, cs) <- Map.toList e0
            , c <- Set.toList cs
            ]
        )

instance (Arbitrary node, Ord node) => Arbitrary (Graph node) where
  arbitrary =
    frequency
      [ (1, mkGraph <$> arbitrary)
      ,
        ( 3
        , do
            order <- nub <$> arbitrary
            mkGraph <$> buildGraph order
        )
      ]
    where
      buildGraph [] = return mempty
      buildGraph [n] = return (Map.singleton n mempty)
      buildGraph (n : ns) = do
        deps <- listOf (elements ns)
        Map.insert n (Set.fromList deps) <$> buildGraph ns
  shrink g =
    [ mkGraph e'
    | e <- shrink (edges g)
    , -- If we don't do this it's very easy to introduce a shrink-loop
    let e' = fmap (\xs -> Set.filter (`Map.member` e) xs) e
    ]

-- | Get all the nodes of a graph
nodes :: Graph node -> Set node
nodes (Graph e _) = Map.keysSet e

-- | Delete a node from a graph
deleteNode :: Ord node => node -> Graph node -> Graph node
deleteNode x (Graph e o) = Graph (clean e) (clean o)
  where
    clean = Map.delete x . fmap (Set.delete x)

-- | Invert the graph
opGraph :: Graph node -> Graph node
opGraph (Graph e o) = Graph o e

-- | @subtractGraph g g'@ is the graph @g@ without the dependencies in @g'@
subtractGraph :: Ord node => Graph node -> Graph node -> Graph node
subtractGraph (Graph e o) (Graph e' o') =
  Graph
    (Map.differenceWith del e e')
    (Map.differenceWith del o o')
  where
    del x y = Just $ Set.difference x y

-- | @dependency x xs@ is the graph where @x@ depends on every node in @xs@
-- and there are no other dependencies.
dependency :: Ord node => node -> Set node -> Graph node
dependency x xs =
  Graph
    (Map.singleton x xs)
    ( Map.unionWith
        (<>)
        (Map.singleton x mempty)
        (Map.fromList [(y, Set.singleton x) | y <- Set.toList xs])
    )

-- | Every node in the first set depends on every node in the second set except themselves
irreflexiveDependencyOn :: Ord node => Set node -> Set node -> Graph node
irreflexiveDependencyOn xs ys =
  deps <> noDependencies ys
  where
    deps =
      Graph
        (Map.fromDistinctAscList [(x, Set.delete x ys) | x <- Set.toList xs])
        (Map.fromDistinctAscList [(a, Set.delete a xs) | a <- Set.toList ys])

-- | Get all down-stream dependencies of a node
transitiveDependencies :: Ord node => node -> Graph node -> Set node
transitiveDependencies x (Graph e _) = go mempty (Set.toList $ fromMaybe mempty $ Map.lookup x e)
  where
    go deps [] = deps
    go deps (y : ys)
      | y `Set.member` deps = go deps ys
      | otherwise = go (Set.insert y deps) (ys ++ Set.toList (fromMaybe mempty $ Map.lookup y e))

-- | Take the transitive closure of the graph
transitiveClosure :: Ord node => Graph node -> Graph node
transitiveClosure g = foldMap (\x -> dependency x (transitiveDependencies x g)) (nodes g)

-- | The discrete graph containing all the input nodes without any dependencies
noDependencies :: Ord node => Set node -> Graph node
noDependencies ns = Graph nodeMap nodeMap
  where
    nodeMap = Map.fromList ((,mempty) <$> Set.toList ns)

-- | Topsort the graph, returning either @Right order@ if the graph is a DAG or
-- @Left cycle@  if it is not
topsort :: Ord node => Graph node -> Either [node] [node]
topsort gr@(Graph e _) = go [] e
  where
    go order g
      | null g = pure $ reverse order
      | otherwise = do
          let noDeps = Map.keysSet . Map.filter null $ g
              removeNode n ds = Set.difference ds noDeps <$ guard (not $ n `Set.member` noDeps)
          if not $ null noDeps
            then go (Set.toList noDeps ++ order) (Map.mapMaybeWithKey removeNode g)
            else Left $ findCycle gr

-- | Simple DFS cycle finding
findCycle :: Ord node => Graph node -> [node]
findCycle g@(Graph e _) = mkCycle . concat . take 1 . filter isCyclic . map (map tr) . concatMap cycles . G.scc $ gr
  where
    edgeList = [(n, n, Set.toList es) | (n, es) <- Map.toList e]
    (gr, tr0, _) = G.graphFromEdges edgeList
    tr x = let (n, _, _) = tr0 x in n
    cycles (G.Node a []) = [[a]]
    cycles (G.Node a as) = (a :) <$> concatMap cycles as
    isCyclic [] = False
    isCyclic [a] = dependsOn a a g
    isCyclic _ = True
    -- Removes a non-dependent stem from the start of the dependencies
    mkCycle ns = let l = last ns in dropWhile (\n -> not $ dependsOn l n g) ns

-- | Get the dependencies of a node in the graph, `mempty` if the node is not
-- in the graph
dependencies :: Ord node => node -> Graph node -> Set node
dependencies x (Graph e _) = fromMaybe mempty (Map.lookup x e)

-- | Check if a node depends on another in the graph
dependsOn :: Ord node => node -> node -> Graph node -> Bool
dependsOn x y g = y `Set.member` dependencies x g

1	{-# LANGUAGE ImportQualifiedPost #-}
2	{-# LANGUAGE OverloadedStrings #-}
3	{-# LANGUAGE TupleSections #-}
4
5	-- \| This module provides a dependency graph implementation.
6	module Constrained.Graph (
7	Graph,
8	edges,
9	opEdges,
10	opGraph,
11	mkGraph,
12	nodes,
13	deleteNode,
14	subtractGraph,
15	dependency,
16	findCycle,
17	dependsOn,
18	dependencies,
19	noDependencies,
20	topsort,
21	transitiveClosure,
22	transitiveDependencies,
23	irreflexiveDependencyOn,
24	) where
25
26	import Control.Monad
27	import Data.Foldable
28	-- TODO: consider using more of this
29	import Data.Graph qualified as G
30	import Data.List (nub)
31	import Data.Map (Map)
32	import Data.Map qualified as Map
33	import Data.Maybe
34	import Data.Set (Set)
35	import Data.Set qualified as Set
36	import Prettyprinter
37	import Test.QuickCheck
38
39	-- \| A graph with unlabeled edges for keeping track of dependencies
40	data Graph node = Graph
UNCOV 41	{ edges :: !(Map node (Set node))	×
42	, opEdges :: !(Map node (Set node))	×
43	}
UNCOV 44	deriving (Show, Eq)	×
45
UNCOV 46	instance Ord node => Semigroup (Graph node) where	×
47	Graph e o <> Graph e' o' =	2✔
48	Graph	2✔
49	(Map.unionWith (<>) e e')	2✔
50	(Map.unionWith (<>) o o')	2✔
51
52	instance Ord node => Monoid (Graph node) where	2✔
53	mempty = Graph mempty mempty	2✔
54
UNCOV 55	instance Pretty n => Pretty (Graph n) where	×
56	pretty gr =	×
57	fold $	×
58	punctuate	×
59	hardline	×
60	[ nest 4 $ pretty n <> " <- " <> brackets (fillSep (map pretty (Set.toList ns)))	×
61	\| (n, ns) <- Map.toList (edges gr)	×
62	]
63
64	-- \| Construct a graph
65	mkGraph :: Ord node => Map node (Set node) -> Graph node
66	mkGraph e0 =	2✔
67	Graph e $	2✔
68	Map.unionsWith	2✔
69	(<>)	2✔
70	[ Map.fromList $	2✔
71	(p, mempty)	2✔
72	: [ (c, Set.singleton p)	2✔
73	\| c <- Set.toList cs	2✔
74	]
75	\| (p, cs) <- Map.toList e	2✔
76	]
77	where
78	e =	2✔
79	Map.unionWith	2✔
80	(<>)	2✔
81	e0	2✔
82	( Map.fromList	2✔
83	[ (c, mempty)	2✔
84	\| (_, cs) <- Map.toList e0	2✔
85	, c <- Set.toList cs	2✔
86	]
87	)
88
89	instance (Arbitrary node, Ord node) => Arbitrary (Graph node) where
90	arbitrary =	2✔
91	frequency	2✔
92	[ (1, mkGraph <$> arbitrary)	2✔
93	,
94	( 3	2✔
95	, do	2✔
96	order <- nub <$> arbitrary	2✔
97	mkGraph <$> buildGraph order	2✔
98	)
99	]
100	where
101	buildGraph [] = return mempty	2✔
102	buildGraph [n] = return (Map.singleton n mempty)	2✔
103	buildGraph (n : ns) = do	2✔
104	deps <- listOf (elements ns)	2✔
105	Map.insert n (Set.fromList deps) <$> buildGraph ns	2✔
106	shrink g =	×
107	[ mkGraph e'	×
108	\| e <- shrink (edges g)	×
109	, -- If we don't do this it's very easy to introduce a shrink-loop
NEW 110	let e' = fmap (\xs -> Set.filter (`Map.member` e) xs) e	×
111	]
112
113	-- \| Get all the nodes of a graph
114	nodes :: Graph node -> Set node
115	nodes (Graph e _) = Map.keysSet e	2✔
116
117	-- \| Delete a node from a graph
118	deleteNode :: Ord node => node -> Graph node -> Graph node
119	deleteNode x (Graph e o) = Graph (clean e) (clean o)	2✔
120	where
121	clean = Map.delete x . fmap (Set.delete x)	2✔
122
123	-- \| Invert the graph
124	opGraph :: Graph node -> Graph node
125	opGraph (Graph e o) = Graph o e	2✔
126
127	-- \| @subtractGraph g g'@ is the graph @g@ without the dependencies in @g'@
128	subtractGraph :: Ord node => Graph node -> Graph node -> Graph node
129	subtractGraph (Graph e o) (Graph e' o') =	2✔
130	Graph	2✔
131	(Map.differenceWith del e e')	2✔
132	(Map.differenceWith del o o')	2✔
133	where
134	del x y = Just $ Set.difference x y	2✔
135
136	-- \| @dependency x xs@ is the graph where @x@ depends on every node in @xs@
137	-- and there are no other dependencies.
138	dependency :: Ord node => node -> Set node -> Graph node
139	dependency x xs =	2✔
140	Graph	2✔
141	(Map.singleton x xs)	2✔
142	( Map.unionWith	2✔
143	(<>)	2✔
144	(Map.singleton x mempty)	2✔
145	(Map.fromList [(y, Set.singleton x) \| y <- Set.toList xs])	2✔
146	)
147
148	-- \| Every node in the first set depends on every node in the second set except themselves
149	irreflexiveDependencyOn :: Ord node => Set node -> Set node -> Graph node
150	irreflexiveDependencyOn xs ys =	2✔
151	deps <> noDependencies ys	2✔
152	where
153	deps =	2✔
154	Graph	2✔
155	(Map.fromDistinctAscList [(x, Set.delete x ys) \| x <- Set.toList xs])	2✔
156	(Map.fromDistinctAscList [(a, Set.delete a xs) \| a <- Set.toList ys])	1✔
157
158	-- \| Get all down-stream dependencies of a node
159	transitiveDependencies :: Ord node => node -> Graph node -> Set node
160	transitiveDependencies x (Graph e _) = go mempty (Set.toList $ fromMaybe mempty $ Map.lookup x e)	2✔
161	where
162	go deps [] = deps	2✔
163	go deps (y : ys)
164	\| y `Set.member` deps = go deps ys	2✔
165	\| otherwise = go (Set.insert y deps) (ys ++ Set.toList (fromMaybe mempty $ Map.lookup y e))	1✔
166
167	-- \| Take the transitive closure of the graph
168	transitiveClosure :: Ord node => Graph node -> Graph node
169	transitiveClosure g = foldMap (\x -> dependency x (transitiveDependencies x g)) (nodes g)	2✔
170
171	-- \| The discrete graph containing all the input nodes without any dependencies
172	noDependencies :: Ord node => Set node -> Graph node
173	noDependencies ns = Graph nodeMap nodeMap	2✔
174	where
175	nodeMap = Map.fromList ((,mempty) <$> Set.toList ns)	2✔
176
177	-- \| Topsort the graph, returning either @Right order@ if the graph is a DAG or
178	-- @Left cycle@ if it is not
179	topsort :: Ord node => Graph node -> Either [node] [node]
180	topsort gr@(Graph e _) = go [] e	2✔
181	where
182	go order g	2✔
183	\| null g = pure $ reverse order	2✔
184	\| otherwise = do	1✔
185	let noDeps = Map.keysSet . Map.filter null $ g	2✔
186	removeNode n ds = Set.difference ds noDeps <$ guard (not $ n `Set.member` noDeps)	2✔
187	if not $ null noDeps	2✔
188	then go (Set.toList noDeps ++ order) (Map.mapMaybeWithKey removeNode g)	2✔
189	else Left $ findCycle gr	1✔
190
191	-- \| Simple DFS cycle finding
192	findCycle :: Ord node => Graph node -> [node]
193	findCycle g@(Graph e _) = mkCycle . concat . take 1 . filter isCyclic . map (map tr) . concatMap cycles . G.scc $ gr	2✔
194	where
195	edgeList = [(n, n, Set.toList es) \| (n, es) <- Map.toList e]	2✔
196	(gr, tr0, _) = G.graphFromEdges edgeList	2✔
197	tr x = let (n, _, _) = tr0 x in n	2✔
198	cycles (G.Node a []) = [[a]]	2✔
199	cycles (G.Node a as) = (a :) <$> concatMap cycles as	2✔
200	isCyclic [] = False	1✔
201	isCyclic [a] = dependsOn a a g	2✔
202	isCyclic _ = True	2✔
203	-- Removes a non-dependent stem from the start of the dependencies
204	mkCycle ns = let l = last ns in dropWhile (\n -> not $ dependsOn l n g) ns	2✔
205
206	-- \| Get the dependencies of a node in the graph, `mempty` if the node is not
207	-- in the graph
208	dependencies :: Ord node => node -> Graph node -> Set node
209	dependencies x (Graph e _) = fromMaybe mempty (Map.lookup x e)	2✔
210
211	-- \| Check if a node depends on another in the graph
212	dependsOn :: Ord node => node -> node -> Graph node -> Bool
213	dependsOn x y g = y `Set.member` dependencies x g	2✔

input-output-hk / constrained-generators / 416

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous