Skip to content

Commit c4df1f0

Browse files
MaximilianAlgehedMaximilianAlgehed
authored
Merge branch 'master' into dead-code
2 parents 18b4fd2 + 417ac9f commit c4df1f0

File tree

7 files changed

+187
-15
lines changed

7 files changed

+187
-15
lines changed

‎README.md‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,2 +1,5 @@
1+
12
# constrained-generators
3+
[![Coverage Status](https://coveralls.io/repos/github/input-output-hk/constrained-generators/badge.svg?branch=master)](https://coveralls.io/github/input-output-hk/constrained-generators?branch=master)
4+
25
Framework for generating constrained random data using a subset of first order logic

‎constrained-generators.cabal‎

Lines changed: 6 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -79,7 +79,7 @@ library
7979
-Wunused-packages
8080

8181
build-depends:
82-
QuickCheck >=2.14 && <2.18,
82+
QuickCheck >=2.15.0.1 && <2.18,
8383
base >=4.18 && <5,
8484
base-orphans,
8585
containers,
@@ -114,7 +114,7 @@ library examples
114114
-Wunused-packages
115115

116116
build-depends:
117-
QuickCheck >=2.14,
117+
QuickCheck >=2.15.0.1,
118118
base >=4.18 && <5,
119119
constrained-generators,
120120
containers,
@@ -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
@@ -138,7 +140,7 @@ test-suite constrained-tests
138140
-rtsopts
139141

140142
build-depends:
141-
QuickCheck,
143+
QuickCheck >= 2.15.0.1,
142144
base,
143145
constrained-generators,
144146
containers,

‎src/Constrained/Graph.hs‎

Lines changed: 45 additions & 8 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
@@ -133,10 +169,11 @@ topsort gr@(Graph e _) = go [] e
133169
else Left . concat . take 1 . sortOn length . filter (not . null) . map (findCycle gr) $ Map.keys e
134170

135171
-- | Simple DFS cycle finding
136-
-- TODO: tests for this, currently it can produce a stem with a cycle after it
137172
findCycle :: Ord node => Graph node -> node -> [node]
138-
findCycle (Graph e _) node = concat . take 1 $ go mempty node
173+
findCycle g@(Graph e _) node = concat . take 1 $ filter loopy $ go mempty node
139174
where
175+
loopy [] = False
176+
loopy c@(x:_) = dependsOn (last c) x g
140177
go seen n
141178
| n `Set.member` seen = [[]]
142179
| otherwise = do

‎stack.yaml‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2,3 +2,5 @@ snapshot: lts-22.44
22
packages:
33
- .
44
system-ghc: true
5+
extra-deps:
6+
- QuickCheck-2.15.0.1

‎stack.yaml.lock‎

Lines changed: 8 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -3,7 +3,14 @@
33
# For more information, please see the documentation at:
44
# https://docs.haskellstack.org/en/stable/topics/lock_files
55

6-
packages: []
6+
packages:
7+
- completed:
8+
hackage: QuickCheck-2.15.0.1@sha256:0cfd337bb9e6fbf09255bd24bb498a156f1d9bcd465396ac8657b25034b9ee31,9046
9+
pantry-tree:
10+
sha256: 27dddf0b64cc7d7e154326059c89b70da61530c25623af7ef576dd9db0c53821
11+
size: 2437
12+
original:
13+
hackage: QuickCheck-2.15.0.1
714
snapshots:
815
- completed:
916
sha256: 238fa745b64f91184f9aa518fe04bdde6552533d169b0da5256670df83a0f1a9

‎test/Constrained/GraphSpec.hs‎

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

‎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)