Extend the shrinker tests: test that the shrinkers shrink!

Some shrinkers are tricky. One easy mistake is that a shrinker does not
return a smaller value. This will likely cause the shrinking to cycle
indefinately, which is annoying when you're trying to track down a
failing test case!

To do this properly would require an appropriate measure of size (which
is specific to the shinker, not an existing notion of size). This is
possible but needs quite a bit of additional infrastructure. We take a
short cut by observing that most shrinker bugs are simple 1-cycles where
the "shrunk" value is actually equal to the original. If we only detect
these cases we should still get most of these bugs. This has the
important advantage of only relying on equality and not on a size
measure, so no extra infrastructure per type is needed.

So we simply add: prop_shrink_nonequal = all (x /=) (shrink x)

And we use that in existing shrinker tests (where we already check that
invariants are preserved), and add shrinker tests for some types that
did not have them already.

In particular this test still catches the GovernorScripts bug that we
had previously.

ouroboros-network/test/Test/Ouroboros/Network/PeerSelection/Instances.hs

@@ -18,6 +18,7 @@ import           Ouroboros.Network.PeerSelection.Governor
 import           Ouroboros.Network.PeerSelection.Types
 
 import           Test.QuickCheck
+import           Test.QuickCheck.Utils
 
 
 --
@@ -70,7 +71,8 @@ prop_arbitrary_PeerSelectionTargets :: PeerSelectionTargets -> Bool
 prop_arbitrary_PeerSelectionTargets =
     sanePeerSelectionTargets
 
-prop_shrink_PeerSelectionTargets :: PeerSelectionTargets -> Bool
-prop_shrink_PeerSelectionTargets =
-    all sanePeerSelectionTargets . shrink
+prop_shrink_PeerSelectionTargets :: Fixed PeerSelectionTargets -> Property
+prop_shrink_PeerSelectionTargets x =
+      prop_shrink_valid sanePeerSelectionTargets x
+ .&&. prop_shrink_nonequal x
 

ouroboros-network/test/Test/Ouroboros/Network/PeerSelection/LocalRootPeers.hs

@@ -115,9 +115,10 @@ prop_arbitrary_LocalRootPeers lrps =
                  | (t, g) <- LocalRootPeers.toGroupSets lrps ]
 
 
-prop_shrink_LocalRootPeers :: LocalRootPeers PeerAddr -> Bool
-prop_shrink_LocalRootPeers =
-    all LocalRootPeers.invariant . shrink
+prop_shrink_LocalRootPeers :: Fixed (LocalRootPeers PeerAddr) -> Property
+prop_shrink_LocalRootPeers x =
+      prop_shrink_valid LocalRootPeers.invariant x
+ .&&. prop_shrink_nonequal x
 
 prop_fromGroups :: [(Int, Map PeerAddr PeerAdvertise)] -> Bool
 prop_fromGroups = LocalRootPeers.invariant . LocalRootPeers.fromGroups

ouroboros-network/test/Test/Ouroboros/Network/PeerSelection/MockEnvironment.hs

@@ -73,7 +73,9 @@ import           Test.Tasty.QuickCheck (QuickCheckMaxSize (..), testProperty)
 tests :: TestTree
 tests =
   testGroup "Mock environment"
