{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}

#if __GLASGOW_HASKELL__ >= 910
{-# OPTIONS_GHC -Wno-x-partial #-}
#endif

-- | Test that 'PerasWeightSnapshot' can correctly compute the weight of points
-- and fragments.
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
    -- Consider suffixes of @frag@, longest first
    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

-- | Test that the weight of a fragment is equal to the weight of its
-- first\/last point plus the weight of the remaining suffix\/infix.
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]
  -- ^ Check the weight of these points.
  , TestSetup -> [AnchoredFragment TestBlock]
tsFragments :: [AnchoredFragment TestBlock]
  -- ^ Check the weight of these fragments.
  , 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
    -- Generate a block tree rooted at Genesis.
    tree :: BlockTree <- Gen BlockTree
forall a. Arbitrary a => Gen a
arbitrary

    let
      -- Points for all blocks in the block tree.
      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)

      -- Chains from Genesis to all leaves of the block tree.
      treeChains :: [Chain TestBlock]
      treeChains = BlockTree -> [Chain TestBlock]
treeToChains BlockTree
tree

    -- Randomly boost some points. This might need to be refined in the future
    -- (as per https://github.com/tweag/cardano-peras/issues/124).
    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

    -- Generate a list of fragments as random infixes of the @treeChains@.
    tsFragments <-
      for treeChains genInfixFragment

    tsSecParam <- arbitrary
    pure
      TestSetup
        { tsWeights
        , tsPoints
        , tsFragments
        , tsSecParam
        }
   where
    -- Generate a weight boost (for some point).
    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))
        ]

    -- Given a chain, generate an infix fragment of that chain.
    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
    -- Decrease by @1@, unless this would mean that it is non-positive.
    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