p2p-governor: improve the Script shrinker

Rather than using a general shrinker for NonEmpty lists, we use a
specific one. We can take advantage of the property that the scripts are
executed in order, so if an error occurs, only script actions performed
before the error are relevant.

This means we can shrink from the back to the front, rather than trying
deleting arbitrary elements, and we be a bit more agressive with
shrinking by bigger jumps.

Since these scripts are used in several places in the governor mock
environemtn, this change makes a fairly substantial improvement to the
number of shrinking steps.

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

@@ -13,8 +13,6 @@ module Test.Ouroboros.Network.PeerSelection.Instances (
 
   ) where
 
-import           Data.List.NonEmpty (NonEmpty (..))
-import qualified Data.List.NonEmpty as NonEmpty
 
 import           Ouroboros.Network.PeerSelection.Governor
 import           Ouroboros.Network.PeerSelection.Types
@@ -40,17 +38,6 @@ instance Arbitrary PeerAddr where
   shrink _  = []
 
 
-instance Arbitrary a => Arbitrary (NonEmpty a) where
-  arbitrary = NonEmpty.fromList <$> listOf1 arbitrary
-
-  shrink = shrinkMap from to
-    where
-      to :: NonEmpty a -> NonEmptyList a
-      to xs = NonEmpty (NonEmpty.toList xs)
-
-      from :: NonEmptyList a -> NonEmpty a
-      from (NonEmpty xs) = NonEmpty.fromList xs
-
 
 instance Arbitrary PeerAdvertise where
   arbitrary = elements [ DoAdvertisePeer, DoNotAdvertisePeer ]

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

@@ -35,6 +35,7 @@ import           Control.Monad.Class.MonadTimer
 import           Test.Ouroboros.Network.PeerSelection.Instances ()
 
 import           Test.QuickCheck
+import           Test.QuickCheck.Utils
 
 
 --
@@ -43,7 +44,6 @@ import           Test.QuickCheck
 
 newtype Script a = Script (NonEmpty a)
   deriving (Eq, Show, Functor, Foldable, Traversable)
-  deriving Arbitrary via NonEmpty a
 
 singletonScript :: a -> Script a
 singletonScript x = (Script (x :| []))
@@ -70,6 +70,20 @@ stepScriptSTM scriptVar = do
       x':xs' -> writeTVar scriptVar (Script (x' :| xs'))
     return x
 
+instance Arbitrary a => Arbitrary (Script a) where
+    arbitrary = (Script . NonEmpty.fromList) <$> listOf1 arbitrary
+
+    shrink (Script (x :| [])) = [ Script (x' :| []) | x' <- shrink x ]
+    shrink (Script (x :| xs)) =
+        Script (x :| [])                          -- drop whole tail
+      : Script (x :| take (length xs `div` 2) xs) -- drop half the tail
+      : Script (x :| init xs)                     -- drop only last
+
+        -- drop none, shrink only elements
+      : [ Script (x' :| xs) | x'  <- shrink x ]
+     ++ [ Script (x :| xs') | xs' <- shrinkListElems shrink xs ]
+
+
 --
 -- Timed scripts
 --

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

@@ -3,12 +3,25 @@
 --
 module Test.QuickCheck.Utils (
 
+    -- * Generator and shrinker utils
+    shrinkListElems,
+
     -- * Reporting utils
     renderRanges,
 
   ) where
 
 
+-- | Like 'shrinkList' but only shrink the elems, don't drop elements.
+--
+-- Useful when you want a custom strategy for dropping elements.
+--
+shrinkListElems :: (a -> [a]) -> [a] -> [[a]]
+shrinkListElems _   []     = []
+shrinkListElems shr (x:xs) = [ x':xs | x'  <- shr x ]
+                          ++ [ x:xs' | xs' <- shrinkListElems shr xs ]
+
+
 -- | Use in 'tabulate' to help summarise data into buckets.
 --
 renderRanges :: Int -> Int -> String