initial stab at property tests for Constrained.Graph

Author: MaximilianAlgehed

constrained-generators.cabal

@@ -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

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,
@@ -29,13 +32,14 @@ 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,28 @@ 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
+  -- TODO: very high % of these graphs don't topsort nicely
+  arbitrary = mkGraph <$> arbitrary
+  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

test/Constrained/GraphSpec.hs

@@ -0,0 +1,82 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# 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_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_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 =
+  within 1_000_000 $ isRight (topsort g) === isRight (topsort $ transitiveClosure g)
+
+prop_trC_opgraph_commute :: Graph Node -> Property
+prop_trC_opgraph_commute g =
+  within 1_000_000 $ 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 =
+  within 1_000_000 $ 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
+
+tests :: Bool -> Spec
+tests _nightly =
+  describe "Graph tests" $ do
+    prop "prop_no_dependencies_topsort" prop_no_dependencies_topsort
+    prop "prop_subtract_topsort"        prop_subtract_topsort
+    prop "prop_delete_topsort"          prop_delete_topsort
+    prop "prop_op_topsort"              prop_op_topsort
+    prop "prop_trC_topsort"             prop_trC_topsort
+    prop "prop_trC_opgraph_commute"     prop_trC_opgraph_commute
+    prop "prop_depends_grows"           prop_depends_grows
+    prop "prop_topsort_all_nodes"       prop_topsort_all_nodes
+    prop "prop_topsort_sound"           prop_topsort_sound

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