Change the PickScript to pick elements not offsets.

The previous representation of pick scripts used [Int], a list of
offsets to pick. These are offsets within the set that the governor
gives to us. This is nice in one sense, that it can be interpreted to
make sense irrespecive of what set the governor gives us. The downside
is that its shrinking behaviour is quite odd and hence poor. It is odd
because the modulo behaviour means the choices are highly unstable, and
that does not sit well with shrinking.

So we switch to an alternative representation where the pick script has
a set of elements that it wants to pick. We arrange to select this set
as an arbitrary subset of the total set of elements, which are the peers
in the graph in the mock environment.

The advantage of this is that the shrinking behaviour is much clearer.
The choices become stable as the other things are shrunk. The slight
downside is that the sets we get to pick from are chosen by the
governor at runtime, which can often be a small subset of the total
peers available in the graph. But for the script we have to pick the
subset up front. So to resolve this we need to pick quite large sets up
front so that the intersection between the set we generated, and the set
the governor asks us to pick from will frequently have a non-trivial
intersection. So the approach we take is to generate random subsets that
roughtly half the size of the total set.

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

@@ -65,6 +65,7 @@ import           Test.Ouroboros.Network.PeerSelection.LocalRootPeers
                    as LocalRootPeers hiding (tests)
 
 import           Test.QuickCheck
+import           Test.QuickCheck.Utils
 import           Test.Tasty (TestTree, localOption, testGroup)
 import           Test.Tasty.QuickCheck (QuickCheckMaxSize (..), testProperty)
 
@@ -99,12 +100,12 @@ data GovernorMockEnvironment = GovernorMockEnvironment {
        localRootPeers          :: LocalRootPeers PeerAddr,
        publicRootPeers         :: Set PeerAddr,
        targets                 :: TimedScript PeerSelectionTargets,
-       pickKnownPeersForGossip :: PickScript,
-       pickColdPeersToPromote  :: PickScript,
-       pickWarmPeersToPromote  :: PickScript,
-       pickHotPeersToDemote    :: PickScript,
-       pickWarmPeersToDemote   :: PickScript,
-       pickColdPeersToForget   :: PickScript
+       pickKnownPeersForGossip :: PickScript PeerAddr,
+       pickColdPeersToPromote  :: PickScript PeerAddr,
+       pickWarmPeersToPromote  :: PickScript PeerAddr,
+       pickHotPeersToDemote    :: PickScript PeerAddr,
+       pickWarmPeersToDemote   :: PickScript PeerAddr,
+       pickColdPeersToForget   :: PickScript PeerAddr
      }
   deriving Show
 
@@ -426,17 +427,20 @@ instance Arbitrary GovernorMockEnvironment where
   arbitrary = do
       -- Dependency of the root set on the graph
       peerGraph         <- arbitrary
+      let peersSet       = allPeers peerGraph
       (localRootPeers,
-       publicRootPeers) <- arbitraryRootPeers (allPeers peerGraph)
+       publicRootPeers) <- arbitraryRootPeers peersSet
 
       -- But the others are independent
       targets                 <- arbitrary
-      pickKnownPeersForGossip <- arbitrary
-      pickColdPeersToPromote  <- arbitrary
-      pickWarmPeersToPromote  <- arbitrary
-      pickHotPeersToDemote    <- arbitrary
-      pickWarmPeersToDemote   <- arbitrary
-      pickColdPeersToForget   <- arbitrary
+
+      let arbitrarySubsetOfPeers = arbitrarySubset peersSet
+      pickKnownPeersForGossip <- arbitraryPickScript arbitrarySubsetOfPeers
+      pickColdPeersToPromote  <- arbitraryPickScript arbitrarySubsetOfPeers
+      pickWarmPeersToPromote  <- arbitraryPickScript arbitrarySubsetOfPeers
+      pickHotPeersToDemote    <- arbitraryPickScript arbitrarySubsetOfPeers
+      pickWarmPeersToDemote   <- arbitraryPickScript arbitrarySubsetOfPeers
+      pickColdPeersToForget   <- arbitraryPickScript arbitrarySubsetOfPeers
       return GovernorMockEnvironment{..}
     where
       arbitraryRootPeers :: Set PeerAddr

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

@@ -19,7 +19,9 @@ module Test.Ouroboros.Network.PeerSelection.Script (
 
     -- * Pick scripts
     PickScript,
-    interpretPickScript
+    PickMembers(..),
+    arbitraryPickScript,
+    interpretPickScript,
 
   ) where
 
