{-# 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 Data.Containers.ListUtils (nubOrd)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes)
import Data.Traversable (for)
import Ouroboros.Consensus.Block
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
          ]
      ]
 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
    } = 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)

-- | 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.
  }
  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

    pure
      TestSetup
        { tsWeights
        , tsPoints
        , tsFragments
        }
   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
        ]
      ]
   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
      } = TestSetup
ts