Cabal-tests/tests/UnitTests/Distribution/Compat/Graph.hs

   1 {-# LANGUAGE PatternGuards #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# OPTIONS_GHC -fno-warn-orphans #-}
   4 module UnitTests.Distribution.Compat.Graph
   5     ( tests
   6     , arbitraryGraph
   7     ) where
   8
   9 import Distribution.Compat.Graph
  10
  11 import qualified Prelude
  12 import Prelude hiding (null)
  13 import Test.Tasty
  14 import Test.Tasty.QuickCheck
  15 import qualified Data.Set as Set
  16 import Control.Monad
  17 import qualified Data.Graph as G
  18 import Data.Array ((!))
  19 import Data.Maybe
  20 import Data.List (sort)
  21
  22 tests :: [TestTree]
  23 tests =
  24     [ testProperty "arbitrary unbroken" (prop_arbitrary_unbroken :: Graph (Node Int ()) -> Bool)
  25     , testProperty "nodes consistent" (prop_nodes_consistent :: Graph (Node Int ()) -> Bool)
  26     , testProperty "edges consistent" (prop_edges_consistent :: Graph (Node Int ()) -> Property)
  27     , testProperty "closure consistent" (prop_closure_consistent :: Graph (Node Int ()) -> Property)
  28     ]
  29
  30 -- Our arbitrary instance does not generate broken graphs
  31 prop_arbitrary_unbroken :: Graph a -> Bool
  32 prop_arbitrary_unbroken g = Prelude.null (broken g)
  33
  34 -- Every node from 'toList' maps to a vertex which
  35 -- is present in the constructed graph, and maps back
  36 -- to a node correctly.
  37 prop_nodes_consistent :: (Eq a, IsNode a) => Graph a -> Bool
  38 prop_nodes_consistent g = all p (toList g)
  39   where
  40     (_, vtn, ktv) = toGraph g
  41     p n = case ktv (nodeKey n) of
  42             Just v  -> vtn v == n
  43             Nothing -> False
  44
  45 -- A non-broken graph has the 'nodeNeighbors' of each node
  46 -- equal the recorded adjacent edges in the node graph.
  47 prop_edges_consistent :: IsNode a => Graph a -> Property
  48 prop_edges_consistent g = Prelude.null (broken g) ==> all p (toList g)
  49   where
  50     (gr, vtn, ktv) = toGraph g
  51     p n = sort (nodeNeighbors n)
  52        == sort (map (nodeKey . vtn) (gr ! fromJust (ktv (nodeKey n))))
  53
  54 -- Closure is consistent with reachable
  55 prop_closure_consistent :: (Show a, IsNode a) => Graph a -> Property
  56 prop_closure_consistent g =
  57     not (null g) ==>
  58     forAll (elements (toList g)) $ \n ->
  59            Set.fromList (map nodeKey (fromJust (closure g [nodeKey n])))
  60         == Set.fromList (map (nodeKey . vtn) (G.reachable gr (fromJust (ktv (nodeKey n)))))
  61   where
  62     (gr, vtn, ktv) = toGraph g
  63
  64 hasNoDups :: Ord a => [a] -> Bool
  65 hasNoDups = loop Set.empty
  66   where
  67     loop _ []       = True
  68     loop s (x:xs) | s' <- Set.insert x s, Set.size s' > Set.size s
  69                     = loop s' xs
  70                   | otherwise
  71                     = False
  72
  73 -- | Produces a graph of size @len@.  We sample with 'suchThat'; if we
  74 -- dropped duplicate entries our size could be smaller.
  75 arbitraryGraph :: (Ord k, Show k, Arbitrary k, Arbitrary a)
  76                => Int -> Gen (Graph (Node k a))
  77 arbitraryGraph len = do
  78     -- Careful! Assume k is much larger than size.
  79     ks <- vectorOf len arbitrary `suchThat` hasNoDups
  80     ns <- forM ks $ \k -> do
  81         a <- arbitrary
  82         ns <- listOf (elements ks)
  83         -- Allow duplicates!
  84         return (N a k ns)
  85     return (fromDistinctList ns)
  86
  87 instance (Ord k, Show k, Arbitrary k, Arbitrary a)
  88       => Arbitrary (Graph (Node k a)) where
  89     arbitrary = sized $ \n -> do
  90         len <- choose (0, n)
  91         arbitraryGraph len