@@ -128,27 +130,39 @@ playTimedScript (Script ((x0,d0) :| script)) = do
 -- choices by their index (modulo the number of choices). This representation
 -- was chosen because it allows easy shrinking.
 --
-type PickScript = Script PickMembers
+type PickScript peeraddr = Script (PickMembers peeraddr)
 
-data PickMembers = PickFirst
-                 | PickAll
-                 | PickSome [Int]
+data PickMembers peeraddr = PickFirst
+                          | PickAll
+                          | PickSome (Set peeraddr)
   deriving (Eq, Show)
 
-instance Arbitrary PickMembers where
-    arbitrary = frequency [ (1, pure PickFirst)
-                          , (1, pure PickAll)
-                          , (2, PickSome <$> listOf1 arbitrarySizedNatural) ]
+instance (Arbitrary peeraddr, Ord peeraddr) =>
+         Arbitrary (PickMembers peeraddr) where
+    arbitrary = arbitraryPickMembers (Set.fromList <$> listOf1 arbitrary)
 
-    shrink (PickSome ixs) = PickAll
+    shrink (PickSome ixs) = PickFirst
+                          : PickAll
                           : [ PickSome ixs'
                             | ixs' <- shrink ixs
-                            , not (null ixs') ]
+                            , not (Set.null ixs') ]
     shrink PickAll        = [PickFirst]
     shrink PickFirst      = []
 
+arbitraryPickMembers :: Gen (Set peeraddr) -> Gen (PickMembers peeraddr)
+arbitraryPickMembers pickSome =
+    frequency [ (1, pure PickFirst)
+              , (1, pure PickAll)
+              , (2, PickSome <$> pickSome)
+              ]
+
+arbitraryPickScript :: Gen (Set peeraddr) -> Gen (PickScript peeraddr)
+arbitraryPickScript pickSome =
+    sized $ \sz ->
+      arbitraryScriptOf sz (arbitraryPickMembers pickSome)
+
 interpretPickScript :: (MonadSTMTx stm, Ord peeraddr)
-                    => TVar_ stm PickScript
+                    => TVar_ stm (PickScript peeraddr)
                     -> Set peeraddr
                     -> Int
                     -> stm (Set peeraddr)
@@ -166,14 +180,13 @@ interpretPickScript scriptVar available pickNum
        return (interpretPickMembers pickmembers available pickNum)
 
 interpretPickMembers :: Ord peeraddr
-                     => PickMembers -> Set peeraddr -> Int -> Set peeraddr
-interpretPickMembers PickFirst      ps _ = Set.singleton (Set.elemAt 0 ps)
-interpretPickMembers PickAll        ps n = Set.take n ps
-interpretPickMembers (PickSome ixs) ps n = pickMapKeys ps (take n ixs)
-
-pickMapKeys :: Ord a => Set a -> [Int] -> Set a
-pickMapKeys m ns =
-    Set.fromList (map pick ns)
+                     => PickMembers peeraddr
+                     -> Set peeraddr -> Int -> Set peeraddr
+interpretPickMembers PickFirst     ps _ = Set.singleton (Set.elemAt 0 ps)
+interpretPickMembers PickAll       ps n = Set.take n ps
+interpretPickMembers (PickSome as) ps n
+  | Set.null ps' = Set.singleton (Set.elemAt 0 ps)
+  | otherwise    = Set.take n ps'
   where
-    pick n = Set.elemAt i m where i = n `mod` Set.size m
+    ps' = Set.intersection ps as
 

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

@@ -4,13 +4,32 @@
 module Test.QuickCheck.Utils (
 
     -- * Generator and shrinker utils
+    arbitrarySubset,
     shrinkListElems,
 
     -- * Reporting utils
     renderRanges,
 
   ) where
 
+import           Data.Set (Set)
+import qualified Data.Set as Set
+
+import           Test.QuickCheck
+
+-- | Pick a subset of a set, using a 50:50 chance for each set element.
+--
+arbitrarySubset :: Ord a => Set a -> Gen (Set a)
+arbitrarySubset s = do
+    picks <- vectorOf (Set.size s) (arbitrary :: Gen Bool)
+    let s' = Set.fromList
+           . map snd
+           . filter fst
+           . zip picks
+           . Set.toList
+           $ s
+    return s'
+
 
 -- | Like 'shrinkList' but only shrink the elems, don't drop elements.
 --