-    [ testProperty "arbitrary for PeerSelectionTargets"    prop_arbitrary_PeerSelectionTargets
+    [ testProperty "shrink for Script"                     prop_shrink_Script
+    , testProperty "shrink for GovernorScripts"            prop_shrink_GovernorScripts
+    , testProperty "arbitrary for PeerSelectionTargets"    prop_arbitrary_PeerSelectionTargets
     , testProperty "shrink for PeerSelectionTargets"       prop_shrink_PeerSelectionTargets
     , testProperty "arbitrary for PeerGraph"               prop_arbitrary_PeerGraph
     , localOption (QuickCheckMaxSize 30) $
@@ -107,7 +109,7 @@ data GovernorMockEnvironment = GovernorMockEnvironment {
        pickWarmPeersToDemote   :: PickScript PeerAddr,
        pickColdPeersToForget   :: PickScript PeerAddr
      }
-  deriving Show
+  deriving (Show, Eq)
 
 data PeerConn m = PeerConn !PeerAddr !(TVar m PeerStatus)
 
@@ -554,7 +556,8 @@ prop_arbitrary_GovernorMockEnvironment env =
           (LocalRootPeers.keysSet (localRootPeers env))
           (publicRootPeers env)
 
-prop_shrink_GovernorMockEnvironment :: GovernorMockEnvironment -> Bool
-prop_shrink_GovernorMockEnvironment =
-    all validGovernorMockEnvironment . shrink
+prop_shrink_GovernorMockEnvironment :: Fixed GovernorMockEnvironment -> Property
+prop_shrink_GovernorMockEnvironment x =
+      prop_shrink_valid validGovernorMockEnvironment x
+ .&&. prop_shrink_nonequal x
 

ouroboros-network/test/Test/Ouroboros/Network/PeerSelection/PeerGraph.hs

@@ -17,6 +17,7 @@ module Test.Ouroboros.Network.PeerSelection.PeerGraph (
     GossipTime,
     interpretGossipTime,
 
+    prop_shrink_GovernorScripts,
     prop_arbitrary_PeerGraph,
     prop_shrink_PeerGraph,
 
@@ -313,6 +314,10 @@ instance Arbitrary GossipTime where
 -- Tests for the QC Arbitrary instances
 --
 
+prop_shrink_GovernorScripts :: Fixed GovernorScripts -> Property
+prop_shrink_GovernorScripts =
+    prop_shrink_nonequal
+
 prop_arbitrary_PeerGraph :: PeerGraph -> Property
 prop_arbitrary_PeerGraph pg =
     -- We are interested in the distribution of the graph size (in nodes)
@@ -341,7 +346,8 @@ peerGraphNumStronglyConnectedComponents pg =
   where
     (g,_,_) = peerGraphAsGraph pg
 
-prop_shrink_PeerGraph :: PeerGraph -> Bool
-prop_shrink_PeerGraph =
-    all validPeerGraph . shrink
+prop_shrink_PeerGraph :: Fixed PeerGraph -> Property
+prop_shrink_PeerGraph x =
+      prop_shrink_valid validPeerGraph x
+ .&&. prop_shrink_nonequal x
 

ouroboros-network/test/Test/Ouroboros/Network/PeerSelection/Script.hs

@@ -11,6 +11,7 @@ module Test.Ouroboros.Network.PeerSelection.Script (
     stepScript,
     stepScriptSTM,
     arbitraryScriptOf,
+    prop_shrink_Script,
 
     -- * Timed scripts
     ScriptDelay(..),
@@ -190,3 +191,11 @@ interpretPickMembers (PickSome as) ps n
   where
     ps' = Set.intersection ps as
 
+
+--
+-- Tests for the QC Arbitrary instances
+--
+
+prop_shrink_Script :: Fixed (Script Int) -> Property
+prop_shrink_Script = prop_shrink_nonequal
+

ouroboros-network/test/Test/QuickCheck/Utils.hs

@@ -6,6 +6,8 @@ module Test.QuickCheck.Utils (
     -- * Generator and shrinker utils
     arbitrarySubset,
     shrinkListElems,
+    prop_shrink_valid,
+    prop_shrink_nonequal,
 
     -- * Reporting utils
     renderRanges,
@@ -41,6 +43,35 @@ shrinkListElems shr (x:xs) = [ x':xs | x'  <- shr x ]
                           ++ [ x:xs' | xs' <- shrinkListElems shr xs ]
 
 
+-- | Check that each shrink satisfies some invariant or validity condition.
+--
+prop_shrink_valid :: (Arbitrary a, Eq a, Show a)
+                  => (a -> Bool) -> Fixed a -> Property
+prop_shrink_valid valid (Fixed x) =
+    let invalid = [ x' | x' <- shrink x, not (valid x') ]
+     in case invalid of
+          []     -> property True
+          (x':_) -> counterexample ("shrink result invalid:\n" ++ show x') $
+                    property False
+
+
+-- | The 'shrink' function needs to give a valid value that is /smaller/ than
+-- the original, otherwise the shrinking procedure is not well-founded and can
+-- cycle.
+--
+-- This property does not check size, as that would need significant extra
+-- infrastructure to define an appropriate measure. Instead this property
+-- simply checks each shrink is not the same as the original. This catches
+-- simple 1-cycles, but not bigger cycles. These are fortunately the most
+-- common case, so it is still a useful property in practice.
+--
+prop_shrink_nonequal :: (Arbitrary a, Eq a) => Fixed a -> Property
+prop_shrink_nonequal (Fixed x) =
+    counterexample "A shrink result equals as the original.\n" $
+    counterexample "This will cause non-termination for shrinking." $
+    all (x /=) (shrink x)
+
+
 -- | Use in 'tabulate' to help summarise data into buckets.
 --
 renderRanges :: Int -> Int -> String