{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
#if __GLASGOW_HASKELL__ >= 910
{-# OPTIONS_GHC -Wno-x-partial #-}
#endif
module Test.Consensus.Peras.WeightSnapshot (tests) where
import Cardano.Ledger.BaseTypes (unNonZero)
import Data.Containers.ListUtils (nubOrd)
import Data.List (find)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes, fromJust)
import Data.Traversable (for)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config.SecurityParam
import Ouroboros.Consensus.Peras.Weight
import Ouroboros.Consensus.Util.Condense
import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
import qualified Ouroboros.Network.AnchoredFragment as AF
import Ouroboros.Network.Mock.Chain (Chain)
import qualified Ouroboros.Network.Mock.Chain as Chain
import Test.QuickCheck
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.Util.Orphans.Arbitrary ()
import Test.Util.QuickCheck
import Test.Util.TestBlock
tests :: TestTree
tests :: TestTree
tests =
String -> [TestTree] -> TestTree
testGroup
String
"PerasWeightSnapshot"
[ String -> (TestSetup -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"correctness" TestSetup -> Property
prop_perasWeightSnapshot
]
prop_perasWeightSnapshot :: TestSetup -> Property
prop_perasWeightSnapshot :: TestSetup -> Property
prop_perasWeightSnapshot TestSetup
testSetup =
String -> [String] -> Property -> Property
forall prop.
Testable prop =>
String -> [String] -> prop -> Property
tabulate String
"log₂ # of points" [Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ forall a b. (RealFrac a, Integral b) => a -> b
round @Double @Int (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double
forall a. Floating a => a -> a -> a
logBase Double
2 (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Point TestBlock] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Point TestBlock]
tsPoints))]
(Property -> Property)
-> (Property -> Property) -> Property -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"PerasWeightSnapshot: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> PerasWeightSnapshot TestBlock -> String
forall a. Show a => a -> String
show PerasWeightSnapshot TestBlock
snap)
(Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
[ [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
[ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Incorrect weight for " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Point TestBlock -> String
forall a. Condense a => a -> String
condense Point TestBlock
pt) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
Point TestBlock -> PerasWeight
weightBoostOfPointReference Point TestBlock
pt PerasWeight -> PerasWeight -> Property
forall a. (Eq a, Condense a) => a -> a -> Property
=:= PerasWeightSnapshot TestBlock -> Point TestBlock -> PerasWeight
forall blk.
StandardHash blk =>
PerasWeightSnapshot blk -> Point blk -> PerasWeight
weightBoostOfPoint PerasWeightSnapshot TestBlock
snap Point TestBlock
pt
| Point TestBlock
pt <- [Point TestBlock]
tsPoints
]
, [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
[ [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
[ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Incorrect weight for " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> AnchoredFragment TestBlock -> String
forall a. Condense a => a -> String
condense AnchoredFragment TestBlock
frag) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
AnchoredFragment TestBlock -> PerasWeight
weightBoostOfFragmentReference AnchoredFragment TestBlock
frag PerasWeight -> PerasWeight -> Property
forall a. (Eq a, Condense a) => a -> a -> Property
=:= PerasWeightSnapshot TestBlock
-> AnchoredFragment TestBlock -> PerasWeight
forall blk h.
(StandardHash blk, HasHeader h, HeaderHash blk ~ HeaderHash h) =>
PerasWeightSnapshot blk -> AnchoredFragment h -> PerasWeight
weightBoostOfFragment PerasWeightSnapshot TestBlock
snap AnchoredFragment TestBlock
frag
, String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Weight not inductively consistent for " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> AnchoredFragment TestBlock -> String
forall a. Condense a => a -> String
condense AnchoredFragment TestBlock
frag) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
PerasWeightSnapshot TestBlock
-> AnchoredFragment TestBlock -> Property
prop_fragmentInduction PerasWeightSnapshot TestBlock
snap AnchoredFragment TestBlock
frag
]
| AnchoredFragment TestBlock
frag <- [AnchoredFragment TestBlock]
tsFragments
]
, [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
[ [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
[ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Incorrect volatile suffix for " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> AnchoredFragment TestBlock -> String
forall a. Condense a => a -> String
condense AnchoredFragment TestBlock
frag) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
AnchoredFragment TestBlock -> AnchoredFragment TestBlock
takeVolatileSuffixReference AnchoredFragment TestBlock
frag AnchoredFragment TestBlock
-> AnchoredFragment TestBlock -> Property
forall a. (Eq a, Condense a) => a -> a -> Property
=:= AnchoredFragment TestBlock
volSuffix
, String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Volatile suffix must be a suffix of" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> AnchoredFragment TestBlock -> String
forall a. Condense a => a -> String
condense AnchoredFragment TestBlock
frag) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
AnchoredFragment TestBlock -> Point TestBlock
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint AnchoredFragment TestBlock
frag Point TestBlock -> Point TestBlock -> Property
forall a. (Eq a, Condense a) => a -> a -> Property
=:= AnchoredFragment TestBlock -> Point TestBlock
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint AnchoredFragment TestBlock
volSuffix
Property -> Bool -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. Point TestBlock -> AnchoredFragment TestBlock -> Bool
forall block.
HasHeader block =>
Point block -> AnchoredFragment block -> Bool
AF.withinFragmentBounds (AnchoredFragment TestBlock -> Point TestBlock
forall block. AnchoredFragment block -> Point block
AF.anchorPoint AnchoredFragment TestBlock
volSuffix) AnchoredFragment TestBlock
frag
, String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"A longer volatile suffix still has total weight at most k") (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
let isImproperSuffix :: Bool
isImproperSuffix = AnchoredFragment TestBlock -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length AnchoredFragment TestBlock
volSuffix Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== AnchoredFragment TestBlock -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length AnchoredFragment TestBlock
frag
fragSuffixOneLonger :: AnchoredFragment TestBlock
fragSuffixOneLonger =
Word64 -> AnchoredFragment TestBlock -> AnchoredFragment TestBlock
forall v a b.
Anchorable v a b =>
Word64 -> AnchoredSeq v a b -> AnchoredSeq v a b
AF.anchorNewest (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (AnchoredFragment TestBlock -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length AnchoredFragment TestBlock
volSuffix) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1) AnchoredFragment TestBlock
frag
weightOneLonger :: PerasWeight
weightOneLonger = PerasWeightSnapshot TestBlock
-> AnchoredFragment TestBlock -> PerasWeight
forall blk h.
(StandardHash blk, HasHeader h, HeaderHash blk ~ HeaderHash h) =>
PerasWeightSnapshot blk -> AnchoredFragment h -> PerasWeight
totalWeightOfFragment PerasWeightSnapshot TestBlock
snap AnchoredFragment TestBlock
fragSuffixOneLonger
in Bool
isImproperSuffix Bool -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.||. PerasWeight
weightOneLonger PerasWeight -> PerasWeight -> Property
forall a. (Ord a, Show a) => a -> a -> Property
`gt` SecurityParam -> PerasWeight
maxRollbackWeight SecurityParam
tsSecParam
, String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Volatile suffix of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> AnchoredFragment TestBlock -> String
forall a. Condense a => a -> String
condense AnchoredFragment TestBlock
frag String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" must contain at most k blocks") (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
AnchoredFragment TestBlock -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length AnchoredFragment TestBlock
volSuffix Int -> Int -> Property
forall a. (Ord a, Show a) => a -> a -> Property
`le` Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero (SecurityParam -> NonZero Word64
maxRollbacks SecurityParam
tsSecParam))
]
| AnchoredFragment TestBlock
frag <- [AnchoredFragment TestBlock]
tsFragments
, let volSuffix :: AnchoredFragment TestBlock
volSuffix = PerasWeightSnapshot TestBlock
-> SecurityParam
-> AnchoredFragment TestBlock
-> AnchoredFragment TestBlock
forall blk h.
(StandardHash blk, HasHeader h, HeaderHash blk ~ HeaderHash h) =>
PerasWeightSnapshot blk
-> SecurityParam -> AnchoredFragment h -> AnchoredFragment h
takeVolatileSuffix PerasWeightSnapshot TestBlock
snap SecurityParam
tsSecParam AnchoredFragment TestBlock
frag
]
]
where
TestSetup
{ Map (Point TestBlock) PerasWeight
tsWeights :: Map (Point TestBlock) PerasWeight
tsWeights :: TestSetup -> Map (Point TestBlock) PerasWeight
tsWeights
, [Point TestBlock]
tsPoints :: [Point TestBlock]
tsPoints :: TestSetup -> [Point TestBlock]
tsPoints
, [AnchoredFragment TestBlock]
tsFragments :: [AnchoredFragment TestBlock]
tsFragments :: TestSetup -> [AnchoredFragment TestBlock]
tsFragments
, SecurityParam
tsSecParam :: SecurityParam
tsSecParam :: TestSetup -> SecurityParam
tsSecParam
} = TestSetup
testSetup
snap :: PerasWeightSnapshot TestBlock
snap = [(Point TestBlock, PerasWeight)] -> PerasWeightSnapshot TestBlock
forall blk.
StandardHash blk =>
[(Point blk, PerasWeight)] -> PerasWeightSnapshot blk
mkPerasWeightSnapshot ([(Point TestBlock, PerasWeight)] -> PerasWeightSnapshot TestBlock)
-> [(Point TestBlock, PerasWeight)]
-> PerasWeightSnapshot TestBlock
forall a b. (a -> b) -> a -> b
$ Map (Point TestBlock) PerasWeight
-> [(Point TestBlock, PerasWeight)]
forall k a. Map k a -> [(k, a)]
Map.toList Map (Point TestBlock) PerasWeight
tsWeights
weightBoostOfPointReference :: Point TestBlock -> PerasWeight
weightBoostOfPointReference :: Point TestBlock -> PerasWeight
weightBoostOfPointReference Point TestBlock
pt = PerasWeight
-> Point TestBlock
-> Map (Point TestBlock) PerasWeight
-> PerasWeight
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault PerasWeight
forall a. Monoid a => a
mempty Point TestBlock
pt Map (Point TestBlock) PerasWeight
tsWeights
weightBoostOfFragmentReference :: AnchoredFragment TestBlock -> PerasWeight
weightBoostOfFragmentReference :: AnchoredFragment TestBlock -> PerasWeight
weightBoostOfFragmentReference AnchoredFragment TestBlock
frag =
(TestBlock -> PerasWeight) -> [TestBlock] -> PerasWeight
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
(Point TestBlock -> PerasWeight
weightBoostOfPointReference (Point TestBlock -> PerasWeight)
-> (TestBlock -> Point TestBlock) -> TestBlock -> PerasWeight
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestBlock -> Point TestBlock
forall block. HasHeader block => block -> Point block
blockPoint)
(AnchoredFragment TestBlock -> [TestBlock]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst AnchoredFragment TestBlock
frag)
takeVolatileSuffixReference ::
AnchoredFragment TestBlock -> AnchoredFragment TestBlock
takeVolatileSuffixReference :: AnchoredFragment TestBlock -> AnchoredFragment TestBlock
takeVolatileSuffixReference =
Maybe (AnchoredFragment TestBlock) -> AnchoredFragment TestBlock
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (AnchoredFragment TestBlock) -> AnchoredFragment TestBlock)
-> (AnchoredFragment TestBlock
-> Maybe (AnchoredFragment TestBlock))
-> AnchoredFragment TestBlock
-> AnchoredFragment TestBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AnchoredFragment TestBlock -> Bool)
-> [AnchoredFragment TestBlock]
-> Maybe (AnchoredFragment TestBlock)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find AnchoredFragment TestBlock -> Bool
hasWeightAtMostK ([AnchoredFragment TestBlock]
-> Maybe (AnchoredFragment TestBlock))
-> (AnchoredFragment TestBlock -> [AnchoredFragment TestBlock])
-> AnchoredFragment TestBlock
-> Maybe (AnchoredFragment TestBlock)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment TestBlock -> [AnchoredFragment TestBlock]
forall {v} {a} {b}.
Anchorable v a b =>
AnchoredSeq v a b -> [AnchoredSeq v a b]
suffixes
where
suffixes :: AnchoredSeq v a b -> [AnchoredSeq v a b]
suffixes AnchoredSeq v a b
frag =
[ Word64 -> AnchoredSeq v a b -> AnchoredSeq v a b
forall v a b.
Anchorable v a b =>
Word64 -> AnchoredSeq v a b -> AnchoredSeq v a b
AF.anchorNewest (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len) AnchoredSeq v a b
frag
| Int
len <- [Int] -> [Int]
forall a. [a] -> [a]
reverse [Int
0 .. AnchoredSeq v a b -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length AnchoredSeq v a b
frag]
]
hasWeightAtMostK :: AnchoredFragment TestBlock -> Bool
hasWeightAtMostK AnchoredFragment TestBlock
frag =
PerasWeight
totalWeight PerasWeight -> PerasWeight -> Bool
forall a. Ord a => a -> a -> Bool
<= SecurityParam -> PerasWeight
maxRollbackWeight SecurityParam
tsSecParam
where
weightBoost :: PerasWeight
weightBoost = AnchoredFragment TestBlock -> PerasWeight
weightBoostOfFragmentReference AnchoredFragment TestBlock
frag
lengthWeight :: PerasWeight
lengthWeight = Word64 -> PerasWeight
PerasWeight (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (AnchoredFragment TestBlock -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length AnchoredFragment TestBlock
frag))
totalWeight :: PerasWeight
totalWeight = PerasWeight
lengthWeight PerasWeight -> PerasWeight -> PerasWeight
forall a. Semigroup a => a -> a -> a
<> PerasWeight
weightBoost
prop_fragmentInduction ::
PerasWeightSnapshot TestBlock ->
AnchoredFragment TestBlock ->
Property
prop_fragmentInduction :: PerasWeightSnapshot TestBlock
-> AnchoredFragment TestBlock -> Property
prop_fragmentInduction PerasWeightSnapshot TestBlock
snap =
\AnchoredFragment TestBlock
frag -> AnchoredFragment TestBlock -> Property
fromLeft AnchoredFragment TestBlock
frag Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. AnchoredFragment TestBlock -> Property
fromRight AnchoredFragment TestBlock
frag
where
fromLeft :: AnchoredFragment TestBlock -> Property
fromLeft :: AnchoredFragment TestBlock -> Property
fromLeft AnchoredFragment TestBlock
frag = case AnchoredFragment TestBlock
frag of
AF.Empty Anchor TestBlock
_ ->
PerasWeightSnapshot TestBlock
-> AnchoredFragment TestBlock -> PerasWeight
forall blk h.
(StandardHash blk, HasHeader h, HeaderHash blk ~ HeaderHash h) =>
PerasWeightSnapshot blk -> AnchoredFragment h -> PerasWeight
weightBoostOfFragment PerasWeightSnapshot TestBlock
snap AnchoredFragment TestBlock
frag PerasWeight -> PerasWeight -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== PerasWeight
forall a. Monoid a => a
mempty
TestBlock
b AF.:< AnchoredFragment TestBlock
frag' ->
PerasWeightSnapshot TestBlock
-> AnchoredFragment TestBlock -> PerasWeight
forall blk h.
(StandardHash blk, HasHeader h, HeaderHash blk ~ HeaderHash h) =>
PerasWeightSnapshot blk -> AnchoredFragment h -> PerasWeight
weightBoostOfFragment PerasWeightSnapshot TestBlock
snap AnchoredFragment TestBlock
frag
PerasWeight -> PerasWeight -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== PerasWeightSnapshot TestBlock -> Point TestBlock -> PerasWeight
forall blk.
StandardHash blk =>
PerasWeightSnapshot blk -> Point blk -> PerasWeight
weightBoostOfPoint PerasWeightSnapshot TestBlock
snap (TestBlock -> Point TestBlock
forall block. HasHeader block => block -> Point block
blockPoint TestBlock
b) PerasWeight -> PerasWeight -> PerasWeight
forall a. Semigroup a => a -> a -> a
<> PerasWeightSnapshot TestBlock
-> AnchoredFragment TestBlock -> PerasWeight
forall blk h.
(StandardHash blk, HasHeader h, HeaderHash blk ~ HeaderHash h) =>
PerasWeightSnapshot blk -> AnchoredFragment h -> PerasWeight
weightBoostOfFragment PerasWeightSnapshot TestBlock
snap AnchoredFragment TestBlock
frag'
fromRight :: AnchoredFragment TestBlock -> Property
fromRight :: AnchoredFragment TestBlock -> Property
fromRight AnchoredFragment TestBlock
frag = case AnchoredFragment TestBlock
frag of
AF.Empty Anchor TestBlock
_ ->
PerasWeightSnapshot TestBlock
-> AnchoredFragment TestBlock -> PerasWeight
forall blk h.
(StandardHash blk, HasHeader h, HeaderHash blk ~ HeaderHash h) =>
PerasWeightSnapshot blk -> AnchoredFragment h -> PerasWeight
weightBoostOfFragment PerasWeightSnapshot TestBlock
snap AnchoredFragment TestBlock
frag PerasWeight -> PerasWeight -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== PerasWeight
forall a. Monoid a => a
mempty
AnchoredFragment TestBlock
frag' AF.:> TestBlock
b ->
PerasWeightSnapshot TestBlock
-> AnchoredFragment TestBlock -> PerasWeight
forall blk h.
(StandardHash blk, HasHeader h, HeaderHash blk ~ HeaderHash h) =>
PerasWeightSnapshot blk -> AnchoredFragment h -> PerasWeight
weightBoostOfFragment PerasWeightSnapshot TestBlock
snap AnchoredFragment TestBlock
frag
PerasWeight -> PerasWeight -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== PerasWeightSnapshot TestBlock -> Point TestBlock -> PerasWeight
forall blk.
StandardHash blk =>
PerasWeightSnapshot blk -> Point blk -> PerasWeight
weightBoostOfPoint PerasWeightSnapshot TestBlock
snap (TestBlock -> Point TestBlock
forall block. HasHeader block => block -> Point block
blockPoint TestBlock
b) PerasWeight -> PerasWeight -> PerasWeight
forall a. Semigroup a => a -> a -> a
<> PerasWeightSnapshot TestBlock
-> AnchoredFragment TestBlock -> PerasWeight
forall blk h.
(StandardHash blk, HasHeader h, HeaderHash blk ~ HeaderHash h) =>
PerasWeightSnapshot blk -> AnchoredFragment h -> PerasWeight
weightBoostOfFragment PerasWeightSnapshot TestBlock
snap AnchoredFragment TestBlock
frag'
data TestSetup = TestSetup
{ TestSetup -> Map (Point TestBlock) PerasWeight
tsWeights :: Map (Point TestBlock) PerasWeight
, TestSetup -> [Point TestBlock]
tsPoints :: [Point TestBlock]
, TestSetup -> [AnchoredFragment TestBlock]
tsFragments :: [AnchoredFragment TestBlock]
, TestSetup -> SecurityParam
tsSecParam :: SecurityParam
}
deriving stock Int -> TestSetup -> String -> String
[TestSetup] -> String -> String
TestSetup -> String
(Int -> TestSetup -> String -> String)
-> (TestSetup -> String)
-> ([TestSetup] -> String -> String)
-> Show TestSetup
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> TestSetup -> String -> String
showsPrec :: Int -> TestSetup -> String -> String
$cshow :: TestSetup -> String
show :: TestSetup -> String
$cshowList :: [TestSetup] -> String -> String
showList :: [TestSetup] -> String -> String
Show
instance Arbitrary TestSetup where
arbitrary :: Gen TestSetup
arbitrary = do
tree :: BlockTree <- Gen BlockTree
forall a. Arbitrary a => Gen a
arbitrary
let
tsPoints :: [Point TestBlock]
tsPoints = [Point TestBlock] -> [Point TestBlock]
forall a. Ord a => [a] -> [a]
nubOrd ([Point TestBlock] -> [Point TestBlock])
-> [Point TestBlock] -> [Point TestBlock]
forall a b. (a -> b) -> a -> b
$ Point TestBlock
forall {k} (block :: k). Point block
GenesisPoint Point TestBlock -> [Point TestBlock] -> [Point TestBlock]
forall a. a -> [a] -> [a]
: (TestBlock -> Point TestBlock
forall block. HasHeader block => block -> Point block
blockPoint (TestBlock -> Point TestBlock) -> [TestBlock] -> [Point TestBlock]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockTree -> [TestBlock]
treeToBlocks BlockTree
tree)
treeChains :: [Chain TestBlock]
treeChains = BlockTree -> [Chain TestBlock]
treeToChains BlockTree
tree
tsWeights :: Map (Point TestBlock) PerasWeight <-
Map.fromList . catMaybes <$> for tsPoints \Point TestBlock
pt ->
(PerasWeight -> (Point TestBlock, PerasWeight))
-> Maybe PerasWeight -> Maybe (Point TestBlock, PerasWeight)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Point TestBlock
pt,) (Maybe PerasWeight -> Maybe (Point TestBlock, PerasWeight))
-> Gen (Maybe PerasWeight)
-> Gen (Maybe (Point TestBlock, PerasWeight))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Maybe PerasWeight)
genWeightBoost
tsFragments <-
for treeChains genInfixFragment
tsSecParam <- arbitrary
pure
TestSetup
{ tsWeights
, tsPoints
, tsFragments
, tsSecParam
}
where
genWeightBoost :: Gen (Maybe PerasWeight)
genWeightBoost :: Gen (Maybe PerasWeight)
genWeightBoost =
[(Int, Gen (Maybe PerasWeight))] -> Gen (Maybe PerasWeight)
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
[ (Int
3, Maybe PerasWeight -> Gen (Maybe PerasWeight)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe PerasWeight
forall a. Maybe a
Nothing)
, (Int
1, PerasWeight -> Maybe PerasWeight
forall a. a -> Maybe a
Just (PerasWeight -> Maybe PerasWeight)
-> (Word64 -> PerasWeight) -> Word64 -> Maybe PerasWeight
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> PerasWeight
PerasWeight (Word64 -> Maybe PerasWeight)
-> Gen Word64 -> Gen (Maybe PerasWeight)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
1, Word64
10))
]
genInfixFragment :: Chain TestBlock -> Gen (AnchoredFragment TestBlock)
genInfixFragment :: Chain TestBlock -> Gen (AnchoredFragment TestBlock)
genInfixFragment Chain TestBlock
chain = do
let lenChain :: Int
lenChain = Chain TestBlock -> Int
forall block. Chain block -> Int
Chain.length Chain TestBlock
chain
fullFrag :: AnchoredFragment TestBlock
fullFrag = Chain TestBlock -> AnchoredFragment TestBlock
forall block.
HasHeader block =>
Chain block -> AnchoredFragment block
Chain.toAnchoredFragment Chain TestBlock
chain
nTakeNewest <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
lenChain)
nDropNewest <- choose (0, nTakeNewest)
pure $
AF.dropNewest nDropNewest $
AF.anchorNewest (fromIntegral nTakeNewest) fullFrag
shrink :: TestSetup -> [TestSetup]
shrink TestSetup
ts =
[[TestSetup]] -> [TestSetup]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ TestSetup
ts{tsWeights = Map.fromList tsWeights'}
| [(Point TestBlock, PerasWeight)]
tsWeights' <-
((Point TestBlock, PerasWeight)
-> [(Point TestBlock, PerasWeight)])
-> [(Point TestBlock, PerasWeight)]
-> [[(Point TestBlock, PerasWeight)]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList
(\(Point TestBlock
pt, PerasWeight
w) -> (Point TestBlock
pt,) (PerasWeight -> (Point TestBlock, PerasWeight))
-> [PerasWeight] -> [(Point TestBlock, PerasWeight)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PerasWeight -> [PerasWeight]
shrinkWeight PerasWeight
w)
([(Point TestBlock, PerasWeight)]
-> [[(Point TestBlock, PerasWeight)]])
-> [(Point TestBlock, PerasWeight)]
-> [[(Point TestBlock, PerasWeight)]]
forall a b. (a -> b) -> a -> b
$ Map (Point TestBlock) PerasWeight
-> [(Point TestBlock, PerasWeight)]
forall k a. Map k a -> [(k, a)]
Map.toList Map (Point TestBlock) PerasWeight
tsWeights
]
, [ TestSetup
ts{tsPoints = tsPoints'}
| [Point TestBlock]
tsPoints' <- (Point TestBlock -> [Point TestBlock])
-> [Point TestBlock] -> [[Point TestBlock]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList (\Point TestBlock
_pt -> []) [Point TestBlock]
tsPoints
]
, [ TestSetup
ts{tsFragments = tsFragments'}
| [AnchoredFragment TestBlock]
tsFragments' <- (AnchoredFragment TestBlock -> [AnchoredFragment TestBlock])
-> [AnchoredFragment TestBlock] -> [[AnchoredFragment TestBlock]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList (\AnchoredFragment TestBlock
_frag -> []) [AnchoredFragment TestBlock]
tsFragments
]
, [ TestSetup
ts{tsSecParam = tsSecParam'}
| SecurityParam
tsSecParam' <- SecurityParam -> [SecurityParam]
forall a. Arbitrary a => a -> [a]
shrink SecurityParam
tsSecParam
]
]
where
shrinkWeight :: PerasWeight -> [PerasWeight]
shrinkWeight :: PerasWeight -> [PerasWeight]
shrinkWeight (PerasWeight Word64
w)
| Word64
w Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
1 = [Word64 -> PerasWeight
PerasWeight (Word64
w Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
1)]
| Bool
otherwise = []
TestSetup
{ Map (Point TestBlock) PerasWeight
tsWeights :: TestSetup -> Map (Point TestBlock) PerasWeight
tsWeights :: Map (Point TestBlock) PerasWeight
tsWeights
, [Point TestBlock]
tsPoints :: TestSetup -> [Point TestBlock]
tsPoints :: [Point TestBlock]
tsPoints
, [AnchoredFragment TestBlock]
tsFragments :: TestSetup -> [AnchoredFragment TestBlock]
tsFragments :: [AnchoredFragment TestBlock]
tsFragments
, SecurityParam
tsSecParam :: TestSetup -> SecurityParam
tsSecParam :: SecurityParam
tsSecParam
} = TestSetup
ts