{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Consensus.BlockTree.Tests (tests) where

import Data.Function (on)
import qualified Data.List as L
import qualified Data.Map as M
import Ouroboros.Consensus.Block.Abstract (HasHeader, HeaderHash)
import qualified Ouroboros.Network.AnchoredFragment as AF
import Ouroboros.Network.Block (blockHash)
import Test.Consensus.BlockTree
import Test.Consensus.Genesis.Setup.GenChains
  ( GenesisTest (..)
  , genChains
  )
import Test.QuickCheck
import qualified Test.QuickCheck as QC
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.Util.TestBlock (TestBlock)

genTestBlockTree :: QC.Gen Word -> QC.Gen (BlockTree TestBlock)
genTestBlockTree :: Gen Word -> Gen (BlockTree TestBlock)
genTestBlockTree = (GenesisTest TestBlock () -> BlockTree TestBlock)
-> Gen (GenesisTest TestBlock ()) -> Gen (BlockTree TestBlock)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenesisTest TestBlock () -> BlockTree TestBlock
forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree (Gen (GenesisTest TestBlock ()) -> Gen (BlockTree TestBlock))
-> (Gen Word -> Gen (GenesisTest TestBlock ()))
-> Gen Word
-> Gen (BlockTree TestBlock)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Gen Word -> Gen (GenesisTest TestBlock ())
forall blk.
(HasHeader blk, IssueTestBlock blk) =>
Gen Word -> Gen (GenesisTest blk ())
genChains

genTestAnchoredFragment :: QC.Gen (AF.AnchoredFragment TestBlock)
genTestAnchoredFragment :: Gen (AnchoredFragment TestBlock)
genTestAnchoredFragment = (BlockTree TestBlock -> AnchoredFragment TestBlock)
-> Gen (BlockTree TestBlock) -> Gen (AnchoredFragment TestBlock)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BlockTree TestBlock -> AnchoredFragment TestBlock
forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk (Gen (BlockTree TestBlock) -> Gen (AnchoredFragment TestBlock))
-> Gen (BlockTree TestBlock) -> Gen (AnchoredFragment TestBlock)
forall a b. (a -> b) -> a -> b
$ Gen Word -> Gen (BlockTree TestBlock)
genTestBlockTree (Word -> Gen Word
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word
0)

tests :: TestTree
tests :: TestTree
tests =
  let branchFactor :: Gen Word
branchFactor = Word -> Gen Word
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word
4
   in TestName -> [TestTree] -> TestTree
testGroup
        TestName
"BlockTree"
        [ TestName -> [TestTree] -> TestTree
testGroup
            TestName
"nonemptyPrefixesOf"
            [ TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"nonemptyPrefixesArePrefixes" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
                Gen (AnchoredFragment TestBlock)
-> (AnchoredFragment TestBlock -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen (AnchoredFragment TestBlock)
genTestAnchoredFragment ((AnchoredFragment TestBlock -> Property) -> Property)
-> (AnchoredFragment TestBlock -> Property) -> Property
forall a b. (a -> b) -> a -> b
$
                  AnchoredFragment TestBlock -> Property
forall blk.
(Eq blk, HasHeader blk) =>
AnchoredFragment blk -> Property
prop_nonemptyPrefixesOf_nonemptyPrefixesArePrefixes
            , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"nonemptyPrefixesAreNonempty" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
                Gen (AnchoredFragment TestBlock)
-> (AnchoredFragment TestBlock -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen (AnchoredFragment TestBlock)
genTestAnchoredFragment ((AnchoredFragment TestBlock -> Property) -> Property)
-> (AnchoredFragment TestBlock -> Property) -> Property
forall a b. (a -> b) -> a -> b
$
                  AnchoredFragment TestBlock -> Property
forall blk. HasHeader blk => AnchoredFragment blk -> Property
prop_nonemptyPrefixesOf_nonemptyPrefixesAreNonempty
            , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"nonemptyPrefixesAreUnique" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
                Gen (AnchoredFragment TestBlock)
-> (AnchoredFragment TestBlock -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen (AnchoredFragment TestBlock)
genTestAnchoredFragment ((AnchoredFragment TestBlock -> Property) -> Property)
-> (AnchoredFragment TestBlock -> Property) -> Property
forall a b. (a -> b) -> a -> b
$
                  AnchoredFragment TestBlock -> Property
forall blk. HasHeader blk => AnchoredFragment blk -> Property
prop_nonemptyPrefixesOf_nonemptyPrefixesAreUnique
            , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"allShareInputAnchor" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
                Gen (AnchoredFragment TestBlock)
-> (AnchoredFragment TestBlock -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen (AnchoredFragment TestBlock)
genTestAnchoredFragment ((AnchoredFragment TestBlock -> Property) -> Property)
-> (AnchoredFragment TestBlock -> Property) -> Property
forall a b. (a -> b) -> a -> b
$
                  AnchoredFragment TestBlock -> Property
forall blk. HasHeader blk => AnchoredFragment blk -> Property
prop_nonemptyPrefixesOf_allShareInputAnchor
            ]
        , TestName -> [TestTree] -> TestTree
testGroup
            TestName
"deforestBlockTree"
            [ TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"headPointsAreDistinct" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
                Gen (BlockTree TestBlock)
-> (BlockTree TestBlock -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Gen Word -> Gen (BlockTree TestBlock)
genTestBlockTree Gen Word
branchFactor) ((BlockTree TestBlock -> Property) -> Property)
-> (BlockTree TestBlock -> Property) -> Property
forall a b. (a -> b) -> a -> b
$
                  BlockTree TestBlock -> Property
forall blk. HasHeader blk => BlockTree blk -> Property
prop_deforestBlockTree_headPointsAreDistinct
            , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"imagesAreNonempty" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
                Gen (BlockTree TestBlock)
-> (BlockTree TestBlock -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Gen Word -> Gen (BlockTree TestBlock)
genTestBlockTree Gen Word
branchFactor) ((BlockTree TestBlock -> Property) -> Property)
-> (BlockTree TestBlock -> Property) -> Property
forall a b. (a -> b) -> a -> b
$
                  BlockTree TestBlock -> Property
forall blk. BlockTree blk -> Property
prop_deforestBlockTree_imagesAreNonempty
            , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"allShareTrunkAnchor" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
                Gen (BlockTree TestBlock)
-> (BlockTree TestBlock -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Gen Word -> Gen (BlockTree TestBlock)
genTestBlockTree Gen Word
branchFactor) ((BlockTree TestBlock -> Property) -> Property)
-> (BlockTree TestBlock -> Property) -> Property
forall a b. (a -> b) -> a -> b
$
                  BlockTree TestBlock -> Property
forall blk. HasHeader blk => BlockTree blk -> Property
prop_deforestBlockTree_allShareTrunkAnchor
            , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"fullBranchesAreBranches" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
                Gen (BlockTree TestBlock)
-> (BlockTree TestBlock -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Gen Word -> Gen (BlockTree TestBlock)
genTestBlockTree Gen Word
branchFactor) ((BlockTree TestBlock -> Property) -> Property)
-> (BlockTree TestBlock -> Property) -> Property
forall a b. (a -> b) -> a -> b
$
                  BlockTree TestBlock -> Property
forall blk. (Eq blk, HasHeader blk) => BlockTree blk -> Property
prop_deforestBlockTree_fullBranchesAreBranches
            , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"everyHeaderHashIsInTheMap" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
                Gen (BlockTree TestBlock)
-> (BlockTree TestBlock -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Gen Word -> Gen (BlockTree TestBlock)
genTestBlockTree Gen Word
branchFactor) ((BlockTree TestBlock -> Property) -> Property)
-> (BlockTree TestBlock -> Property) -> Property
forall a b. (a -> b) -> a -> b
$
                  BlockTree TestBlock -> Property
forall blk. HasHeader blk => BlockTree blk -> Property
prop_deforestBlockTree_everyHeaderHashIsInTheMap
            , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"prefixMaximalPrefixesAreBranches" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
                Gen (BlockTree TestBlock)
-> (BlockTree TestBlock -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Gen Word -> Gen (BlockTree TestBlock)
genTestBlockTree Gen Word
branchFactor) ((BlockTree TestBlock -> Property) -> Property)
-> (BlockTree TestBlock -> Property) -> Property
forall a b. (a -> b) -> a -> b
$
                  BlockTree TestBlock -> Property
forall blk. (Ord blk, HasHeader blk) => BlockTree blk -> Property
prop_deforestBlockTree_prefixMaximalPrefixesAreBranches
            ]
        ]

-- | The nonempty prefixes of an `AF.AnchoredFragment` are in fact prefixes.
prop_nonemptyPrefixesOf_nonemptyPrefixesArePrefixes ::
  (Eq blk, HasHeader blk) => AF.AnchoredFragment blk -> QC.Property
prop_nonemptyPrefixesOf_nonemptyPrefixesArePrefixes :: forall blk.
(Eq blk, HasHeader blk) =>
AnchoredFragment blk -> Property
prop_nonemptyPrefixesOf_nonemptyPrefixesArePrefixes AnchoredFragment blk
fragment =
  Bool -> Property
forall prop. Testable prop => prop -> Property
QC.property (Bool -> Property)
-> (AnchoredFragment blk -> Bool)
-> AnchoredFragment blk
-> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AnchoredFragment blk -> Bool) -> [AnchoredFragment blk] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((AnchoredFragment blk -> AnchoredFragment blk -> Bool)
-> AnchoredFragment blk -> AnchoredFragment blk -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip AnchoredFragment blk -> AnchoredFragment blk -> Bool
forall v a b.
(Eq a, Eq b) =>
AnchoredSeq v a b -> AnchoredSeq v a b -> Bool
AF.isPrefixOf AnchoredFragment blk
fragment) ([AnchoredFragment blk] -> Bool)
-> (AnchoredFragment blk -> [AnchoredFragment blk])
-> AnchoredFragment blk
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment blk -> [AnchoredFragment blk]
forall blk.
HasHeader blk =>
AnchoredFragment blk -> [AnchoredFragment blk]
nonemptyPrefixesOf (AnchoredFragment blk -> Property)
-> AnchoredFragment blk -> Property
forall a b. (a -> b) -> a -> b
$ AnchoredFragment blk
fragment

-- | The nonempty prefixes of an `AF.AnchoredFragment` are in fact nonempty.
prop_nonemptyPrefixesOf_nonemptyPrefixesAreNonempty ::
  HasHeader blk => AF.AnchoredFragment blk -> QC.Property
prop_nonemptyPrefixesOf_nonemptyPrefixesAreNonempty :: forall blk. HasHeader blk => AnchoredFragment blk -> Property
prop_nonemptyPrefixesOf_nonemptyPrefixesAreNonempty AnchoredFragment blk
fragment =
  Bool -> Property
forall prop. Testable prop => prop -> Property
QC.property (Bool -> Property)
-> (AnchoredFragment blk -> Bool)
-> AnchoredFragment blk
-> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AnchoredFragment blk -> Bool) -> [AnchoredFragment blk] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not (Bool -> Bool)
-> (AnchoredFragment blk -> Bool) -> AnchoredFragment blk -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment blk -> Bool
forall v a b. AnchoredSeq v a b -> Bool
AF.null) ([AnchoredFragment blk] -> Bool)
-> (AnchoredFragment blk -> [AnchoredFragment blk])
-> AnchoredFragment blk
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment blk -> [AnchoredFragment blk]
forall blk.
HasHeader blk =>
AnchoredFragment blk -> [AnchoredFragment blk]
nonemptyPrefixesOf (AnchoredFragment blk -> Property)
-> AnchoredFragment blk -> Property
forall a b. (a -> b) -> a -> b
$ AnchoredFragment blk
fragment

-- | The nonempty prefixes of an `AF.AnchoredFragment` are unique.
prop_nonemptyPrefixesOf_nonemptyPrefixesAreUnique ::
  forall blk. HasHeader blk => AF.AnchoredFragment blk -> QC.Property
prop_nonemptyPrefixesOf_nonemptyPrefixesAreUnique :: forall blk. HasHeader blk => AnchoredFragment blk -> Property
prop_nonemptyPrefixesOf_nonemptyPrefixesAreUnique =
  Bool -> Property
forall prop. Testable prop => prop -> Property
QC.property (Bool -> Property)
-> (AnchoredFragment blk -> Bool)
-> AnchoredFragment blk
-> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[HeaderHash blk]] -> Bool
forall a. Ord a => [a] -> Bool
noDuplicates ([[HeaderHash blk]] -> Bool)
-> (AnchoredFragment blk -> [[HeaderHash blk]])
-> AnchoredFragment blk
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AnchoredFragment blk -> [HeaderHash blk])
-> [AnchoredFragment blk] -> [[HeaderHash blk]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((blk -> HeaderHash blk) -> [blk] -> [HeaderHash blk]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash ([blk] -> [HeaderHash blk])
-> (AnchoredFragment blk -> [blk])
-> AnchoredFragment blk
-> [HeaderHash blk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment blk -> [blk]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst) ([AnchoredFragment blk] -> [[HeaderHash blk]])
-> (AnchoredFragment blk -> [AnchoredFragment blk])
-> AnchoredFragment blk
-> [[HeaderHash blk]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment blk -> [AnchoredFragment blk]
forall blk.
HasHeader blk =>
AnchoredFragment blk -> [AnchoredFragment blk]
nonemptyPrefixesOf

noDuplicates :: Ord a => [a] -> Bool
noDuplicates :: forall a. Ord a => [a] -> Bool
noDuplicates =
  let tally :: k -> Map k Int -> Map k Int
tally k
k = (Int -> Int -> Int) -> k -> Int -> Map k Int -> Map k Int
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) k
k (Int
1 :: Int)
   in (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) ([Int] -> Bool) -> ([a] -> [Int]) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map a Int -> [Int]
forall k a. Map k a -> [a]
M.elems (Map a Int -> [Int]) -> ([a] -> Map a Int) -> [a] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Map a Int -> Map a Int) -> Map a Int -> [a] -> Map a Int
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> Map a Int -> Map a Int
forall {k}. Ord k => k -> Map k Int -> Map k Int
tally Map a Int
forall a. Monoid a => a
mempty

-- | All the nonempty prefixes should share the original fragment's anchor.
prop_nonemptyPrefixesOf_allShareInputAnchor ::
  HasHeader blk => AF.AnchoredFragment blk -> QC.Property
prop_nonemptyPrefixesOf_allShareInputAnchor :: forall blk. HasHeader blk => AnchoredFragment blk -> Property
prop_nonemptyPrefixesOf_allShareInputAnchor AnchoredFragment blk
fragment =
  let sharesTrunkAnchor :: AnchoredFragment blk -> Bool
sharesTrunkAnchor = (Anchor blk -> Anchor blk -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Anchor blk -> Anchor blk -> Bool)
-> (AnchoredFragment blk -> Anchor blk)
-> AnchoredFragment blk
-> AnchoredFragment blk
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` AnchoredFragment blk -> Anchor blk
forall v a b. AnchoredSeq v a b -> a
AF.anchor) AnchoredFragment blk
fragment
   in Bool -> Property
forall prop. Testable prop => prop -> Property
QC.property (Bool -> Property)
-> (AnchoredFragment blk -> Bool)
-> AnchoredFragment blk
-> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AnchoredFragment blk -> Bool) -> [AnchoredFragment blk] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all AnchoredFragment blk -> Bool
sharesTrunkAnchor ([AnchoredFragment blk] -> Bool)
-> (AnchoredFragment blk -> [AnchoredFragment blk])
-> AnchoredFragment blk
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment blk -> [AnchoredFragment blk]
forall blk.
HasHeader blk =>
AnchoredFragment blk -> [AnchoredFragment blk]
nonemptyPrefixesOf (AnchoredFragment blk -> Property)
-> AnchoredFragment blk -> Property
forall a b. (a -> b) -> a -> b
$ AnchoredFragment blk
fragment

-- | The head points of all the branches are distinct.
-- (Points uniquely determine positions in the tree.)
prop_deforestBlockTree_headPointsAreDistinct ::
  HasHeader blk => BlockTree blk -> QC.Property
prop_deforestBlockTree_headPointsAreDistinct :: forall blk. HasHeader blk => BlockTree blk -> Property
prop_deforestBlockTree_headPointsAreDistinct =
  Bool -> Property
forall prop. Testable prop => prop -> Property
QC.property (Bool -> Property)
-> (BlockTree blk -> Bool) -> BlockTree blk -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point blk] -> Bool
forall a. Ord a => [a] -> Bool
noDuplicates ([Point blk] -> Bool)
-> (BlockTree blk -> [Point blk]) -> BlockTree blk -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AnchoredFragment blk -> Point blk)
-> [AnchoredFragment blk] -> [Point blk]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AnchoredFragment blk -> Point blk
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint ([AnchoredFragment blk] -> [Point blk])
-> (BlockTree blk -> [AnchoredFragment blk])
-> BlockTree blk
-> [Point blk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (HeaderHash blk) (AnchoredFragment blk)
-> [AnchoredFragment blk]
forall k a. Map k a -> [a]
M.elems (Map (HeaderHash blk) (AnchoredFragment blk)
 -> [AnchoredFragment blk])
-> (BlockTree blk -> Map (HeaderHash blk) (AnchoredFragment blk))
-> BlockTree blk
-> [AnchoredFragment blk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockTree blk -> Map (HeaderHash blk) (AnchoredFragment blk)
forall blk. BlockTree blk -> DeforestedBlockTree blk
deforestBlockTree

-- | The deforested branches are all populated.
prop_deforestBlockTree_imagesAreNonempty ::
  BlockTree blk -> QC.Property
prop_deforestBlockTree_imagesAreNonempty :: forall blk. BlockTree blk -> Property
prop_deforestBlockTree_imagesAreNonempty =
  Bool -> Property
forall prop. Testable prop => prop -> Property
QC.property (Bool -> Property)
-> (BlockTree blk -> Bool) -> BlockTree blk -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk -> Bool)
-> Map
     (HeaderHash blk) (AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk)
-> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not (Bool -> Bool)
-> (AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk -> Bool)
-> AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk -> Bool
forall v a b. AnchoredSeq v a b -> Bool
AF.null) (Map
   (HeaderHash blk) (AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk)
 -> Bool)
-> (BlockTree blk
    -> Map
         (HeaderHash blk)
         (AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk))
-> BlockTree blk
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockTree blk
-> Map
     (HeaderHash blk) (AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk)
forall blk. BlockTree blk -> DeforestedBlockTree blk
deforestBlockTree

-- | All the deforested branches share the trunk's anchor.
prop_deforestBlockTree_allShareTrunkAnchor ::
  HasHeader blk => BlockTree blk -> QC.Property
prop_deforestBlockTree_allShareTrunkAnchor :: forall blk. HasHeader blk => BlockTree blk -> Property
prop_deforestBlockTree_allShareTrunkAnchor BlockTree blk
tree =
  let sharesTrunkAnchor :: AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk -> Bool
sharesTrunkAnchor = (Anchor blk -> Anchor blk -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Anchor blk -> Anchor blk -> Bool)
-> (AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk -> Anchor blk)
-> AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
-> AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk -> Anchor blk
forall v a b. AnchoredSeq v a b -> a
AF.anchor) (BlockTree blk -> AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk BlockTree blk
tree)
   in Bool -> Property
forall prop. Testable prop => prop -> Property
QC.property (Bool -> Property)
-> (BlockTree blk -> Bool) -> BlockTree blk -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk -> Bool)
-> Map
     (HeaderHash blk) (AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk)
-> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk -> Bool
sharesTrunkAnchor (Map
   (HeaderHash blk) (AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk)
 -> Bool)
-> (BlockTree blk
    -> Map
         (HeaderHash blk)
         (AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk))
-> BlockTree blk
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockTree blk
-> Map
     (HeaderHash blk) (AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk)
forall blk. BlockTree blk -> DeforestedBlockTree blk
deforestBlockTree (BlockTree blk -> Property) -> BlockTree blk -> Property
forall a b. (a -> b) -> a -> b
$ BlockTree blk
tree

-- | Full branches are in the deforestation.
prop_deforestBlockTree_fullBranchesAreBranches ::
  (Eq blk, HasHeader blk) => BlockTree blk -> QC.Property
prop_deforestBlockTree_fullBranchesAreBranches :: forall blk. (Eq blk, HasHeader blk) => BlockTree blk -> Property
prop_deforestBlockTree_fullBranchesAreBranches BlockTree blk
tree =
  let inDeforestation :: AnchoredFragment blk -> Bool
inDeforestation = (AnchoredFragment blk
 -> Map (HeaderHash blk) (AnchoredFragment blk) -> Bool)
-> Map (HeaderHash blk) (AnchoredFragment blk)
-> AnchoredFragment blk
-> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip AnchoredFragment blk
-> Map (HeaderHash blk) (AnchoredFragment blk) -> Bool
forall a. Eq a => a -> Map (HeaderHash blk) a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (BlockTree blk -> Map (HeaderHash blk) (AnchoredFragment blk)
forall blk. BlockTree blk -> DeforestedBlockTree blk
deforestBlockTree BlockTree blk
tree)
   in Bool -> Property
forall prop. Testable prop => prop -> Property
QC.property (Bool -> Property)
-> (BlockTree blk -> Bool) -> BlockTree blk -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AnchoredFragment blk -> Bool) -> [AnchoredFragment blk] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all AnchoredFragment blk -> Bool
inDeforestation ([AnchoredFragment blk] -> Bool)
-> (BlockTree blk -> [AnchoredFragment blk])
-> BlockTree blk
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BlockTreeBranch blk -> AnchoredFragment blk)
-> [BlockTreeBranch blk] -> [AnchoredFragment blk]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BlockTreeBranch blk -> AnchoredFragment blk
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbFull ([BlockTreeBranch blk] -> [AnchoredFragment blk])
-> (BlockTree blk -> [BlockTreeBranch blk])
-> BlockTree blk
-> [AnchoredFragment blk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockTree blk -> [BlockTreeBranch blk]
forall blk. BlockTree blk -> [BlockTreeBranch blk]
btBranches (BlockTree blk -> Property) -> BlockTree blk -> Property
forall a b. (a -> b) -> a -> b
$ BlockTree blk
tree

-- | Every block header from the `BlockTree` is in the deforestation map.
prop_deforestBlockTree_everyHeaderHashIsInTheMap ::
  forall blk. HasHeader blk => BlockTree blk -> QC.Property
prop_deforestBlockTree_everyHeaderHashIsInTheMap :: forall blk. HasHeader blk => BlockTree blk -> Property
prop_deforestBlockTree_everyHeaderHashIsInTheMap tree :: BlockTree blk
tree@(BlockTree AnchoredFragment blk
trunk [BlockTreeBranch blk]
branches) =
  let
    allBranchHeaderHashes :: BlockTreeBranch blk -> [HeaderHash blk]
    allBranchHeaderHashes :: BlockTreeBranch blk -> [HeaderHash blk]
allBranchHeaderHashes (BlockTreeBranch AnchoredFragment blk
prefix AnchoredFragment blk
suffix AnchoredFragment blk
restOfTrunk AnchoredFragment blk
full) =
      (blk -> HeaderHash blk) -> [blk] -> [HeaderHash blk]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash ([blk] -> [HeaderHash blk]) -> [blk] -> [HeaderHash blk]
forall a b. (a -> b) -> a -> b
$ (AnchoredFragment blk -> [blk]) -> [AnchoredFragment blk] -> [blk]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap AnchoredFragment blk -> [blk]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst [AnchoredFragment blk
prefix, AnchoredFragment blk
suffix, AnchoredFragment blk
restOfTrunk, AnchoredFragment blk
full]

    allHeaderHashes :: [HeaderHash blk]
    allHeaderHashes :: [HeaderHash blk]
allHeaderHashes =
      (blk -> HeaderHash blk) -> [blk] -> [HeaderHash blk]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash (AnchoredFragment blk -> [blk]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst AnchoredFragment blk
trunk)
        [HeaderHash blk] -> [HeaderHash blk] -> [HeaderHash blk]
forall a. Semigroup a => a -> a -> a
<> (BlockTreeBranch blk -> [HeaderHash blk])
-> [BlockTreeBranch blk] -> [HeaderHash blk]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap BlockTreeBranch blk -> [HeaderHash blk]
allBranchHeaderHashes [BlockTreeBranch blk]
branches
   in
    Bool -> Property
forall prop. Testable prop => prop -> Property
QC.property (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ (HeaderHash blk -> Bool) -> [HeaderHash blk] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((HeaderHash blk
 -> Map (HeaderHash blk) (AnchoredFragment blk) -> Bool)
-> Map (HeaderHash blk) (AnchoredFragment blk)
-> HeaderHash blk
-> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip HeaderHash blk
-> Map (HeaderHash blk) (AnchoredFragment blk) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member (Map (HeaderHash blk) (AnchoredFragment blk)
 -> HeaderHash blk -> Bool)
-> Map (HeaderHash blk) (AnchoredFragment blk)
-> HeaderHash blk
-> Bool
forall a b. (a -> b) -> a -> b
$ BlockTree blk -> Map (HeaderHash blk) (AnchoredFragment blk)
forall blk. BlockTree blk -> DeforestedBlockTree blk
deforestBlockTree BlockTree blk
tree) [HeaderHash blk]
allHeaderHashes

-- | An `AF.AnchoredFragment` is /prefix maximal/ in a list if it is not a nontrivial
-- prefix of another fragment in the list. After deforesting a tree, the maximal
-- prefixes in the result are precisely the trunk and branches of the tree in
-- some order.
prop_deforestBlockTree_prefixMaximalPrefixesAreBranches ::
  forall blk. (Ord blk, HasHeader blk) => BlockTree blk -> QC.Property
prop_deforestBlockTree_prefixMaximalPrefixesAreBranches :: forall blk. (Ord blk, HasHeader blk) => BlockTree blk -> Property
prop_deforestBlockTree_prefixMaximalPrefixesAreBranches tree :: BlockTree blk
tree@(BlockTree AnchoredFragment blk
trunk [BlockTreeBranch blk]
branches) =
  Bool -> Property
forall prop. Testable prop => prop -> Property
QC.property (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$
    ([[blk]] -> [[blk]] -> Bool
forall a. Eq a => a -> a -> Bool
(==) ([[blk]] -> [[blk]] -> Bool)
-> ([AnchoredFragment blk] -> [[blk]])
-> [AnchoredFragment blk]
-> [AnchoredFragment blk]
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ([[blk]] -> [[blk]]
forall a. Ord a => [a] -> [a]
L.sort ([[blk]] -> [[blk]])
-> ([AnchoredFragment blk] -> [[blk]])
-> [AnchoredFragment blk]
-> [[blk]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AnchoredFragment blk -> [blk])
-> [AnchoredFragment blk] -> [[blk]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AnchoredFragment blk -> [blk]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst))
      ((AnchoredFragment blk
 -> [AnchoredFragment blk] -> [AnchoredFragment blk])
-> [AnchoredFragment blk]
-> Map (HeaderHash blk) (AnchoredFragment blk)
-> [AnchoredFragment blk]
forall a b. (a -> b -> b) -> b -> Map (HeaderHash blk) a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((AnchoredFragment blk -> AnchoredFragment blk -> Bool)
-> AnchoredFragment blk
-> [AnchoredFragment blk]
-> [AnchoredFragment blk]
forall u. (u -> u -> Bool) -> u -> [u] -> [u]
insertIfMaximalBy AnchoredFragment blk -> AnchoredFragment blk -> Bool
forall v a b.
(Eq a, Eq b) =>
AnchoredSeq v a b -> AnchoredSeq v a b -> Bool
AF.isPrefixOf) [] (Map (HeaderHash blk) (AnchoredFragment blk)
 -> [AnchoredFragment blk])
-> Map (HeaderHash blk) (AnchoredFragment blk)
-> [AnchoredFragment blk]
forall a b. (a -> b) -> a -> b
$ BlockTree blk -> Map (HeaderHash blk) (AnchoredFragment blk)
forall blk. BlockTree blk -> DeforestedBlockTree blk
deforestBlockTree BlockTree blk
tree)
      (AnchoredFragment blk
trunk AnchoredFragment blk
-> [AnchoredFragment blk] -> [AnchoredFragment blk]
forall a. a -> [a] -> [a]
: (BlockTreeBranch blk -> AnchoredFragment blk)
-> [BlockTreeBranch blk] -> [AnchoredFragment blk]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BlockTreeBranch blk -> AnchoredFragment blk
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbFull [BlockTreeBranch blk]
branches)

-- | If @u@ is smaller than any of the elements of @xs@, return @xs@.
-- Otherwise, remove any elements of @xs@ smaller than @u@ and append @u@ to
-- the remainder on the right.
insertIfMaximalBy :: forall u. (u -> u -> Bool) -> u -> [u] -> [u]
insertIfMaximalBy :: forall u. (u -> u -> Bool) -> u -> [u] -> [u]
insertIfMaximalBy u -> u -> Bool
lessThan u
u =
  let
    go :: [u] -> [u]
go [u]
xs = case [u]
xs of
      [] -> [u
u]
      u
x : [u]
rest -> case u
x u -> u -> Bool
`lessThan` u
u of
        Bool
True -> [u] -> [u]
go [u]
rest
        Bool
False ->
          u
x
            u -> [u] -> [u]
forall a. a -> [a] -> [a]
: case u
u u -> u -> Bool
`lessThan` u
x of
              Bool
True -> [u]
rest
              Bool
False -> [u] -> [u]
go [u]
rest
   in
    [u] -> [u]
go