Property-based tests for Constrained.Graph

constrained-generators.cabal

@@ -79,7 +79,7 @@ library
     -Wunused-packages
 
   build-depends:
-    QuickCheck >=2.14 && <2.18,
+    QuickCheck >=2.15.0.1 && <2.18,
     base >=4.18 && <5,
     base-orphans,
     containers,
@@ -114,7 +114,7 @@ library examples
     -Wunused-packages
 
   build-depends:
-    QuickCheck >=2.14,
+    QuickCheck >=2.15.0.1,
     base >=4.18 && <5,
     constrained-generators,
     containers,
@@ -125,7 +125,9 @@ test-suite constrained-tests
   type: exitcode-stdio-1.0
   main-is: Tests.hs
   hs-source-dirs: test
-  other-modules: Constrained.Tests
+  other-modules:
+    Constrained.Tests
+    Constrained.GraphSpec
   default-language: Haskell2010
   ghc-options:
     -Wall
@@ -138,7 +140,7 @@ test-suite constrained-tests
     -rtsopts
 
   build-depends:
-    QuickCheck,
+    QuickCheck >= 2.15.0.1,
     base,
     constrained-generators,
     containers,

src/Constrained/Graph.hs

@@ -5,7 +5,10 @@
 -- | This module provides a dependency graph implementation.
 module Constrained.Graph (
   Graph,
+  edges,
+  opEdges,
   opGraph,
+  mkGraph,
   nodes,
   deleteNode,
   subtractGraph,
@@ -22,20 +25,21 @@ module Constrained.Graph (
 
 import Control.Monad
 import Data.Foldable
-import Data.List (sortOn)
+import Data.List (sortOn, 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)
+  deriving (Show, Eq)
 
 instance Ord node => Semigroup (Graph node) where
   Graph e o <> Graph e' o' =
@@ -55,6 +59,37 @@ instance Pretty n => Pretty (Graph n) where
         | (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
@@ -102,11 +137,12 @@ irreflexiveDependencyOn xs ys =
 
 -- | Get all down-stream dependencies of a node
 transitiveDependencies :: Ord node => node -> Graph node -> Set node
-transitiveDependencies x (Graph e _) = go (Set.singleton x) x
+transitiveDependencies x (Graph e _) = go mempty (Set.toList $ fromMaybe mempty $ Map.lookup x e)
   where
-    go seen y = ys <> foldMap (go $ Set.insert y seen) (Set.difference ys seen)
-      where
-        ys = fromMaybe mempty (Map.lookup y e)
+    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
@@ -133,10 +169,11 @@ topsort gr@(Graph e _) = go [] e
             else Left . concat . take 1 . sortOn length . filter (not . null) . map (findCycle gr) $ Map.keys e
 
 -- | Simple DFS cycle finding
--- TODO: tests for this, currently it can produce a stem with a cycle after it
 findCycle :: Ord node => Graph node -> node -> [node]
-findCycle (Graph e _) node = concat . take 1 $ go mempty node
+findCycle g@(Graph e _) node = concat . take 1 $ filter loopy $ go mempty node
   where
+    loopy [] = False
+    loopy c@(x:_) = dependsOn (last c) x g
     go seen n
       | n `Set.member` seen = [[]]
       | otherwise = do

stack.yaml

@@ -2,3 +2,5 @@ snapshot: lts-22.44
 packages:
 - .
 system-ghc: true
+extra-deps:
+- QuickCheck-2.15.0.1

stack.yaml.lock

@@ -3,7 +3,14 @@
 # For more information, please see the documentation at:
 #   https://docs.haskellstack.org/en/stable/topics/lock_files
 
-packages: []
+packages:
+- completed:
+    hackage: QuickCheck-2.15.0.1@sha256:0cfd337bb9e6fbf09255bd24bb498a156f1d9bcd465396ac8657b25034b9ee31,9046
+    pantry-tree:
+      sha256: 27dddf0b64cc7d7e154326059c89b70da61530c25623af7ef576dd9db0c53821
+      size: 2437
+  original:
+    hackage: QuickCheck-2.15.0.1
 snapshots:
 - completed:
     sha256: 238fa745b64f91184f9aa518fe04bdde6552533d169b0da5256670df83a0f1a9

test/Constrained/GraphSpec.hs

@@ -0,0 +1,118 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE DerivingVia #-}
+module Constrained.GraphSpec where
+
+import Data.Either
+import Constrained.Graph
+import Data.Set (Set)
+import Data.Set qualified as Set
+import Test.Hspec
+import Test.Hspec.QuickCheck
+import Test.QuickCheck
+
+newtype Node = Node Int
+  deriving (Ord, Eq)
+  deriving Show via Int
+
+instance Arbitrary Node where
+  arbitrary = Node <$> choose (0, 20)
+  shrink (Node n) = Node <$> shrink n
+
+prop_arbitrary_reasonable_distribution :: Graph Node -> Property
+prop_arbitrary_reasonable_distribution g =
+  cover 60 (isRight $ topsort g) "has topsort" True
+
+prop_no_dependencies_topsort :: Set Node -> Property
+prop_no_dependencies_topsort = property . isRight . topsort . noDependencies
+
+prop_subtract_topsort :: Graph Node -> Graph Node -> Property
+prop_subtract_topsort g g' =
+  isRight (topsort g) ==>
+    isRight (topsort $ subtractGraph g g')
+
+prop_subtract_union :: Graph Node -> Graph Node -> Property
+prop_subtract_union g g0' =
+  let g' = subtractGraph g g0'
+  in subtractGraph g g' <> g' === g
+
+prop_subtract_keeps_nodes :: Graph Node -> Graph Node -> Property
+prop_subtract_keeps_nodes g g' = nodes (subtractGraph g g') === nodes g
+
+prop_subtract_removes_edges :: Graph Node -> Graph Node -> Node -> Node -> Property
+prop_subtract_removes_edges g g' x y =
+  property $ not (dependsOn x y (subtractGraph g $ dependency x (Set.singleton y) <> g'))
+
+prop_union_commutes :: Graph Node -> Graph Node -> Property
+prop_union_commutes g g' = g <> g' === g' <> g
+
+prop_delete_topsort :: Graph Node -> Node -> Property
+prop_delete_topsort g n =
+  isRight (topsort g) ==>
+    isRight (topsort $ deleteNode n g)
+
+prop_op_topsort :: Graph Node -> Property
+prop_op_topsort g =
+  isRight (topsort g) === isRight (topsort $ opGraph g)
+
+prop_trC_topsort :: Graph Node -> Property
+prop_trC_topsort g =
+  isRight (topsort g) === isRight (topsort $ transitiveClosure g)
+
+prop_trC_opgraph_commute :: Graph Node -> Property
+prop_trC_opgraph_commute g =
+  transitiveClosure (opGraph g) === opGraph (transitiveClosure g)
+
+prop_depends_grows :: Graph Node -> Graph Node -> Node -> Property
+prop_depends_grows g g' n = property $ dependencies n g `Set.isSubsetOf` dependencies n (g <> g')
+
+prop_transitive_dependencies :: Graph Node -> Node -> Property
+prop_transitive_dependencies g n =
+  transitiveDependencies n g === dependencies n (transitiveClosure g)
+
+prop_topsort_all_nodes :: Graph Node -> Property
+prop_topsort_all_nodes g =
+  case topsort g of
+    Left{} -> discard
+    Right o -> Set.fromList o === nodes g
+
+prop_topsort_sound :: Graph Node -> Property
+prop_topsort_sound g =
+  case topsort g of
+    Left{} -> discard
+    Right o -> property $ go o
+  where
+    go [] = True
+    go (n : ns) = all (\n' -> not $ dependsOn n n' g) ns && go ns
+
+prop_topsort_complete :: Graph Node -> Property
+prop_topsort_complete g =
+  isLeft (topsort g) === any (\ n -> not . null $ findCycle g n) (nodes g)
+
+prop_find_cycle_sound :: Property
+prop_find_cycle_sound =
+  forAllShrink (mkGraph @Node <$> arbitrary) shrink $ \ g ->
+    and [ all (\(x, y) -> dependsOn x y g) (zip c (drop 1 c))
+        | n <- Set.toList $ nodes g
+        , let c = findCycle g n
+        ]
+
+prop_find_cycle_loops :: Property
+prop_find_cycle_loops =
+  forAllShrink (mkGraph @Node <$> arbitrary) shrink $ \ g ->
+    conjoin
+      [ case findCycle g n of
+          [] -> property True
+          c@(x:_) -> cover 40 True "found cycle" $ counterexample (show c) $ dependsOn (last c) x g
+      | n <- Set.toList $ nodes g
+      ]
+
+return []
+
+tests :: Bool -> Spec
+tests _nightly =
+  describe "Graph tests" $ sequence_ [ prop n (checkCoverage $ withMaxSuccess 1000 p) | (n, p) <- $allProperties ]

test/Tests.hs

@@ -1,11 +1,14 @@
 module Main where
 
-import Constrained.Tests
+import Constrained.Tests as Tests
+import Constrained.GraphSpec as Graph
 import Data.Maybe
 import System.Environment
 import Test.Hspec
 
 main :: IO ()
 main = do
   nightly <- isJust <$> lookupEnv "NIGHTLY"
-  hspec $ tests nightly
+  hspec $ do
+    Tests.tests nightly
+    Graph.tests nightly