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

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

import           Data.Functor (($>))
import           Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NonEmpty
import           Data.Set (Set)
import qualified Data.Set as Set

import           Control.Concurrent.Class.MonadSTM.Strict
import           Control.Concurrent.Class.MonadSTM (TVar)
import qualified Control.Concurrent.Class.MonadSTM as LazySTM
import           Control.Monad.Class.MonadAsync
import           Control.Monad.Class.MonadFork
import           Control.Monad.Class.MonadTimer.SI
import           Control.Tracer (Tracer, traceWith)

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

singletonScript :: a -> Script a
singletonScript :: forall a. 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 :: forall a. Script a -> a
scriptHead (Script (a
x :| [a]
_)) = a
x

arbitraryScriptOf :: Int -> Gen a -> Gen (Script a)
arbitraryScriptOf :: forall a. 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
      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))
      Script . NonEmpty.fromList <$> vectorOf n a

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

stepScript :: MonadSTM m => TVar m (Script a) -> m a
stepScript :: forall (m :: * -> *) a. MonadSTM m => TVar m (Script a) -> m a
stepScript TVar m (Script a)
scriptVar = STM m a -> m a
forall a. HasCallStack => 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 :: forall (m :: * -> *) a. MonadSTM m => TVar m (Script a) -> STM m a
stepScriptSTM TVar m (Script a)
scriptVar = do
    Script (x :| xs) <- TVar m (Script a) -> STM m (Script a)
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
LazySTM.readTVar TVar m (Script a)
scriptVar
    case xs of
      []     -> () -> STM m ()
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      a
x':[a]
xs' -> TVar m (Script a) -> Script a -> STM m ()
forall a. TVar m a -> 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'))
    return x

-- | Return 'Left' if it was the last step, return 'Right' if the script can
-- continue.
--
stepScriptOrFinish :: MonadSTM m => TVar m (Script a) -> m (Either a a)
stepScriptOrFinish :: forall (m :: * -> *) a.
MonadSTM m =>
TVar m (Script a) -> m (Either a a)
stepScriptOrFinish TVar m (Script a)
scriptVar = STM m (Either a a) -> m (Either a a)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (TVar m (Script a) -> STM m (Either a a)
forall (m :: * -> *) a.
MonadSTM m =>
TVar m (Script a) -> STM m (Either a a)
stepScriptOrFinishSTM TVar m (Script a)
scriptVar)

stepScriptOrFinishSTM :: MonadSTM m => TVar m (Script a) -> STM m (Either a a)
stepScriptOrFinishSTM :: forall (m :: * -> *) a.
MonadSTM m =>
TVar m (Script a) -> STM m (Either a a)
stepScriptOrFinishSTM TVar m (Script a)
scriptVar = do
    Script (x :| xs) <- TVar m (Script a) -> STM m (Script a)
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
LazySTM.readTVar TVar m (Script a)
scriptVar
    case xs of
      []     -> Either a a -> STM m (Either a a)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either a a
forall a b. a -> Either a b
Left a
x)
      a
x':[a]
xs' -> TVar m (Script a) -> Script a -> STM m ()
forall a. TVar m a -> 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'))
             STM m () -> Either a a -> STM m (Either a a)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> a -> Either a a
forall a b. b -> Either a b
Right a
x

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

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

stepScriptSTM' :: MonadSTM m => StrictTVar m (Script a) -> STM m a
stepScriptSTM' :: forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m (Script a) -> STM m a
stepScriptSTM' StrictTVar m (Script a)
scriptVar = do
    Script (x :| xs) <- StrictTVar m (Script a) -> STM m (Script a)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Script a)
scriptVar
    case xs of
      []     -> () -> STM m ()
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      a
x':[a]
xs' -> StrictTVar m (Script a) -> Script a -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar 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'))
    return 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 = (a -> [a]) -> Script a -> [Script a]
forall a. (a -> [a]) -> Script a -> [Script a]
shrinkScriptWith a -> [a]
forall a. Arbitrary a => a -> [a]
shrink

shrinkScriptWith :: (a -> [a]) -> Script a -> [Script a]
shrinkScriptWith :: forall a. (a -> [a]) -> Script a -> [Script a]
shrinkScriptWith a -> [a]
f (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]
f a
x ]
shrinkScriptWith a -> [a]
f (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 a. [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. HasCallStack => [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]
f 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]
f [a]
xs ]


--
-- Timed scripts
--

type TimedScript a = Script (a, ScriptDelay)

-- | Timed script which consists of a single element.
--
singletonTimedScript :: a -> TimedScript a
singletonTimedScript :: forall a. a -> TimedScript a
singletonTimedScript = (a, ScriptDelay) -> Script (a, ScriptDelay)
forall a. a -> Script a
singletonScript ((a, ScriptDelay) -> Script (a, ScriptDelay))
-> (a -> (a, ScriptDelay)) -> a -> Script (a, ScriptDelay)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,ScriptDelay
NoDelay)

