{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingVia       #-}

module Ouroboros.Network.Testing.Data.Script
  ( -- * Test scripts
    Script (..)
  , NonEmpty (..)
  , scriptHead
  , singletonScript
  , initScript
  , stepScript
  , stepScriptSTM
  , initScript'
  , stepScript'
  , stepScriptSTM'
  , arbitraryScriptOf
  , prop_shrink_Script
    -- * Timed scripts
  , ScriptDelay (..)
  , TimedScript
  , playTimedScript
    -- * Pick scripts
  , PickScript
  , PickMembers (..)
  , arbitraryPickScript
  , interpretPickScript
  ) where

import           Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NonEmpty
import           Data.Set (Set)
import qualified Data.Set as Set

import           Control.Monad.Class.MonadAsync
import           Control.Monad.Class.MonadSTM
import qualified Control.Monad.Class.MonadSTM as LazySTM
import           Control.Monad.Class.MonadTimer
import           Control.Tracer (Tracer, traceWith)

import           Ouroboros.Network.Testing.Utils (prop_shrink_nonequal,
                     shrinkVector)
import           Test.QuickCheck

--
-- Test script abstraction
--

newtype Script a = Script (NonEmpty a)
  deriving (Script a -> Script a -> Bool
(Script a -> Script a -> Bool)
-> (Script a -> Script a -> Bool) -> Eq (Script a)
forall a. Eq a => Script a -> Script a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Script a -> Script a -> Bool
$c/= :: forall a. Eq a => Script a -> Script a -> Bool
== :: Script a -> Script a -> Bool
$c== :: forall a. Eq a => Script a -> Script a -> Bool
Eq, Int -> Script a -> ShowS
[Script a] -> ShowS
Script a -> String
(Int -> Script a -> ShowS)
-> (Script a -> String) -> ([Script a] -> ShowS) -> Show (Script a)
forall a. Show a => Int -> Script a -> ShowS
forall a. Show a => [Script a] -> ShowS
forall a. Show a => Script a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Script a] -> ShowS
$cshowList :: forall a. Show a => [Script a] -> ShowS
show :: Script a -> String
$cshow :: forall a. Show a => Script a -> String
showsPrec :: Int -> Script a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Script a -> ShowS
Show, a -> Script b -> Script a
(a -> b) -> Script a -> Script b
(forall a b. (a -> b) -> Script a -> Script b)
-> (forall a b. a -> Script b -> Script a) -> Functor Script
forall a b. a -> Script b -> Script a
forall a b. (a -> b) -> Script a -> Script b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Script b -> Script a
$c<$ :: forall a b. a -> Script b -> Script a
fmap :: (a -> b) -> Script a -> Script b
$cfmap :: forall a b. (a -> b) -> Script a -> Script b
Functor, Script a -> Bool
(a -> m) -> Script a -> m
(a -> b -> b) -> b -> Script a -> b
(forall m. Monoid m => Script m -> m)
-> (forall m a. Monoid m => (a -> m) -> Script a -> m)
-> (forall m a. Monoid m => (a -> m) -> Script a -> m)
-> (forall a b. (a -> b -> b) -> b -> Script a -> b)
-> (forall a b. (a -> b -> b) -> b -> Script a -> b)
-> (forall b a. (b -> a -> b) -> b -> Script a -> b)
-> (forall b a. (b -> a -> b) -> b -> Script a -> b)
-> (forall a. (a -> a -> a) -> Script a -> a)
-> (forall a. (a -> a -> a) -> Script a -> a)
-> (forall a. Script a -> [a])
-> (forall a. Script a -> Bool)
-> (forall a. Script a -> Int)
-> (forall a. Eq a => a -> Script a -> Bool)
-> (forall a. Ord a => Script a -> a)
-> (forall a. Ord a => Script a -> a)
-> (forall a. Num a => Script a -> a)
-> (forall a. Num a => Script a -> a)
-> Foldable Script
forall a. Eq a => a -> Script a -> Bool
forall a. Num a => Script a -> a
forall a. Ord a => Script a -> a
forall m. Monoid m => Script m -> m
forall a. Script a -> Bool
forall a. Script a -> Int
forall a. Script a -> [a]
forall a. (a -> a -> a) -> Script a -> a
forall m a. Monoid m => (a -> m) -> Script a -> m
forall b a. (b -> a -> b) -> b -> Script a -> b
forall a b. (a -> b -> b) -> b -> Script a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: Script a -> a
$cproduct :: forall a. Num a => Script a -> a
sum :: Script a -> a
$csum :: forall a. Num a => Script a -> a
minimum :: Script a -> a
$cminimum :: forall a. Ord a => Script a -> a
maximum :: Script a -> a
$cmaximum :: forall a. Ord a => Script a -> a
elem :: a -> Script a -> Bool
$celem :: forall a. Eq a => a -> Script a -> Bool
length :: Script a -> Int
$clength :: forall a. Script a -> Int
null :: Script a -> Bool
$cnull :: forall a. Script a -> Bool
toList :: Script a -> [a]
$ctoList :: forall a. Script a -> [a]
foldl1 :: (a -> a -> a) -> Script a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Script a -> a
foldr1 :: (a -> a -> a) -> Script a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Script a -> a
foldl' :: (b -> a -> b) -> b -> Script a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Script a -> b
foldl :: (b -> a -> b) -> b -> Script a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Script a -> b
foldr' :: (a -> b -> b) -> b -> Script a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Script a -> b
foldr :: (a -> b -> b) -> b -> Script a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Script a -> b
foldMap' :: (a -> m) -> Script a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Script a -> m
foldMap :: (a -> m) -> Script a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Script a -> m
fold :: Script m -> m
$cfold :: forall m. Monoid m => Script m -> m
Foldable, Functor Script
Foldable Script
Functor Script
-> Foldable Script
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> Script a -> f (Script b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Script (f a) -> f (Script a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Script a -> m (Script b))
-> (forall (m :: * -> *) a.
    Monad m =>
    Script (m a) -> m (Script a))
-> Traversable Script
(a -> f b) -> Script a -> f (Script b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Script (m a) -> m (Script a)
forall (f :: * -> *) a.
Applicative f =>
Script (f a) -> f (Script a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Script a -> m (Script b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Script a -> f (Script b)
sequence :: Script (m a) -> m (Script a)
$csequence :: forall (m :: * -> *) a. Monad m => Script (m a) -> m (Script a)
mapM :: (a -> m b) -> Script a -> m (Script b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Script a -> m (Script b)
sequenceA :: Script (f a) -> f (Script a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Script (f a) -> f (Script a)
traverse :: (a -> f b) -> Script a -> f (Script b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Script a -> f (Script b)
$cp2Traversable :: Foldable Script
$cp1Traversable :: Functor Script
Traversable)

singletonScript :: a -> Script a
singletonScript :: a -> Script a
singletonScript a
x = NonEmpty a -> Script a
forall a. NonEmpty a -> Script a
Script (a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [])

scriptHead :: Script a -> a
scriptHead :: Script a -> a
scriptHead (Script (a
x :| [a]
_)) = a
x

arbitraryScriptOf :: Int -> Gen a -> Gen (Script a)
arbitraryScriptOf :: Int -> Gen a -> Gen (Script a)
arbitraryScriptOf Int
maxSz Gen a
a =
    (Int -> Gen (Script a)) -> Gen (Script a)
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen (Script a)) -> Gen (Script a))
-> (Int -> Gen (Script a)) -> Gen (Script a)
forall a b. (a -> b) -> a -> b
$ \Int
sz -> do
      Int
n <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
maxSz Int
sz))
      NonEmpty a -> Script a
forall a. NonEmpty a -> Script a
Script (NonEmpty a -> Script a) -> ([a] -> NonEmpty a) -> [a] -> Script a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> NonEmpty a
forall a. [a] -> NonEmpty a
NonEmpty.fromList ([a] -> Script a) -> Gen [a] -> Gen (Script a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen a -> Gen [a]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
n Gen a
a

initScript :: MonadSTM m
            => Script a
            -> STM m (TVar m (Script a))
initScript :: Script a -> STM m (TVar m (Script a))
initScript = Script a -> STM m (TVar m (Script a))
forall (m :: * -> *) a. MonadSTM m => a -> STM m (TVar m a)
LazySTM.newTVar

stepScript :: MonadSTM m => TVar m (Script a) -> m a
stepScript :: TVar m (Script a) -> m a
stepScript TVar m (Script a)
scriptVar = STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (TVar m (Script a) -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m (Script a) -> STM m a
stepScriptSTM TVar m (Script a)
scriptVar)

stepScriptSTM :: MonadSTM m => TVar m (Script a) -> STM m a
stepScriptSTM :: TVar m (Script a) -> STM m a
stepScriptSTM TVar m (Script a)
scriptVar = do
    Script (a
x :| [a]
xs) <- TVar m (Script a) -> STM m (Script a)
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
LazySTM.readTVar TVar m (Script a)
scriptVar
    case [a]
xs of
      []     -> () -> STM m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      a
x':[a]
xs' -> TVar m (Script a) -> Script a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
LazySTM.writeTVar TVar m (Script a)
scriptVar (NonEmpty a -> Script a
forall a. NonEmpty a -> Script a
Script (a
x' a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
xs'))
    a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

initScript' :: MonadSTM m => Script a -> m (TVar m (Script a))
initScript' :: Script a -> m (TVar m (Script a))
initScript' = Script a -> m (TVar m (Script a))
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO

stepScript' :: MonadSTM m => TVar m (Script a) -> m a
stepScript' :: TVar m (Script a) -> m a
stepScript' TVar m (Script a)
scriptVar = STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (TVar m (Script a) -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m (Script a) -> STM m a
stepScriptSTM TVar m (Script a)
scriptVar)

stepScriptSTM' :: MonadSTM m => TVar m (Script a) -> STM m a
stepScriptSTM' :: TVar m (Script a) -> STM m a
stepScriptSTM' TVar m (Script a)
scriptVar = do
    Script (a
x :| [a]
xs) <- TVar m (Script a) -> STM m (Script a)
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m (Script a)
scriptVar
    case [a]
xs of
      []     -> () -> STM m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      a
x':[a]
xs' -> TVar m (Script a) -> Script a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (Script a)
scriptVar (NonEmpty a -> Script a
forall a. NonEmpty a -> Script a
Script (a
x' a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
xs'))
    a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

instance Arbitrary a => Arbitrary (Script a) where
    arbitrary :: Gen (Script a)
arbitrary = (Int -> Gen (Script a)) -> Gen (Script a)
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen (Script a)) -> Gen (Script a))
-> (Int -> Gen (Script a)) -> Gen (Script a)
forall a b. (a -> b) -> a -> b
$ \Int
sz -> Int -> Gen a -> Gen (Script a)
forall a. Int -> Gen a -> Gen (Script a)
arbitraryScriptOf Int
sz Gen a
forall a. Arbitrary a => Gen a
arbitrary

    shrink :: Script a -> [Script a]
shrink (Script (a
x :| [])) = [ NonEmpty a -> Script a
forall a. NonEmpty a -> Script a
Script (a
x' a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| []) | a
x' <- a -> [a]
forall a. Arbitrary a => a -> [a]
shrink a
x ]
    shrink (Script (a
x :| [a]
xs)) =
        NonEmpty a -> Script a
forall a. NonEmpty a -> Script a
Script (a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [])                          -- drop whole tail
      Script a -> [Script a] -> [Script a]
forall a. a -> [a] -> [a]
: NonEmpty a -> Script a
forall a. NonEmpty a -> Script a
Script (a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) [a]
xs) -- drop half the tail
      Script a -> [Script a] -> [Script a]
forall a. a -> [a] -> [a]
: NonEmpty a -> Script a
forall a. NonEmpty a -> Script a
Script (a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a] -> [a]
forall a. [a] -> [a]
init [a]
xs)                     -- drop only last

        -- drop none, shrink only elements
      Script a -> [Script a] -> [Script a]
forall a. a -> [a] -> [a]
: [ NonEmpty a -> Script a
forall a. NonEmpty a -> Script a
Script (a
x' a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
xs) | a
x'  <- a -> [a]
forall a. Arbitrary a => a -> [a]
shrink a
x ]
     [Script a] -> [Script a] -> [Script a]
forall a. [a] -> [a] -> [a]
++ [ NonEmpty a -> Script a
forall a. NonEmpty a -> Script a
Script (a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
xs') | [a]
xs' <- (a -> [a]) -> [a] -> [[a]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkVector a -> [a]
forall a. Arbitrary a => a -> [a]
shrink [a]
xs ]


--
-- Timed scripts
--

type TimedScript a = Script (a, ScriptDelay)

data ScriptDelay = NoDelay | ShortDelay | LongDelay
  deriving (ScriptDelay -> ScriptDelay -> Bool
(ScriptDelay -> ScriptDelay -> Bool)
-> (ScriptDelay -> ScriptDelay -> Bool) -> Eq ScriptDelay
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ScriptDelay -> ScriptDelay -> Bool
$c/= :: ScriptDelay -> ScriptDelay -> Bool
== :: ScriptDelay -> ScriptDelay -> Bool
$c== :: ScriptDelay -> ScriptDelay -> Bool
Eq, Int -> ScriptDelay -> ShowS
[ScriptDelay] -> ShowS
ScriptDelay -> String
(Int -> ScriptDelay -> ShowS)
-> (ScriptDelay -> String)
-> ([ScriptDelay] -> ShowS)
-> Show ScriptDelay
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ScriptDelay] -> ShowS
$cshowList :: [ScriptDelay] -> ShowS
show :: ScriptDelay -> String
$cshow :: ScriptDelay -> String
showsPrec :: Int -> ScriptDelay -> ShowS
$cshowsPrec :: Int -> ScriptDelay -> ShowS
Show)

instance Arbitrary ScriptDelay where
  arbitrary :: Gen ScriptDelay
arbitrary = [(Int, Gen ScriptDelay)] -> Gen ScriptDelay
forall a. [(Int, Gen a)] -> Gen a
frequency [ (Int
1, ScriptDelay -> Gen ScriptDelay
forall (f :: * -> *) a. Applicative f => a -> f a
pure ScriptDelay
NoDelay)
                        , (Int
1, ScriptDelay -> Gen ScriptDelay
forall (f :: * -> *) a. Applicative f => a -> f a
pure ScriptDelay
ShortDelay)
                        , (Int
4, ScriptDelay -> Gen ScriptDelay
forall (f :: * -> *) a. Applicative f => a -> f a
pure ScriptDelay
LongDelay) ]

  shrink :: ScriptDelay -> [ScriptDelay]
shrink ScriptDelay
LongDelay  = [ScriptDelay
NoDelay, ScriptDelay
ShortDelay]
  shrink ScriptDelay
ShortDelay = [ScriptDelay
NoDelay]
  shrink ScriptDelay
NoDelay    = []

playTimedScript :: (MonadAsync m, MonadTimer m)
                => Tracer m a -> TimedScript a -> m (TVar m a)
playTimedScript :: Tracer m a -> TimedScript a -> m (TVar m a)
playTimedScript Tracer m a
tracer (Script ((a
x0,ScriptDelay
d0) :| [(a, ScriptDelay)]
script)) = do
    TVar m a
v <- a -> m (TVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO a
x0
    Tracer m a -> a -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m a
tracer a
x0
    Async m ()
_ <- m () -> m (Async m ())
forall (m :: * -> *) a. MonadAsync m => m a -> m (Async m a)
async (m () -> m (Async m ())) -> m () -> m (Async m ())
forall a b. (a -> b) -> a -> b
$ do
           DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay (ScriptDelay -> DiffTime
forall p. Num p => ScriptDelay -> p
interpretScriptDelay ScriptDelay
d0)
           [m ()] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ do STM m () -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m a
v a
x)
                          Tracer m a -> a -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m a
tracer a
x
                          DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay (ScriptDelay -> DiffTime
forall p. Num p => ScriptDelay -> p
interpretScriptDelay ScriptDelay
d)
                     | (a
x,ScriptDelay
d) <- [(a, ScriptDelay)]
script ]
    TVar m a -> m (TVar m a)
forall (m :: * -> *) a. Monad m => a -> m a
return TVar m a
v
  where
    interpretScriptDelay :: ScriptDelay -> p
interpretScriptDelay ScriptDelay
NoDelay    = p
0
    interpretScriptDelay ScriptDelay
ShortDelay = p
1
    interpretScriptDelay ScriptDelay
LongDelay  = p
3600


--
-- Pick scripts
--

-- | A pick script is used to interpret the 'policyPickKnownPeersForGossip' and
-- the 'policyPickColdPeersToForget'. It selects elements from the given
-- choices by their index (modulo the number of choices). This representation
-- was chosen because it allows easy shrinking.
--
type PickScript peeraddr = Script (PickMembers peeraddr)

data PickMembers peeraddr = PickFirst
                          | PickAll
                          | PickSome (Set peeraddr)
  deriving (PickMembers peeraddr -> PickMembers peeraddr -> Bool
(PickMembers peeraddr -> PickMembers peeraddr -> Bool)
-> (PickMembers peeraddr -> PickMembers peeraddr -> Bool)
-> Eq (PickMembers peeraddr)
forall peeraddr.
Eq peeraddr =>
PickMembers peeraddr -> PickMembers peeraddr -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PickMembers peeraddr -> PickMembers peeraddr -> Bool
$c/= :: forall peeraddr.
Eq peeraddr =>
PickMembers peeraddr -> PickMembers peeraddr -> Bool
== :: PickMembers peeraddr -> PickMembers peeraddr -> Bool
$c== :: forall peeraddr.
Eq peeraddr =>
PickMembers peeraddr -> PickMembers peeraddr -> Bool
Eq, Int -> PickMembers peeraddr -> ShowS
[PickMembers peeraddr] -> ShowS
PickMembers peeraddr -> String
(Int -> PickMembers peeraddr -> ShowS)
-> (PickMembers peeraddr -> String)
-> ([PickMembers peeraddr] -> ShowS)
-> Show (PickMembers peeraddr)
forall peeraddr.
Show peeraddr =>
Int -> PickMembers peeraddr -> ShowS
forall peeraddr. Show peeraddr => [PickMembers peeraddr] -> ShowS
forall peeraddr. Show peeraddr => PickMembers peeraddr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PickMembers peeraddr] -> ShowS
$cshowList :: forall peeraddr. Show peeraddr => [PickMembers peeraddr] -> ShowS
show :: PickMembers peeraddr -> String
$cshow :: forall peeraddr. Show peeraddr => PickMembers peeraddr -> String
showsPrec :: Int -> PickMembers peeraddr -> ShowS
$cshowsPrec :: forall peeraddr.
Show peeraddr =>
Int -> PickMembers peeraddr -> ShowS
Show)

instance (Arbitrary peeraddr, Ord peeraddr) =>
         Arbitrary (PickMembers peeraddr) where
    arbitrary :: Gen (PickMembers peeraddr)
arbitrary = Gen (Set peeraddr) -> Gen (PickMembers peeraddr)
forall peeraddr. Gen (Set peeraddr) -> Gen (PickMembers peeraddr)
arbitraryPickMembers ([peeraddr] -> Set peeraddr
forall a. Ord a => [a] -> Set a
Set.fromList ([peeraddr] -> Set peeraddr)
-> Gen [peeraddr] -> Gen (Set peeraddr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen peeraddr -> Gen [peeraddr]
forall a. Gen a -> Gen [a]
listOf1 Gen peeraddr
forall a. Arbitrary a => Gen a
arbitrary)

    shrink :: PickMembers peeraddr -> [PickMembers peeraddr]
shrink (PickSome Set peeraddr
ixs) = PickMembers peeraddr
forall peeraddr. PickMembers peeraddr
PickFirst
                          PickMembers peeraddr
-> [PickMembers peeraddr] -> [PickMembers peeraddr]
forall a. a -> [a] -> [a]
: PickMembers peeraddr
forall peeraddr. PickMembers peeraddr
PickAll
                          PickMembers peeraddr
-> [PickMembers peeraddr] -> [PickMembers peeraddr]
forall a. a -> [a] -> [a]
: [ Set peeraddr -> PickMembers peeraddr
forall peeraddr. Set peeraddr -> PickMembers peeraddr
PickSome Set peeraddr
ixs'
                            | Set peeraddr
ixs' <- Set peeraddr -> [Set peeraddr]
forall a. Arbitrary a => a -> [a]
shrink Set peeraddr
ixs
                            , Bool -> Bool
not (Set peeraddr -> Bool
forall a. Set a -> Bool
Set.null Set peeraddr
ixs') ]
    shrink PickMembers peeraddr
PickAll        = [PickMembers peeraddr
forall peeraddr. PickMembers peeraddr
PickFirst]
    shrink PickMembers peeraddr
PickFirst      = []

arbitraryPickMembers :: Gen (Set peeraddr) -> Gen (PickMembers peeraddr)
arbitraryPickMembers :: Gen (Set peeraddr) -> Gen (PickMembers peeraddr)
arbitraryPickMembers Gen (Set peeraddr)
pickSome =
    [(Int, Gen (PickMembers peeraddr))] -> Gen (PickMembers peeraddr)
forall a. [(Int, Gen a)] -> Gen a
frequency [ (Int
1, PickMembers peeraddr -> Gen (PickMembers peeraddr)
forall (f :: * -> *) a. Applicative f => a -> f a
pure PickMembers peeraddr
forall peeraddr. PickMembers peeraddr
PickFirst)
              , (Int
1, PickMembers peeraddr -> Gen (PickMembers peeraddr)
forall (f :: * -> *) a. Applicative f => a -> f a
pure PickMembers peeraddr
forall peeraddr. PickMembers peeraddr
PickAll)
              , (Int
2, Set peeraddr -> PickMembers peeraddr
forall peeraddr. Set peeraddr -> PickMembers peeraddr
PickSome (Set peeraddr -> PickMembers peeraddr)
-> Gen (Set peeraddr) -> Gen (PickMembers peeraddr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Set peeraddr)
pickSome)
              ]

arbitraryPickScript :: Gen (Set peeraddr) -> Gen (PickScript peeraddr)
arbitraryPickScript :: Gen (Set peeraddr) -> Gen (PickScript peeraddr)
arbitraryPickScript Gen (Set peeraddr)
pickSome =
    (Int -> Gen (PickScript peeraddr)) -> Gen (PickScript peeraddr)
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen (PickScript peeraddr)) -> Gen (PickScript peeraddr))
-> (Int -> Gen (PickScript peeraddr)) -> Gen (PickScript peeraddr)
forall a b. (a -> b) -> a -> b
$ \Int
sz ->
      Int -> Gen (PickMembers peeraddr) -> Gen (PickScript peeraddr)
forall a. Int -> Gen a -> Gen (Script a)
arbitraryScriptOf Int
sz (Gen (Set peeraddr) -> Gen (PickMembers peeraddr)
forall peeraddr. Gen (Set peeraddr) -> Gen (PickMembers peeraddr)
arbitraryPickMembers Gen (Set peeraddr)
pickSome)

interpretPickScript :: (MonadSTM m, Ord peeraddr)
                    => TVar m (PickScript peeraddr)
                    -> Set peeraddr
                    -> Int
                    -> STM m (Set peeraddr)
interpretPickScript :: TVar m (PickScript peeraddr)
-> Set peeraddr -> Int -> STM m (Set peeraddr)
interpretPickScript TVar m (PickScript peeraddr)
scriptVar Set peeraddr
available Int
pickNum
  | Set peeraddr -> Bool
forall a. Set a -> Bool
Set.null Set peeraddr
available
  = String -> STM m (Set peeraddr)
forall a. HasCallStack => String -> a
error String
"interpretPickScript: given empty map to pick from"
  | Int
pickNum Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
  = String -> STM m (Set peeraddr)
forall a. HasCallStack => String -> a
error String
"interpretPickScript: given invalid pickNum"

  | Bool
otherwise
  = do PickMembers peeraddr
pickmembers <- TVar m (PickScript peeraddr) -> STM m (PickMembers peeraddr)
forall (m :: * -> *) a. MonadSTM m => TVar m (Script a) -> STM m a
stepScriptSTM TVar m (PickScript peeraddr)
scriptVar
       Set peeraddr -> STM m (Set peeraddr)
forall (m :: * -> *) a. Monad m => a -> m a
return (PickMembers peeraddr -> Set peeraddr -> Int -> Set peeraddr
forall peeraddr.
Ord peeraddr =>
PickMembers peeraddr -> Set peeraddr -> Int -> Set peeraddr
interpretPickMembers PickMembers peeraddr
pickmembers Set peeraddr
available Int
pickNum)

interpretPickMembers :: Ord peeraddr
                     => PickMembers peeraddr
                     -> Set peeraddr -> Int -> Set peeraddr
interpretPickMembers :: PickMembers peeraddr -> Set peeraddr -> Int -> Set peeraddr
interpretPickMembers PickMembers peeraddr
PickFirst     Set peeraddr
ps Int
_ = peeraddr -> Set peeraddr
forall a. a -> Set a
Set.singleton (Int -> Set peeraddr -> peeraddr
forall a. Int -> Set a -> a
Set.elemAt Int
0 Set peeraddr
ps)
interpretPickMembers PickMembers peeraddr
PickAll       Set peeraddr
ps Int
n = Int -> Set peeraddr -> Set peeraddr
forall a. Int -> Set a -> Set a
Set.take Int
n Set peeraddr
ps
interpretPickMembers (PickSome Set peeraddr
as) Set peeraddr
ps Int
n
  | Set peeraddr -> Bool
forall a. Set a -> Bool
Set.null Set peeraddr
ps' = peeraddr -> Set peeraddr
forall a. a -> Set a
Set.singleton (Int -> Set peeraddr -> peeraddr
forall a. Int -> Set a -> a
Set.elemAt Int
0 Set peeraddr
ps)
  | Bool
otherwise    = Int -> Set peeraddr -> Set peeraddr
forall a. Int -> Set a -> Set a
Set.take Int
n Set peeraddr
ps'
  where
    ps' :: Set peeraddr
ps' = Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set peeraddr
ps Set peeraddr
as


--
-- Tests for the QC Arbitrary instances
--

prop_shrink_Script :: Fixed (Script Int) -> Property
prop_shrink_Script :: Fixed (Script Int) -> Property
prop_shrink_Script = Fixed (Script Int) -> Property
forall a. (Arbitrary a, Eq a) => Fixed a -> Property
prop_shrink_nonequal