Skip to content

Commit becd004

Browse files
MaximilianAlgehedMaximilianAlgehed
committed
Property tests for Constrained.Graph
1 parent b24b667 commit becd004

File tree

4 files changed

+169
-10
lines changed

4 files changed

+169
-10
lines changed

‎constrained-generators.cabal‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -125,7 +125,9 @@ test-suite constrained-tests
125125
type: exitcode-stdio-1.0
126126
main-is: Tests.hs
127127
hs-source-dirs: test
128-
other-modules: Constrained.Tests
128+
other-modules:
129+
Constrained.Tests
130+
Constrained.GraphSpec
129131
default-language: Haskell2010
130132
ghc-options:
131133
-Wall

‎src/Constrained/Graph.hs‎

Lines changed: 45 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -5,7 +5,10 @@
55
-- | This module provides a dependency graph implementation.
66
module Constrained.Graph (
77
Graph,
8+
edges,
9+
opEdges,
810
opGraph,
11+
mkGraph,
912
nodes,
1013
deleteNode,
1114
subtractGraph,
@@ -22,20 +25,21 @@ module Constrained.Graph (
2225

2326
import Control.Monad
2427
import Data.Foldable
25-
import Data.List (sortOn)
28+
import Data.List (sortOn, nub)
2629
import Data.Map (Map)
2730
import Data.Map qualified as Map
2831
import Data.Maybe
2932
import Data.Set (Set)
3033
import Data.Set qualified as Set
3134
import Prettyprinter
35+
import Test.QuickCheck
3236

3337
-- | A graph with unlabeled edges for keeping track of dependencies
3438
data Graph node = Graph
3539
{ edges :: !(Map node (Set node))
3640
, opEdges :: !(Map node (Set node))
3741
}
38-
deriving (Show)
42+
deriving (Show, Eq)
3943

4044
instance Ord node => Semigroup (Graph node) where
4145
Graph e o <> Graph e' o' =
@@ -55,6 +59,37 @@ instance Pretty n => Pretty (Graph n) where
5559
| (n, ns) <- Map.toList (edges gr)
5660
]
5761

62+
-- | Construct a graph
63+
mkGraph :: Ord node => Map node (Set node) -> Graph node
64+
mkGraph e0 = Graph e $ Map.unionsWith (<>)
65+
[ Map.fromList $ (p, mempty) : [ (c, Set.singleton p)
66+
| c <- Set.toList cs
67+
]
68+
| (p, cs) <- Map.toList e
69+
]
70+
where e = Map.unionWith (<>) e0 (Map.fromList [ (c, mempty) | (_, cs) <- Map.toList e0
71+
, c <- Set.toList cs
72+
])
73+
74+
instance (Arbitrary node, Ord node) => Arbitrary (Graph node) where
75+
arbitrary =
76+
frequency [ (1, mkGraph <$> arbitrary)
77+
, (3, do order <- nub <$> arbitrary
78+
mkGraph <$> buildGraph order
79+
)
80+
]
81+
where buildGraph [] = return mempty
82+
buildGraph [n] = return (Map.singleton n mempty)
83+
buildGraph (n:ns) = do
84+
deps <- listOf (elements ns)
85+
Map.insert n (Set.fromList deps) <$> buildGraph ns
86+
shrink g =
87+
[ mkGraph e'
88+
| e <- shrink (edges g)
89+
-- If we don't do this it's very easy to introduce a shrink-loop
90+
, let e' = fmap (\ xs -> Set.filter (`Map.member` e) xs) e
91+
]
92+
5893
-- | Get all the nodes of a graph
5994
nodes :: Graph node -> Set node
6095
nodes (Graph e _) = Map.keysSet e
@@ -102,11 +137,12 @@ irreflexiveDependencyOn xs ys =
102137

103138
-- | Get all down-stream dependencies of a node
104139
transitiveDependencies :: Ord node => node -> Graph node -> Set node
105-
transitiveDependencies x (Graph e _) = go (Set.singleton x) x
140+
transitiveDependencies x (Graph e _) = go mempty (Set.toList $ fromMaybe mempty $ Map.lookup x e)
106141
where
107-
go seen y = ys <> foldMap (go $ Set.insert y seen) (Set.difference ys seen)
108-
where
109-
ys = fromMaybe mempty (Map.lookup y e)
142+
go deps [] = deps
143+
go deps (y:ys)
144+
| y `Set.member` deps = go deps ys
145+
| otherwise = go (Set.insert y deps) (ys ++ Set.toList (fromMaybe mempty $ Map.lookup y e))
110146

111147
-- | Take the transitive closure of the graph
112148
transitiveClosure :: Ord node => Graph node -> Graph node
@@ -135,8 +171,10 @@ topsort gr@(Graph e _) = go [] e
135171
-- | Simple DFS cycle finding
136172
-- TODO: tests for this, currently it can produce a stem with a cycle after it
137173
findCycle :: Ord node => Graph node -> node -> [node]
138-
findCycle (Graph e _) node = concat . take 1 $ go mempty node
174+
findCycle g@(Graph e _) node = concat . take 1 $ filter loopy $ go mempty node
139175
where
176+
loopy [] = False
177+
loopy c@(x:_) = dependsOn (last c) x g
140178
go seen n
141179
| n `Set.member` seen = [[]]
142180
| otherwise = do

‎test/Constrained/GraphSpec.hs‎

Lines changed: 116 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,116 @@
1+
{-# LANGUAGE DerivingStrategies #-}
2+
{-# LANGUAGE TypeApplications #-}
3+
{-# LANGUAGE ScopedTypeVariables #-}
4+
{-# LANGUAGE NumericUnderscores #-}
5+
{-# LANGUAGE ImportQualifiedPost #-}
6+
{-# LANGUAGE DerivingVia #-}
7+
module Constrained.GraphSpec where
8+
9+
import Data.Either
10+
import Constrained.Graph
11+
import Data.Set (Set)
12+
import Data.Set qualified as Set
13+
import Test.Hspec
14+
import Test.Hspec.QuickCheck
15+
import Test.QuickCheck
16+
17+
newtype Node = Node Int
18+
deriving (Ord, Eq)
19+
deriving Show via Int
20+
21+
instance Arbitrary Node where
22+
arbitrary = Node <$> choose (0, 20)
23+
shrink (Node n) = Node <$> shrink n
24+
25+
prop_arbitrary_reasonable_distribution :: Graph Node -> Property
26+
prop_arbitrary_reasonable_distribution g =
27+
cover 60 (isRight $ topsort g) "has topsort" True
28+
29+
prop_no_dependencies_topsort :: Set Node -> Property
30+
prop_no_dependencies_topsort = property . isRight . topsort . noDependencies
31+
32+
prop_subtract_topsort :: Graph Node -> Graph Node -> Property
33+
prop_subtract_topsort g g' =
34+
isRight (topsort g) ==>
35+
isRight (topsort $ subtractGraph g g')
36+
37+
prop_delete_topsort :: Graph Node -> Node -> Property
38+
prop_delete_topsort g n =
39+
isRight (topsort g) ==>
40+
isRight (topsort $ deleteNode n g)
41+
42+
prop_op_topsort :: Graph Node -> Property
43+
prop_op_topsort g =
44+
isRight (topsort g) === isRight (topsort $ opGraph g)
45+
46+
prop_trC_topsort :: Graph Node -> Property
47+
prop_trC_topsort g =
48+
isRight (topsort g) === isRight (topsort $ transitiveClosure g)
49+
50+
prop_trC_opgraph_commute :: Graph Node -> Property
51+
prop_trC_opgraph_commute g =
52+
transitiveClosure (opGraph g) === opGraph (transitiveClosure g)
53+
54+
prop_depends_grows :: Graph Node -> Graph Node -> Node -> Property
55+
prop_depends_grows g g' n = property $ dependencies n g `Set.isSubsetOf` dependencies n (g <> g')
56+
57+
prop_transitive_dependencies :: Graph Node -> Node -> Property
58+
prop_transitive_dependencies g n =
59+
transitiveDependencies n g === dependencies n (transitiveClosure g)
60+
61+
prop_topsort_all_nodes :: Graph Node -> Property
62+
prop_topsort_all_nodes g =
63+
case topsort g of
64+
Left{} -> discard
65+
Right o -> Set.fromList o === nodes g
66+
67+
prop_topsort_sound :: Graph Node -> Property
68+
prop_topsort_sound g =
69+
case topsort g of
70+
Left{} -> discard
71+
Right o -> property $ go o
72+
where
73+
go [] = True
74+
go (n : ns) = all (\n' -> not $ dependsOn n n' g) ns && go ns
75+
76+
prop_topsort_complete :: Graph Node -> Property
77+
prop_topsort_complete g =
78+
isLeft (topsort g) === any (\ n -> not . null $ findCycle g n) (nodes g)
79+
80+
prop_find_cycle_sound :: Property
81+
prop_find_cycle_sound =
82+
forAllShrink (mkGraph @Node <$> arbitrary) shrink $ \ g ->
83+
and [ all (\(x, y) -> dependsOn x y g) (zip c (drop 1 c))
84+
| n <- Set.toList $ nodes g
85+
, let c = findCycle g n
86+
]
87+
88+
prop_find_cycle_loops :: Property
89+
prop_find_cycle_loops =
90+
forAllShrink (mkGraph @Node <$> arbitrary) shrink $ \ g ->
91+
conjoin
92+
[ case findCycle g n of
93+
[] -> property True
94+
c@(x:_) -> cover 40 True "found cycle" $ counterexample (show c) $ dependsOn (last c) x g
95+
| n <- Set.toList $ nodes g
96+
]
97+
98+
tests :: Bool -> Spec
99+
tests _nightly =
100+
describe "Graph tests" $ do
101+
prop "prop_arbitrary_reasonable_distribution" $ checkCoverage $ prop_arbitrary_reasonable_distribution
102+
prop "prop_no_dependencies_topsort" $ checkCoverage $ prop_no_dependencies_topsort
103+
prop "prop_subtract_topsort" $ checkCoverage $ prop_subtract_topsort
104+
prop "prop_delete_topsort" $ checkCoverage $ prop_delete_topsort
105+
prop "prop_op_topsort" $ checkCoverage $ prop_op_topsort
106+
prop "prop_trC_topsort" $ checkCoverage $ prop_trC_topsort
107+
prop "prop_trC_opgraph_commute" $ checkCoverage $ prop_trC_opgraph_commute
108+
prop "prop_depends_grows" $ checkCoverage $ prop_depends_grows
109+
prop "prop_topsort_all_nodes" $ checkCoverage $ prop_topsort_all_nodes
110+
prop "prop_topsort_sound" $ checkCoverage $ prop_topsort_sound
111+
prop "prop_topsort_complete" $ checkCoverage $ prop_topsort_complete
112+
prop "prop_find_cycle_sound" $ checkCoverage $ prop_find_cycle_sound
113+
prop "prop_find_cycle_loops" $ checkCoverage $ prop_find_cycle_loops
114+
115+
runTests :: IO ()
116+
runTests = hspec $ tests False

‎test/Tests.hs‎

Lines changed: 5 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,11 +1,14 @@
11
module Main where
22

3-
import Constrained.Tests
3+
import Constrained.Tests as Tests
4+
import Constrained.GraphSpec as Graph
45
import Data.Maybe
56
import System.Environment
67
import Test.Hspec
78

89
main :: IO ()
910
main = do
1011
nightly <- isJust <$> lookupEnv "NIGHTLY"
11-
hspec $ tests nightly
12+
hspec $ do
13+
Tests.tests nightly
14+
Graph.tests nightly

0 commit comments

Comments
 (0)