data ScriptDelay = NoDelay | ShortDelay | LongDelay | Delay DiffTime
  deriving (ScriptDelay -> ScriptDelay -> Bool
(ScriptDelay -> ScriptDelay -> Bool)
-> (ScriptDelay -> ScriptDelay -> Bool) -> Eq ScriptDelay
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ScriptDelay -> ScriptDelay -> Bool
== :: ScriptDelay -> ScriptDelay -> Bool
$c/= :: ScriptDelay -> ScriptDelay -> Bool
/= :: 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
$cshowsPrec :: Int -> ScriptDelay -> ShowS
showsPrec :: Int -> ScriptDelay -> ShowS
$cshow :: ScriptDelay -> String
show :: ScriptDelay -> String
$cshowList :: [ScriptDelay] -> ShowS
showList :: [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 a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ScriptDelay
NoDelay)
                        , (Int
1, ScriptDelay -> Gen ScriptDelay
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ScriptDelay
ShortDelay)
                        , (Int
4, ScriptDelay -> Gen ScriptDelay
forall a. a -> Gen a
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    = []
  shrink (Delay DiffTime
_)  = []

playTimedScript :: (MonadAsync m, MonadDelay m)
                => Tracer m a -> TimedScript a -> m (TVar m a)
playTimedScript :: forall (m :: * -> *) a.
(MonadAsync m, MonadDelay m) =>
Tracer m a -> TimedScript a -> m (TVar m a)
playTimedScript Tracer m a
tracer (Script ((a
x0,ScriptDelay
d0) :| [(a, ScriptDelay)]
script)) = do
    v <- a -> m (TVar m a)
forall a. a -> m (TVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
LazySTM.newTVarIO a
x0
    traceWith tracer x0
    _ <- async $ do
           labelThisThread "timed-script"
           threadDelay (interpretScriptDelay d0)
           sequence_ [ do atomically (LazySTM.writeTVar v x)
                          traceWith tracer x
                          threadDelay (interpretScriptDelay d)
                     | (x,d) <- script ]
    return v
  where
    interpretScriptDelay :: ScriptDelay -> DiffTime
interpretScriptDelay ScriptDelay
NoDelay       = DiffTime
0
    interpretScriptDelay ScriptDelay
ShortDelay    = DiffTime
1
    interpretScriptDelay ScriptDelay
LongDelay     = DiffTime
3600
    interpretScriptDelay (Delay DiffTime
delay) = DiffTime
delay


--
-- Pick scripts
--

-- | A pick script is used to interpret the 'policyPickKnownPeersForPeerShare' 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
$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
/= :: 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
$cshowsPrec :: forall peeraddr.
Show peeraddr =>
Int -> PickMembers peeraddr -> ShowS
showsPrec :: Int -> PickMembers peeraddr -> ShowS
$cshow :: forall peeraddr. Show peeraddr => PickMembers peeraddr -> String
show :: PickMembers peeraddr -> String
$cshowList :: forall peeraddr. Show peeraddr => [PickMembers peeraddr] -> ShowS
showList :: [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 :: forall peeraddr. 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 a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PickMembers peeraddr
forall peeraddr. PickMembers peeraddr
PickFirst)
              , (Int
1, PickMembers peeraddr -> Gen (PickMembers peeraddr)
forall a. a -> Gen a
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 :: forall peeraddr. 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)
                    => StrictTVar m (PickScript peeraddr)
                    -> Set peeraddr
                    -> Int
                    -> STM m (Set peeraddr)
interpretPickScript :: forall (m :: * -> *) peeraddr.
(MonadSTM m, Ord peeraddr) =>
StrictTVar m (PickScript peeraddr)
-> Set peeraddr -> Int -> STM m (Set peeraddr)
interpretPickScript StrictTVar 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 <- StrictTVar m (PickScript peeraddr) -> STM m (PickMembers peeraddr)
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m (Script a) -> STM m a
stepScriptSTM' StrictTVar m (PickScript peeraddr)
scriptVar
       return (interpretPickMembers pickmembers available pickNum)

interpretPickMembers :: Ord peeraddr
                     => PickMembers peeraddr
                     -> Set peeraddr -> Int -> Set peeraddr
interpretPickMembers :: forall peeraddr.
Ord peeraddr =>
PickMembers peeraddr -> Set peeraddr -> Int -> Set peeraddr
interpretPickMembers PickMembers peeraddr
PickFirst     Set peeraddr
ps Int
_
  | Set peeraddr -> Bool
forall a. Set a -> Bool
Set.null Set peeraddr
ps = Set peeraddr
ps
  | Bool
otherwise   = 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 :: ShrinkCarefully (Script Int) -> Property
prop_shrink_Script :: ShrinkCarefully (Script Int) -> Property
prop_shrink_Script = ShrinkCarefully (Script Int) -> Property
forall a.
(Arbitrary a, Eq a, Show a) =>
ShrinkCarefully a -> Property
prop_shrink_nonequal