diff --git a/constrained-generators.cabal b/constrained-generators.cabal index d3d1f7d..12abb81 100644 --- a/constrained-generators.cabal +++ b/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, diff --git a/src/Constrained/Graph.hs b/src/Constrained/Graph.hs index 402ff93..d8a9018 100644 --- a/src/Constrained/Graph.hs +++ b/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 diff --git a/stack.yaml b/stack.yaml index 01c0455..d8eeeeb 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,3 +2,5 @@ snapshot: lts-22.44 packages: - . system-ghc: true +extra-deps: +- QuickCheck-2.15.0.1 diff --git a/stack.yaml.lock b/stack.yaml.lock index 8d134eb..6d01407 100644 --- a/stack.yaml.lock +++ b/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 diff --git a/test/Constrained/GraphSpec.hs b/test/Constrained/GraphSpec.hs new file mode 100644 index 0000000..9c88a7a --- /dev/null +++ b/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 (dependency x (Set.singleton y) <> 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 ] diff --git a/test/Tests.hs b/test/Tests.hs index 09b5c14..beecbcf 100644 --- a/test/Tests.hs +++ b/test/Tests.hs @@ -1,6 +1,7 @@ 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 @@ -8,4 +9,6 @@ import Test.Hspec main :: IO () main = do nightly <- isJust <$> lookupEnv "NIGHTLY" - hspec $ tests nightly + hspec $ do + Tests.tests nightly + Graph.tests nightly