{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
module Test.Util.ChainUpdates (
ChainUpdate (..)
, UpdateBehavior (..)
, genChainUpdates
, toChainUpdates
, prop_genChainUpdates
) where
import Control.Monad (replicateM, replicateM_)
import Control.Monad.State.Strict (MonadTrans, execStateT, get, lift,
modify)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.Util.Condense (Condense (..))
import Ouroboros.Network.Mock.Chain (Chain (Genesis))
import qualified Ouroboros.Network.Mock.Chain as Chain
import Test.QuickCheck
import Test.Util.TestBlock
data ChainUpdate =
AddBlock TestBlock
| SwitchFork (Point TestBlock) [TestBlock]
deriving stock (ChainUpdate -> ChainUpdate -> Bool
(ChainUpdate -> ChainUpdate -> Bool)
-> (ChainUpdate -> ChainUpdate -> Bool) -> Eq ChainUpdate
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ChainUpdate -> ChainUpdate -> Bool
== :: ChainUpdate -> ChainUpdate -> Bool
$c/= :: ChainUpdate -> ChainUpdate -> Bool
/= :: ChainUpdate -> ChainUpdate -> Bool
Eq, Int -> ChainUpdate -> ShowS
[ChainUpdate] -> ShowS
ChainUpdate -> String
(Int -> ChainUpdate -> ShowS)
-> (ChainUpdate -> String)
-> ([ChainUpdate] -> ShowS)
-> Show ChainUpdate
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ChainUpdate -> ShowS
showsPrec :: Int -> ChainUpdate -> ShowS
$cshow :: ChainUpdate -> String
show :: ChainUpdate -> String
$cshowList :: [ChainUpdate] -> ShowS
showList :: [ChainUpdate] -> ShowS
Show)
instance Condense ChainUpdate where
condense :: ChainUpdate -> String
condense = \case
AddBlock TestBlock
b -> String
"AddBlock " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TestBlock -> String
forall a. Condense a => a -> String
condense TestBlock
b
SwitchFork Point TestBlock
p [TestBlock]
bs -> String
"SwitchFork <- " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Point TestBlock -> String
forall a. Condense a => a -> String
condense Point TestBlock
p String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" -> " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
[String] -> String
unwords ((TestBlock -> String) -> [TestBlock] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map TestBlock -> String
forall a. Condense a => a -> String
condense [TestBlock]
bs)
toChainUpdates :: [ChainUpdate] -> [Chain.ChainUpdate TestBlock TestBlock]
toChainUpdates :: [ChainUpdate] -> [ChainUpdate TestBlock TestBlock]
toChainUpdates = (ChainUpdate -> [ChainUpdate TestBlock TestBlock])
-> [ChainUpdate] -> [ChainUpdate TestBlock TestBlock]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((ChainUpdate -> [ChainUpdate TestBlock TestBlock])
-> [ChainUpdate] -> [ChainUpdate TestBlock TestBlock])
-> (ChainUpdate -> [ChainUpdate TestBlock TestBlock])
-> [ChainUpdate]
-> [ChainUpdate TestBlock TestBlock]
forall a b. (a -> b) -> a -> b
$ \case
SwitchFork Point TestBlock
pt [TestBlock]
bs -> Point TestBlock -> ChainUpdate TestBlock TestBlock
forall {k} (block :: k) a. Point block -> ChainUpdate block a
Chain.RollBack Point TestBlock
pt ChainUpdate TestBlock TestBlock
-> [ChainUpdate TestBlock TestBlock]
-> [ChainUpdate TestBlock TestBlock]
forall a. a -> [a] -> [a]
: (TestBlock -> ChainUpdate TestBlock TestBlock)
-> [TestBlock] -> [ChainUpdate TestBlock TestBlock]
forall a b. (a -> b) -> [a] -> [b]
map TestBlock -> ChainUpdate TestBlock TestBlock
forall {k} (block :: k) a. a -> ChainUpdate block a
Chain.AddBlock [TestBlock]
bs
AddBlock TestBlock
b -> TestBlock -> ChainUpdate TestBlock TestBlock
forall {k} (block :: k) a. a -> ChainUpdate block a
Chain.AddBlock TestBlock
b ChainUpdate TestBlock TestBlock
-> [ChainUpdate TestBlock TestBlock]
-> [ChainUpdate TestBlock TestBlock]
forall a. a -> [a] -> [a]
: []
data ChainUpdateState = ChainUpdateState
{ ChainUpdateState -> Chain TestBlock
cusCurrentChain :: !(Chain TestBlock)
, ChainUpdateState -> [ChainUpdate]
cusUpdates :: ![ChainUpdate]
} deriving stock (Int -> ChainUpdateState -> ShowS
[ChainUpdateState] -> ShowS
ChainUpdateState -> String
(Int -> ChainUpdateState -> ShowS)
-> (ChainUpdateState -> String)
-> ([ChainUpdateState] -> ShowS)
-> Show ChainUpdateState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ChainUpdateState -> ShowS
showsPrec :: Int -> ChainUpdateState -> ShowS
$cshow :: ChainUpdateState -> String
show :: ChainUpdateState -> String
$cshowList :: [ChainUpdateState] -> ShowS
showList :: [ChainUpdateState] -> ShowS
Show)
emptyUpdateState :: ChainUpdateState
emptyUpdateState :: ChainUpdateState
emptyUpdateState = ChainUpdateState
{ cusCurrentChain :: Chain TestBlock
cusCurrentChain = Chain TestBlock
forall block. Chain block
Genesis
, cusUpdates :: [ChainUpdate]
cusUpdates = []
}
getChainUpdates :: ChainUpdateState -> [ChainUpdate]
getChainUpdates :: ChainUpdateState -> [ChainUpdate]
getChainUpdates = [ChainUpdate] -> [ChainUpdate]
forall a. [a] -> [a]
reverse ([ChainUpdate] -> [ChainUpdate])
-> (ChainUpdateState -> [ChainUpdate])
-> ChainUpdateState
-> [ChainUpdate]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainUpdateState -> [ChainUpdate]
cusUpdates
data UpdateBehavior =
SelectedChainBehavior
|
TentativeChainBehavior
deriving stock (Int -> UpdateBehavior -> ShowS
[UpdateBehavior] -> ShowS
UpdateBehavior -> String
(Int -> UpdateBehavior -> ShowS)
-> (UpdateBehavior -> String)
-> ([UpdateBehavior] -> ShowS)
-> Show UpdateBehavior
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UpdateBehavior -> ShowS
showsPrec :: Int -> UpdateBehavior -> ShowS
$cshow :: UpdateBehavior -> String
show :: UpdateBehavior -> String
$cshowList :: [UpdateBehavior] -> ShowS
showList :: [UpdateBehavior] -> ShowS
Show, UpdateBehavior -> UpdateBehavior -> Bool
(UpdateBehavior -> UpdateBehavior -> Bool)
-> (UpdateBehavior -> UpdateBehavior -> Bool) -> Eq UpdateBehavior
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UpdateBehavior -> UpdateBehavior -> Bool
== :: UpdateBehavior -> UpdateBehavior -> Bool
$c/= :: UpdateBehavior -> UpdateBehavior -> Bool
/= :: UpdateBehavior -> UpdateBehavior -> Bool
Eq, Int -> UpdateBehavior
UpdateBehavior -> Int
UpdateBehavior -> [UpdateBehavior]
UpdateBehavior -> UpdateBehavior
UpdateBehavior -> UpdateBehavior -> [UpdateBehavior]
UpdateBehavior
-> UpdateBehavior -> UpdateBehavior -> [UpdateBehavior]
(UpdateBehavior -> UpdateBehavior)
-> (UpdateBehavior -> UpdateBehavior)
-> (Int -> UpdateBehavior)
-> (UpdateBehavior -> Int)
-> (UpdateBehavior -> [UpdateBehavior])
-> (UpdateBehavior -> UpdateBehavior -> [UpdateBehavior])
-> (UpdateBehavior -> UpdateBehavior -> [UpdateBehavior])
-> (UpdateBehavior
-> UpdateBehavior -> UpdateBehavior -> [UpdateBehavior])
-> Enum UpdateBehavior
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: UpdateBehavior -> UpdateBehavior
succ :: UpdateBehavior -> UpdateBehavior
$cpred :: UpdateBehavior -> UpdateBehavior
pred :: UpdateBehavior -> UpdateBehavior
$ctoEnum :: Int -> UpdateBehavior
toEnum :: Int -> UpdateBehavior
$cfromEnum :: UpdateBehavior -> Int
fromEnum :: UpdateBehavior -> Int
$cenumFrom :: UpdateBehavior -> [UpdateBehavior]
enumFrom :: UpdateBehavior -> [UpdateBehavior]
$cenumFromThen :: UpdateBehavior -> UpdateBehavior -> [UpdateBehavior]
enumFromThen :: UpdateBehavior -> UpdateBehavior -> [UpdateBehavior]
$cenumFromTo :: UpdateBehavior -> UpdateBehavior -> [UpdateBehavior]
enumFromTo :: UpdateBehavior -> UpdateBehavior -> [UpdateBehavior]
$cenumFromThenTo :: UpdateBehavior
-> UpdateBehavior -> UpdateBehavior -> [UpdateBehavior]
enumFromThenTo :: UpdateBehavior
-> UpdateBehavior -> UpdateBehavior -> [UpdateBehavior]
Enum, UpdateBehavior
UpdateBehavior -> UpdateBehavior -> Bounded UpdateBehavior
forall a. a -> a -> Bounded a
$cminBound :: UpdateBehavior
minBound :: UpdateBehavior
$cmaxBound :: UpdateBehavior
maxBound :: UpdateBehavior
Bounded)
genChainUpdates ::
UpdateBehavior
-> SecurityParam
-> Int
-> Gen [ChainUpdate]
genChainUpdates :: UpdateBehavior -> SecurityParam -> Int -> Gen [ChainUpdate]
genChainUpdates UpdateBehavior
updateBehavior SecurityParam
securityParam Int
n =
ChainUpdateState -> [ChainUpdate]
getChainUpdates
(ChainUpdateState -> [ChainUpdate])
-> Gen ChainUpdateState -> Gen [ChainUpdate]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UpdateBehavior
-> SecurityParam -> Int -> ChainUpdateState -> Gen ChainUpdateState
genChainUpdateState UpdateBehavior
updateBehavior SecurityParam
securityParam Int
n ChainUpdateState
emptyUpdateState
genChainUpdateState ::
UpdateBehavior
-> SecurityParam
-> Int
-> ChainUpdateState
-> Gen ChainUpdateState
genChainUpdateState :: UpdateBehavior
-> SecurityParam -> Int -> ChainUpdateState -> Gen ChainUpdateState
genChainUpdateState UpdateBehavior
updateBehavior SecurityParam
securityParam Int
n =
StateT ChainUpdateState Gen ()
-> ChainUpdateState -> Gen ChainUpdateState
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (Int
-> StateT ChainUpdateState Gen () -> StateT ChainUpdateState Gen ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
n StateT ChainUpdateState Gen ()
genChainUpdate)
where
addUpdate :: ChainUpdate -> ChainUpdateState -> ChainUpdateState
addUpdate ChainUpdate
u ChainUpdateState
cus = ChainUpdateState
cus { cusUpdates = u : cusUpdates cus }
setChain :: Chain TestBlock -> ChainUpdateState -> ChainUpdateState
setChain Chain TestBlock
c ChainUpdateState
cus = ChainUpdateState
cus { cusCurrentChain = c }
k :: Int
k = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> Word64 -> Int
forall a b. (a -> b) -> a -> b
$ SecurityParam -> Word64
maxRollbacks SecurityParam
securityParam
genChainUpdate :: StateT ChainUpdateState Gen ()
genChainUpdate = do
ChainUpdateState { cusCurrentChain :: ChainUpdateState -> Chain TestBlock
cusCurrentChain = Chain TestBlock
chain } <- StateT ChainUpdateState Gen ChainUpdateState
forall s (m :: * -> *). MonadState s m => m s
get
let genValid :: StateT ChainUpdateState Gen ()
genValid =
[(Int, StateT ChainUpdateState Gen ())]
-> StateT ChainUpdateState Gen ()
forall (t :: (* -> *) -> * -> *) a.
(MonadTrans t, Monad (t Gen)) =>
[(Int, t Gen a)] -> t Gen a
frequency'
[ (Int
3, Validity -> StateT ChainUpdateState Gen ()
forall {t :: (* -> *) -> * -> *}.
(MonadState ChainUpdateState (t Gen), MonadTrans t) =>
Validity -> t Gen ()
genAddBlock Validity
Valid)
, ( if Chain TestBlock -> Bool
forall block. Chain block -> Bool
Chain.null Chain TestBlock
chain then Int
0 else Int
1
, Gen Int -> StateT ChainUpdateState Gen ()
forall {t :: (* -> *) -> * -> *}.
(MonadState ChainUpdateState (t Gen), MonadTrans t) =>
Gen Int -> t Gen ()
genSwitchFork ((Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
k))
)
]
[(Int, StateT ChainUpdateState Gen ())]
-> StateT ChainUpdateState Gen ()
forall (t :: (* -> *) -> * -> *) a.
(MonadTrans t, Monad (t Gen)) =>
[(Int, t Gen a)] -> t Gen a
frequency' ([(Int, StateT ChainUpdateState Gen ())]
-> StateT ChainUpdateState Gen ())
-> [(Int, StateT ChainUpdateState Gen ())]
-> StateT ChainUpdateState Gen ()
forall a b. (a -> b) -> a -> b
$
(Int
5, Int
-> StateT ChainUpdateState Gen () -> StateT ChainUpdateState Gen ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
2 StateT ChainUpdateState Gen ()
genValid) (Int, StateT ChainUpdateState Gen ())
-> [(Int, StateT ChainUpdateState Gen ())]
-> [(Int, StateT ChainUpdateState Gen ())]
forall a. a -> [a] -> [a]
:
[ (Int
1, StateT ChainUpdateState Gen ()
genInvalidBlock) | UpdateBehavior
updateBehavior UpdateBehavior -> UpdateBehavior -> Bool
forall a. Eq a => a -> a -> Bool
== UpdateBehavior
TentativeChainBehavior ]
genBlockToAdd :: Validity -> t Gen TestBlock
genBlockToAdd Validity
validity = do
ChainUpdateState { cusCurrentChain :: ChainUpdateState -> Chain TestBlock
cusCurrentChain = Chain TestBlock
chain } <- t Gen ChainUpdateState
forall s (m :: * -> *). MonadState s m => m s
get
TestBlock
block <- Gen TestBlock -> t Gen TestBlock
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Gen TestBlock -> t Gen TestBlock)
-> Gen TestBlock -> t Gen TestBlock
forall a b. (a -> b) -> a -> b
$ case Chain TestBlock -> Maybe TestBlock
forall b. Chain b -> Maybe b
Chain.head Chain TestBlock
chain of
Maybe TestBlock
Nothing -> TestBlock -> TestBlock
forall {ptype}. TestBlockWith ptype -> TestBlockWith ptype
setValidity (TestBlock -> TestBlock)
-> (Word64 -> TestBlock) -> Word64 -> TestBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> TestBlock
firstBlock (Word64 -> TestBlock) -> Gen Word64 -> Gen TestBlock
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word64
genForkNo
Just TestBlock
curHead -> do
Word64
forkNo <- case Validity
validity of
Validity
Valid -> Gen Word64
genForkNo
Validity
Invalid -> Word64 -> Gen Word64
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word64
3
TestBlock -> Gen TestBlock
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return
(TestBlock -> Gen TestBlock)
-> (TestBlock -> TestBlock) -> TestBlock -> Gen TestBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word64 -> Word64) -> TestBlock -> TestBlock
modifyFork (Word64 -> Word64 -> Word64
forall a b. a -> b -> a
const Word64
forkNo)
(TestBlock -> TestBlock)
-> (TestBlock -> TestBlock) -> TestBlock -> TestBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestBlock -> TestBlock
forall {ptype}. TestBlockWith ptype -> TestBlockWith ptype
setValidity
(TestBlock -> Gen TestBlock) -> TestBlock -> Gen TestBlock
forall a b. (a -> b) -> a -> b
$ TestBlock -> TestBlock
successorBlock TestBlock
curHead
(ChainUpdateState -> ChainUpdateState) -> t Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ChainUpdateState -> ChainUpdateState) -> t Gen ())
-> (ChainUpdateState -> ChainUpdateState) -> t Gen ()
forall a b. (a -> b) -> a -> b
$ Chain TestBlock -> ChainUpdateState -> ChainUpdateState
setChain (TestBlock -> Chain TestBlock -> Chain TestBlock
forall block.
HasHeader block =>
block -> Chain block -> Chain block
Chain.addBlock TestBlock
block Chain TestBlock
chain)
TestBlock -> t Gen TestBlock
forall a. a -> t Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return TestBlock
block
where
setValidity :: TestBlockWith ptype -> TestBlockWith ptype
setValidity TestBlockWith ptype
b = TestBlockWith ptype
b { tbValid = validity }
genForkNo :: Gen Word64
genForkNo = case Validity
validity of
Validity
Valid -> [(Int, Gen Word64)] -> Gen Word64
forall a. [(Int, Gen a)] -> Gen a
frequency
[ (Int
1, Word64 -> Gen Word64
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return Word64
0)
, (Int
1, (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
1, Word64
2))
]
Validity
Invalid -> Word64 -> Gen Word64
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word64
3
genAddBlock :: Validity -> t Gen ()
genAddBlock Validity
validity = do
TestBlock
block <- Validity -> t Gen TestBlock
forall {t :: (* -> *) -> * -> *}.
(MonadState ChainUpdateState (t Gen), MonadTrans t) =>
Validity -> t Gen TestBlock
genBlockToAdd Validity
validity
(ChainUpdateState -> ChainUpdateState) -> t Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ChainUpdateState -> ChainUpdateState) -> t Gen ())
-> (ChainUpdateState -> ChainUpdateState) -> t Gen ()
forall a b. (a -> b) -> a -> b
$ ChainUpdate -> ChainUpdateState -> ChainUpdateState
addUpdate (TestBlock -> ChainUpdate
AddBlock TestBlock
block)
genSwitchFork :: Gen Int -> t Gen ()
genSwitchFork Gen Int
genRollBackBlocks = do
ChainUpdateState { cusCurrentChain :: ChainUpdateState -> Chain TestBlock
cusCurrentChain = Chain TestBlock
chain } <- t Gen ChainUpdateState
forall s (m :: * -> *). MonadState s m => m s
get
Int
rollBackBlocks <- Gen Int -> t Gen Int
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Gen Int
genRollBackBlocks
let chain' :: Chain TestBlock
chain' = Int -> Chain TestBlock -> Chain TestBlock
forall block. Int -> Chain block -> Chain block
Chain.drop Int
rollBackBlocks Chain TestBlock
chain
(ChainUpdateState -> ChainUpdateState) -> t Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ChainUpdateState -> ChainUpdateState) -> t Gen ())
-> (ChainUpdateState -> ChainUpdateState) -> t Gen ()
forall a b. (a -> b) -> a -> b
$ Chain TestBlock -> ChainUpdateState -> ChainUpdateState
setChain Chain TestBlock
chain'
[TestBlock]
blocks <- Int -> t Gen TestBlock -> t Gen [TestBlock]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
rollBackBlocks (Validity -> t Gen TestBlock
forall {t :: (* -> *) -> * -> *}.
(MonadState ChainUpdateState (t Gen), MonadTrans t) =>
Validity -> t Gen TestBlock
genBlockToAdd Validity
Valid)
(ChainUpdateState -> ChainUpdateState) -> t Gen ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ChainUpdateState -> ChainUpdateState) -> t Gen ())
-> (ChainUpdateState -> ChainUpdateState) -> t Gen ()
forall a b. (a -> b) -> a -> b
$ ChainUpdate -> ChainUpdateState -> ChainUpdateState
addUpdate (Point TestBlock -> [TestBlock] -> ChainUpdate
SwitchFork (Chain TestBlock -> Point TestBlock
forall block. HasHeader block => Chain block -> Point block
Chain.headPoint Chain TestBlock
chain') [TestBlock]
blocks)
genInvalidBlock :: StateT ChainUpdateState Gen ()
genInvalidBlock = do
Validity -> StateT ChainUpdateState Gen ()
forall {t :: (* -> *) -> * -> *}.
(MonadState ChainUpdateState (t Gen), MonadTrans t) =>
Validity -> t Gen ()
genAddBlock Validity
Invalid
Gen Int -> StateT ChainUpdateState Gen ()
forall {t :: (* -> *) -> * -> *}.
(MonadState ChainUpdateState (t Gen), MonadTrans t) =>
Gen Int -> t Gen ()
genSwitchFork (Int -> Gen Int
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
1)
frequency' :: (MonadTrans t, Monad (t Gen)) => [(Int, t Gen a)] -> t Gen a
frequency' :: forall (t :: (* -> *) -> * -> *) a.
(MonadTrans t, Monad (t Gen)) =>
[(Int, t Gen a)] -> t Gen a
frequency' [] = String -> t Gen a
forall a. HasCallStack => String -> a
error String
"frequency' used with empty list"
frequency' [(Int, t Gen a)]
xs0 = Gen Int -> t Gen Int
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ((Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
tot)) t Gen Int -> (Int -> t Gen a) -> t Gen a
forall a b. t Gen a -> (a -> t Gen b) -> t Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Int -> [(Int, t Gen a)] -> t Gen a
forall {t} {b}. (Ord t, Num t) => t -> [(t, b)] -> b
`pick` [(Int, t Gen a)]
xs0)
where
tot :: Int
tot = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (((Int, t Gen a) -> Int) -> [(Int, t Gen a)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, t Gen a) -> Int
forall a b. (a, b) -> a
fst [(Int, t Gen a)]
xs0)
pick :: t -> [(t, b)] -> b
pick t
n ((t
k,b
x):[(t, b)]
xs)
| t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
k = b
x
| Bool
otherwise = t -> [(t, b)] -> b
pick (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
k) [(t, b)]
xs
pick t
_ [(t, b)]
_ = String -> b
forall a. HasCallStack => String -> a
error String
"pick used with empty list"
prop_genChainUpdates :: SecurityParam -> Int -> Property
prop_genChainUpdates :: SecurityParam -> Int -> Property
prop_genChainUpdates SecurityParam
securityParam Int
n =
Gen ChainUpdateState -> (ChainUpdateState -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen ChainUpdateState
genCUS ((ChainUpdateState -> Property) -> Property)
-> (ChainUpdateState -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \ChainUpdateState
cus ->
[ChainUpdate TestBlock TestBlock]
-> Chain TestBlock -> Maybe (Chain TestBlock)
forall block.
HasHeader block =>
[ChainUpdate block block] -> Chain block -> Maybe (Chain block)
Chain.applyChainUpdates ([ChainUpdate] -> [ChainUpdate TestBlock TestBlock]
toChainUpdates (ChainUpdateState -> [ChainUpdate]
getChainUpdates ChainUpdateState
cus)) Chain TestBlock
forall block. Chain block
Genesis Maybe (Chain TestBlock) -> Maybe (Chain TestBlock) -> Property
forall a. (Eq a, Show a) => a -> a -> Property
===
Chain TestBlock -> Maybe (Chain TestBlock)
forall a. a -> Maybe a
Just (ChainUpdateState -> Chain TestBlock
cusCurrentChain ChainUpdateState
cus)
where
genCUS :: Gen ChainUpdateState
genCUS = do
UpdateBehavior
behavior <- (UpdateBehavior, UpdateBehavior) -> Gen UpdateBehavior
forall a. Enum a => (a, a) -> Gen a
chooseEnum (UpdateBehavior
forall a. Bounded a => a
minBound, UpdateBehavior
forall a. Bounded a => a
maxBound)
UpdateBehavior
-> SecurityParam -> Int -> ChainUpdateState -> Gen ChainUpdateState
genChainUpdateState UpdateBehavior
behavior SecurityParam
securityParam Int
n ChainUpdateState
emptyUpdateState