{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UndecidableInstances #-}

module Test.Ouroboros.Storage.ChainDB.Paths (tests) where

import           Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NE
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Fragment.Diff (ChainDiff (..))
import qualified Ouroboros.Consensus.Fragment.Diff as Diff
import           Ouroboros.Consensus.Storage.ChainDB.Impl.Paths (isReachable)
import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB
import           Ouroboros.Network.AnchoredFragment (AnchoredFragment)
import qualified Ouroboros.Network.AnchoredFragment as AF
import           Test.Ouroboros.Storage.TestBlock
import           Test.Tasty
import           Test.Tasty.QuickCheck
import           Test.Util.Orphans.Arbitrary ()

{-------------------------------------------------------------------------------
  Top-level tests
-------------------------------------------------------------------------------}

tests :: TestTree
tests :: TestTree
tests = TestName -> [TestTree] -> TestTree
testGroup TestName
"Paths" [
      TestName -> (ReachableSetup TestBlock -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"isReachable" ReachableSetup TestBlock -> Property
prop_isReachable
    ]

{-------------------------------------------------------------------------------
  Test properties
-------------------------------------------------------------------------------}

prop_isReachable :: ReachableSetup TestBlock -> Property
prop_isReachable :: ReachableSetup TestBlock -> Property
prop_isReachable ReachableSetup { AnchoredFragment (Header TestBlock)
currentChain :: AnchoredFragment (Header TestBlock)
currentChain :: forall blk. ReachableSetup blk -> AnchoredFragment (Header blk)
currentChain, RealPoint TestBlock
forkTip :: RealPoint TestBlock
forkTip :: forall blk. ReachableSetup blk -> RealPoint blk
forkTip, Maybe (ChainDiff (HeaderFields TestBlock))
fork :: Maybe (ChainDiff (HeaderFields TestBlock))
fork :: forall blk.
ReachableSetup blk -> Maybe (ChainDiff (HeaderFields blk))
fork, Map (HeaderHash TestBlock) (BlockInfo TestBlock)
blockInfo :: Map (HeaderHash TestBlock) (BlockInfo TestBlock)
blockInfo :: forall blk.
ReachableSetup blk -> Map (HeaderHash blk) (BlockInfo blk)
blockInfo } =
        LookupBlockInfo TestBlock
-> AnchoredFragment (Header TestBlock)
-> RealPoint TestBlock
-> Maybe (ChainDiff (HeaderFields TestBlock))
forall blk.
(HasHeader blk, GetHeader blk) =>
LookupBlockInfo blk
-> AnchoredFragment (Header blk)
-> RealPoint blk
-> Maybe (ChainDiff (HeaderFields blk))
isReachable ((TestHeaderHash
 -> Map TestHeaderHash (BlockInfo TestBlock)
 -> Maybe (BlockInfo TestBlock))
-> Map TestHeaderHash (BlockInfo TestBlock)
-> TestHeaderHash
-> Maybe (BlockInfo TestBlock)
forall a b c. (a -> b -> c) -> b -> a -> c
flip TestHeaderHash
-> Map TestHeaderHash (BlockInfo TestBlock)
-> Maybe (BlockInfo TestBlock)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Map (HeaderHash TestBlock) (BlockInfo TestBlock)
Map TestHeaderHash (BlockInfo TestBlock)
blockInfo) AnchoredFragment (Header TestBlock)
currentChain RealPoint TestBlock
forkTip
    Maybe (ChainDiff (HeaderFields TestBlock))
-> Maybe (ChainDiff (HeaderFields TestBlock)) -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Maybe (ChainDiff (HeaderFields TestBlock))
fork

{-------------------------------------------------------------------------------
  Test setup
-------------------------------------------------------------------------------}

data ReachableSetup blk = ReachableSetup {
      forall blk. ReachableSetup blk -> AnchoredFragment (Header blk)
currentChain :: AnchoredFragment (Header blk)
    , forall blk. ReachableSetup blk -> RealPoint blk
forkTip      :: RealPoint blk
    , forall blk.
ReachableSetup blk -> Maybe (ChainDiff (HeaderFields blk))
fork         :: Maybe (ChainDiff (HeaderFields blk))
    , forall blk.
ReachableSetup blk -> Map (HeaderHash blk) (BlockInfo blk)
blockInfo    :: Map (HeaderHash blk) (VolatileDB.BlockInfo blk)
    }

deriving instance (HasHeader blk, Show (Header blk)) => Show (ReachableSetup blk)

{-------------------------------------------------------------------------------
  Generators
-------------------------------------------------------------------------------}

-- | All blocks on the current chain use this value as for their body. This
-- allows us to statically convert a header from the current chain to a block.
currentChainBody :: TestBody
currentChainBody :: TestBody
currentChainBody = Word -> Bool -> TestBody
TestBody Word
0 Bool
True

genFirstBlock ::
     Gen TestBody
  -> Gen TestBlock
genFirstBlock :: Gen TestBody -> Gen TestBlock
genFirstBlock Gen TestBody
genBody = [Gen TestBlock] -> Gen TestBlock
forall a. HasCallStack => [Gen a] -> Gen a
oneof
    [ SlotNo -> TestBody -> TestBlock
firstBlock SlotNo
0            (TestBody -> TestBlock) -> Gen TestBody -> Gen TestBlock
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen TestBody
genBody
    , (SlotNo -> Bool) -> TestBody -> TestBlock
firstEBB   (Bool -> SlotNo -> Bool
forall a b. a -> b -> a
const Bool
True) (TestBody -> TestBlock) -> Gen TestBody -> Gen TestBlock
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen TestBody
genBody
    ]

genSuccessor ::
     (HeaderFields TestBlock, IsEBB, ChainLength)
  -> Gen TestBody
  -> Gen TestBlock
genSuccessor :: (HeaderFields TestBlock, IsEBB, ChainLength)
-> Gen TestBody -> Gen TestBlock
genSuccessor (HeaderFields TestBlock
prevHeaderFields, IsEBB
prevIsEBB, ChainLength
prevChainLength) Gen TestBody
genBody = [(Int, Gen TestBlock)] -> Gen TestBlock
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
    [ ( if Bool
prevWasEBB then Int
0 else Int
1
      , (SlotNo -> Bool)
-> (HeaderFields TestBlock, ChainLength)
-> SlotNo
-> EpochNo
-> TestBody
-> TestBlock
mkNextEBB' (Bool -> SlotNo -> Bool
forall a b. a -> b -> a
const Bool
True) (HeaderFields TestBlock
prevHeaderFields, ChainLength
prevChainLength)
          (SlotNo -> EpochNo -> TestBody -> TestBlock)
-> Gen SlotNo -> Gen (EpochNo -> TestBody -> TestBlock)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SlotNo -> SlotNo -> Gen SlotNo
chooseSlot (SlotNo
prevSlot SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
1) (SlotNo
prevSlot SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
2)
          -- We don't care about EpochNo
          Gen (EpochNo -> TestBody -> TestBlock)
-> Gen EpochNo -> Gen (TestBody -> TestBlock)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> EpochNo -> Gen EpochNo
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return EpochNo
0
          Gen (TestBody -> TestBlock) -> Gen TestBody -> Gen TestBlock
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen TestBody
genBody
      )
    , (Int
3
      , (HeaderFields TestBlock, ChainLength)
-> SlotNo -> TestBody -> TestBlock
mkNextBlock' (HeaderFields TestBlock
prevHeaderFields, ChainLength
prevChainLength)
          (SlotNo -> TestBody -> TestBlock)
-> Gen SlotNo -> Gen (TestBody -> TestBlock)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SlotNo -> SlotNo -> Gen SlotNo
chooseSlot (SlotNo
prevSlot SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ if Bool
prevWasEBB then SlotNo
0 else SlotNo
1) (SlotNo
prevSlot SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
2)
          Gen (TestBody -> TestBlock) -> Gen TestBody -> Gen TestBlock
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen TestBody
genBody
      )
    ]
  where
    prevSlot :: SlotNo
prevSlot  = HeaderFields TestBlock -> SlotNo
forall k (b :: k). HeaderFields b -> SlotNo
headerFieldSlot HeaderFields TestBlock
prevHeaderFields
    prevWasEBB :: Bool
prevWasEBB = case IsEBB
prevIsEBB of
        IsEBB
IsEBB    -> Bool
True
        IsEBB
IsNotEBB -> Bool
False

    chooseSlot :: SlotNo -> SlotNo -> Gen SlotNo
    chooseSlot :: SlotNo -> SlotNo -> Gen SlotNo
chooseSlot (SlotNo Word64
start) (SlotNo Word64
end) = Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Gen Word64 -> Gen SlotNo
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
start, Word64
end)

genChainHelper ::
     Gen TestBody
  -> Int
     -- ^ Number of headers to generate
  -> WithOrigin (HeaderFields TestBlock, IsEBB, ChainLength)
     -- ^ Optional previous block
  -> Gen (AnchoredFragment (Header TestBlock))
genChainHelper :: Gen TestBody
-> Int
-> WithOrigin (HeaderFields TestBlock, IsEBB, ChainLength)
-> Gen (AnchoredFragment (Header TestBlock))
genChainHelper Gen TestBody
genBody = \Int
n WithOrigin (HeaderFields TestBlock, IsEBB, ChainLength)
optPrevBlk ->
    case WithOrigin (HeaderFields TestBlock, IsEBB, ChainLength)
optPrevBlk of
      WithOrigin (HeaderFields TestBlock, IsEBB, ChainLength)
Origin | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 ->
        AnchoredFragment (Header TestBlock)
-> Gen (AnchoredFragment (Header TestBlock))
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (AnchoredFragment (Header TestBlock)
 -> Gen (AnchoredFragment (Header TestBlock)))
-> AnchoredFragment (Header TestBlock)
-> Gen (AnchoredFragment (Header TestBlock))
forall a b. (a -> b) -> a -> b
$ Anchor (Header TestBlock) -> AnchoredFragment (Header TestBlock)
forall v a b. Anchorable v a b => a -> AnchoredSeq v a b
AF.Empty Anchor (Header TestBlock)
forall block. Anchor block
AF.AnchorGenesis

      WithOrigin (HeaderFields TestBlock, IsEBB, ChainLength)
Origin -> do
        TestBlock
firstBlk <- Gen TestBody -> Gen TestBlock
genFirstBlock Gen TestBody
genBody
        let initAcc :: AnchoredFragment (Header TestBlock)
initAcc  = Anchor (Header TestBlock) -> AnchoredFragment (Header TestBlock)
forall v a b. Anchorable v a b => a -> AnchoredSeq v a b
AF.Empty Anchor (Header TestBlock)
forall block. Anchor block
AF.AnchorGenesis AnchoredFragment (Header TestBlock)
-> Header TestBlock -> AnchoredFragment (Header TestBlock)
forall v a b.
Anchorable v a b =>
AnchoredSeq v a b -> b -> AnchoredSeq v a b
AF.:> TestBlock -> Header TestBlock
forall blk. GetHeader blk => blk -> Header blk
getHeader TestBlock
firstBlk
            prevInfo :: (HeaderFields TestBlock, IsEBB, ChainLength)
prevInfo = ( TestBlock -> HeaderFields TestBlock
forall blk. GetHeader blk => blk -> HeaderFields blk
getBlockHeaderFields TestBlock
firstBlk
                       , TestBlock -> IsEBB
forall blk. GetHeader blk => blk -> IsEBB
blockToIsEBB TestBlock
firstBlk
                       , Int -> ChainLength
ChainLength Int
1
                       )
        Int
-> (HeaderFields TestBlock, IsEBB, ChainLength)
-> AnchoredFragment (Header TestBlock)
-> Gen (AnchoredFragment (Header TestBlock))
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (HeaderFields TestBlock, IsEBB, ChainLength)
prevInfo AnchoredFragment (Header TestBlock)
initAcc

      NotOrigin prevInfo :: (HeaderFields TestBlock, IsEBB, ChainLength)
prevInfo@(HeaderFields TestBlock
prevHeaderFields, IsEBB
_, ChainLength
_) -> do
        let anchor :: Anchor (Header TestBlock)
anchor  = SlotNo
-> HeaderHash (Header TestBlock)
-> BlockNo
-> Anchor (Header TestBlock)
forall block. SlotNo -> HeaderHash block -> BlockNo -> Anchor block
AF.Anchor
                        (HeaderFields TestBlock -> SlotNo
forall k (b :: k). HeaderFields b -> SlotNo
headerFieldSlot    HeaderFields TestBlock
prevHeaderFields)
                        (HeaderFields TestBlock -> HeaderHash TestBlock
forall k (b :: k). HeaderFields b -> HeaderHash b
headerFieldHash    HeaderFields TestBlock
prevHeaderFields)
                        (HeaderFields TestBlock -> BlockNo
forall k (b :: k). HeaderFields b -> BlockNo
headerFieldBlockNo HeaderFields TestBlock
prevHeaderFields)
            initAcc :: AnchoredFragment (Header TestBlock)
initAcc = Anchor (Header TestBlock) -> AnchoredFragment (Header TestBlock)
forall v a b. Anchorable v a b => a -> AnchoredSeq v a b
AF.Empty Anchor (Header TestBlock)
anchor
        Int
-> (HeaderFields TestBlock, IsEBB, ChainLength)
-> AnchoredFragment (Header TestBlock)
-> Gen (AnchoredFragment (Header TestBlock))
go Int
n (HeaderFields TestBlock, IsEBB, ChainLength)
prevInfo AnchoredFragment (Header TestBlock)
initAcc
  where
    go ::
         Int
      -> (HeaderFields TestBlock, IsEBB, ChainLength)
      -> AnchoredFragment (Header TestBlock)
      -> Gen (AnchoredFragment (Header TestBlock))
    go :: Int
-> (HeaderFields TestBlock, IsEBB, ChainLength)
-> AnchoredFragment (Header TestBlock)
-> Gen (AnchoredFragment (Header TestBlock))
go Int
n prevInfo :: (HeaderFields TestBlock, IsEBB, ChainLength)
prevInfo@(HeaderFields TestBlock
_, IsEBB
_, ChainLength
prevChainLength) AnchoredFragment (Header TestBlock)
acc = case Int
n of
      Int
0 -> AnchoredFragment (Header TestBlock)
-> Gen (AnchoredFragment (Header TestBlock))
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return AnchoredFragment (Header TestBlock)
acc
      Int
_ -> do
        TestBlock
blk <- (HeaderFields TestBlock, IsEBB, ChainLength)
-> Gen TestBody -> Gen TestBlock
genSuccessor (HeaderFields TestBlock, IsEBB, ChainLength)
prevInfo Gen TestBody
genBody
        let isEBB :: IsEBB
isEBB     = TestBlock -> IsEBB
forall blk. GetHeader blk => blk -> IsEBB
blockToIsEBB TestBlock
blk
            prevInfo' :: (HeaderFields TestBlock, IsEBB, ChainLength)
prevInfo' = (TestBlock -> HeaderFields TestBlock
forall blk. GetHeader blk => blk -> HeaderFields blk
getBlockHeaderFields TestBlock
blk, IsEBB
isEBB, ChainLength -> ChainLength
forall a. Enum a => a -> a
succ ChainLength
prevChainLength)
        Int
-> (HeaderFields TestBlock, IsEBB, ChainLength)
-> AnchoredFragment (Header TestBlock)
-> Gen (AnchoredFragment (Header TestBlock))
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (HeaderFields TestBlock, IsEBB, ChainLength)
prevInfo' (AnchoredFragment (Header TestBlock)
acc AnchoredFragment (Header TestBlock)
-> Header TestBlock -> AnchoredFragment (Header TestBlock)
forall v a b.
Anchorable v a b =>
AnchoredSeq v a b -> b -> AnchoredSeq v a b
AF.:> TestBlock -> Header TestBlock
forall blk. GetHeader blk => blk -> Header blk
getHeader TestBlock
blk)

-- | Also returns the header corresponding to the anchor, unless the anchor is
-- genesis.
generateChain :: Gen ( AnchoredFragment (Header TestBlock)
                     , Maybe (Header TestBlock)
                     )
generateChain :: Gen (AnchoredFragment (Header TestBlock), Maybe (Header TestBlock))
generateChain = (Int
 -> Gen
      (AnchoredFragment (Header TestBlock), Maybe (Header TestBlock)))
-> Gen
     (AnchoredFragment (Header TestBlock), Maybe (Header TestBlock))
forall a. (Int -> Gen a) -> Gen a
sized ((Int
  -> Gen
       (AnchoredFragment (Header TestBlock), Maybe (Header TestBlock)))
 -> Gen
      (AnchoredFragment (Header TestBlock), Maybe (Header TestBlock)))
-> (Int
    -> Gen
         (AnchoredFragment (Header TestBlock), Maybe (Header TestBlock)))
-> Gen
     (AnchoredFragment (Header TestBlock), Maybe (Header TestBlock))
forall a b. (a -> b) -> a -> b
$ \Int
size -> do
    Int
takeNewestN <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
size)
    AnchoredFragment (Header TestBlock)
fullChain   <- Gen TestBody
-> Int
-> WithOrigin (HeaderFields TestBlock, IsEBB, ChainLength)
-> Gen (AnchoredFragment (Header TestBlock))
genChainHelper (TestBody -> Gen TestBody
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return TestBody
currentChainBody) Int
size WithOrigin (HeaderFields TestBlock, IsEBB, ChainLength)
forall t. WithOrigin t
Origin
    let mbAnchorHdr :: Maybe (Header TestBlock)
mbAnchorHdr = case AnchoredFragment (Header TestBlock)
-> Either (Anchor (Header TestBlock)) (Header TestBlock)
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Either a b
AF.head (Int
-> AnchoredFragment (Header TestBlock)
-> AnchoredFragment (Header TestBlock)
forall v a b.
Anchorable v a b =>
Int -> AnchoredSeq v a b -> AnchoredSeq v a b
AF.dropNewest Int
takeNewestN AnchoredFragment (Header TestBlock)
fullChain) of
                        Left Anchor (Header TestBlock)
_          -> Maybe (Header TestBlock)
forall a. Maybe a
Nothing
                        Right Header TestBlock
anchorHdr -> Header TestBlock -> Maybe (Header TestBlock)
forall a. a -> Maybe a
Just Header TestBlock
anchorHdr
    (AnchoredFragment (Header TestBlock), Maybe (Header TestBlock))
-> Gen
     (AnchoredFragment (Header TestBlock), Maybe (Header TestBlock))
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64
-> AnchoredFragment (Header TestBlock)
-> AnchoredFragment (Header 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 Int
takeNewestN) AnchoredFragment (Header TestBlock)
fullChain, Maybe (Header TestBlock)
mbAnchorHdr)

-- | NOTE: the fork must be the minimal fork, i.e., it must not contain headers
-- that are also part of the current chain.
generateFork ::
     ( AnchoredFragment (Header TestBlock)
     , Maybe (Header TestBlock)
     )
  -> Gen (ChainDiff (HeaderFields TestBlock), [Header TestBlock])
generateFork :: (AnchoredFragment (Header TestBlock), Maybe (Header TestBlock))
-> Gen (ChainDiff (HeaderFields TestBlock), [Header TestBlock])
generateFork (AnchoredFragment (Header TestBlock)
chain, Maybe (Header TestBlock)
mbAnchorHdr) = (Int
 -> Gen (ChainDiff (HeaderFields TestBlock), [Header TestBlock]))
-> Gen (ChainDiff (HeaderFields TestBlock), [Header TestBlock])
forall a. (Int -> Gen a) -> Gen a
sized ((Int
  -> Gen (ChainDiff (HeaderFields TestBlock), [Header TestBlock]))
 -> Gen (ChainDiff (HeaderFields TestBlock), [Header TestBlock]))
-> (Int
    -> Gen (ChainDiff (HeaderFields TestBlock), [Header TestBlock]))
-> Gen (ChainDiff (HeaderFields TestBlock), [Header TestBlock])
forall a b. (a -> b) -> a -> b
$ \Int
size -> do
    -- Roll back 0 or more headers and add 0 or more headers
    Int
rollback <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, AnchoredFragment (Header TestBlock) -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length AnchoredFragment (Header TestBlock)
chain)
    let mbPrevHdr :: Maybe (Header TestBlock)
mbPrevHdr = case AnchoredFragment (Header TestBlock)
-> Either (Anchor (Header TestBlock)) (Header TestBlock)
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Either a b
AF.head (Int
-> AnchoredFragment (Header TestBlock)
-> AnchoredFragment (Header TestBlock)
forall v a b.
Anchorable v a b =>
Int -> AnchoredSeq v a b -> AnchoredSeq v a b
AF.dropNewest Int
rollback AnchoredFragment (Header TestBlock)
chain) of
          Left Anchor (Header TestBlock)
_    -> Maybe (Header TestBlock)
mbAnchorHdr
          Right Header TestBlock
hdr -> Header TestBlock -> Maybe (Header TestBlock)
forall a. a -> Maybe a
Just Header TestBlock
hdr
        wiPrevInfo :: WithOrigin (HeaderFields TestBlock, IsEBB, ChainLength)
wiPrevInfo = Header TestBlock -> (HeaderFields TestBlock, IsEBB, ChainLength)
headerToPrevInfo (Header TestBlock -> (HeaderFields TestBlock, IsEBB, ChainLength))
-> WithOrigin (Header TestBlock)
-> WithOrigin (HeaderFields TestBlock, IsEBB, ChainLength)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Header TestBlock) -> WithOrigin (Header TestBlock)
forall t. Maybe t -> WithOrigin t
withOriginFromMaybe Maybe (Header TestBlock)
mbPrevHdr
    Int
toAdd <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
size)
    AnchoredFragment (Header TestBlock)
suffix <- Gen TestBody
-> Int
-> WithOrigin (HeaderFields TestBlock, IsEBB, ChainLength)
-> Gen (AnchoredFragment (Header TestBlock))
genChainHelper Gen TestBody
genBody Int
toAdd WithOrigin (HeaderFields TestBlock, IsEBB, ChainLength)
wiPrevInfo
    let diff :: ChainDiff (HeaderFields TestBlock)
diff = Word64
-> AnchoredFragment (HeaderFields TestBlock)
-> ChainDiff (HeaderFields TestBlock)
forall b. Word64 -> AnchoredFragment b -> ChainDiff b
ChainDiff
                 (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
rollback)
                 ((Header TestBlock -> HeaderFields TestBlock)
-> AnchoredFragment (Header TestBlock)
-> AnchoredFragment (HeaderFields TestBlock)
forall block2 block1.
(HasHeader block2, HeaderHash block1 ~ HeaderHash block2) =>
(block1 -> block2)
-> AnchoredFragment block1 -> AnchoredFragment block2
AF.mapAnchoredFragment
                   (HeaderFields (Header TestBlock) -> HeaderFields TestBlock
forall {k1} {k2} (b :: k1) (b' :: k2).
(HeaderHash b ~ HeaderHash b') =>
HeaderFields b -> HeaderFields b'
castHeaderFields (HeaderFields (Header TestBlock) -> HeaderFields TestBlock)
-> (Header TestBlock -> HeaderFields (Header TestBlock))
-> Header TestBlock
-> HeaderFields TestBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header TestBlock -> HeaderFields (Header TestBlock)
forall b. HasHeader b => b -> HeaderFields b
getHeaderFields)
                   AnchoredFragment (Header TestBlock)
suffix)
    (ChainDiff (HeaderFields TestBlock), [Header TestBlock])
-> Gen (ChainDiff (HeaderFields TestBlock), [Header TestBlock])
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (ChainDiff (HeaderFields TestBlock)
diff, AnchoredFragment (Header TestBlock) -> [Header TestBlock]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst AnchoredFragment (Header TestBlock)
suffix)
  where
    genBody :: Gen TestBody
    genBody :: Gen TestBody
genBody = (Word -> Bool -> TestBody
`TestBody` Bool
True) (Word -> TestBody) -> Gen Word -> Gen TestBody
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word, Word) -> Gen Word
forall a. Random a => (a, a) -> Gen a
choose (Word
1, Word
3)

    headerToPrevInfo ::
         Header TestBlock
      -> (HeaderFields TestBlock, IsEBB, ChainLength)
    headerToPrevInfo :: Header TestBlock -> (HeaderFields TestBlock, IsEBB, ChainLength)
headerToPrevInfo Header TestBlock
hdr =
        ( HeaderFields (Header TestBlock) -> HeaderFields TestBlock
forall {k1} {k2} (b :: k1) (b' :: k2).
(HeaderHash b ~ HeaderHash b') =>
HeaderFields b -> HeaderFields b'
castHeaderFields (HeaderFields (Header TestBlock) -> HeaderFields TestBlock)
-> HeaderFields (Header TestBlock) -> HeaderFields TestBlock
forall a b. (a -> b) -> a -> b
$ Header TestBlock -> HeaderFields (Header TestBlock)
forall b. HasHeader b => b -> HeaderFields b
getHeaderFields Header TestBlock
hdr
        , Header TestBlock -> IsEBB
forall blk. GetHeader blk => Header blk -> IsEBB
headerToIsEBB Header TestBlock
hdr
        , TestHeader -> ChainLength
thChainLength (TestHeader -> ChainLength) -> TestHeader -> ChainLength
forall a b. (a -> b) -> a -> b
$ Header TestBlock -> TestHeader
unTestHeader Header TestBlock
hdr
        )

-- | Generate headers that don't fit onto the given chain, but that may fit
-- onto each other.
generateDisconnectedHeaders ::
     ( AnchoredFragment (Header TestBlock)
     , Maybe (Header TestBlock)
     )
  -> Gen (NonEmpty (Header TestBlock))
generateDisconnectedHeaders :: (AnchoredFragment (Header TestBlock), Maybe (Header TestBlock))
-> Gen (NonEmpty (Header TestBlock))
generateDisconnectedHeaders (AnchoredFragment (Header TestBlock)
chain, Maybe (Header TestBlock)
mbAnchorHdr) =
    (AnchoredFragment (Header TestBlock), Maybe (Header TestBlock))
-> Gen (ChainDiff (HeaderFields TestBlock), [Header TestBlock])
generateFork (AnchoredFragment (Header TestBlock)
chain, Maybe (Header TestBlock)
mbAnchorHdr) Gen (ChainDiff (HeaderFields TestBlock), [Header TestBlock])
-> ((ChainDiff (HeaderFields TestBlock), [Header TestBlock])
    -> Maybe (NonEmpty (Header TestBlock)))
-> Gen (NonEmpty (Header TestBlock))
forall a b. Gen a -> (a -> Maybe b) -> Gen b
`suchThatMap` (ChainDiff (HeaderFields TestBlock), [Header TestBlock])
-> Maybe (NonEmpty (Header TestBlock))
dropConnectingBlock
  where
    -- 'Maybe' because the suffix might be empty or contain only a single
    -- block, which is the connecting one which we have to drop
    dropConnectingBlock ::
         (ChainDiff (HeaderFields TestBlock), [Header TestBlock])
      -> Maybe (NonEmpty (Header TestBlock))
    dropConnectingBlock :: (ChainDiff (HeaderFields TestBlock), [Header TestBlock])
-> Maybe (NonEmpty (Header TestBlock))
dropConnectingBlock (ChainDiff Word64
_ AnchoredFragment (HeaderFields TestBlock)
suffix, [Header TestBlock]
hdrs) = do
        Point TestBlock
connectingPt <- (Anchor (HeaderFields TestBlock) -> Maybe (Point TestBlock))
-> (HeaderFields TestBlock -> Maybe (Point TestBlock))
-> Either
     (Anchor (HeaderFields TestBlock)) (HeaderFields TestBlock)
-> Maybe (Point TestBlock)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe (Point TestBlock)
-> Anchor (HeaderFields TestBlock) -> Maybe (Point TestBlock)
forall a b. a -> b -> a
const Maybe (Point TestBlock)
forall a. Maybe a
Nothing) (Point TestBlock -> Maybe (Point TestBlock)
forall a. a -> Maybe a
Just (Point TestBlock -> Maybe (Point TestBlock))
-> (HeaderFields TestBlock -> Point TestBlock)
-> HeaderFields TestBlock
-> Maybe (Point TestBlock)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point (HeaderFields TestBlock) -> Point TestBlock
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (HeaderFields TestBlock) -> Point TestBlock)
-> (HeaderFields TestBlock -> Point (HeaderFields TestBlock))
-> HeaderFields TestBlock
-> Point TestBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderFields TestBlock -> Point (HeaderFields TestBlock)
forall block. HasHeader block => block -> Point block
blockPoint) (Either (Anchor (HeaderFields TestBlock)) (HeaderFields TestBlock)
 -> Maybe (Point TestBlock))
-> Either
     (Anchor (HeaderFields TestBlock)) (HeaderFields TestBlock)
-> Maybe (Point TestBlock)
forall a b. (a -> b) -> a -> b
$
                          AnchoredFragment (HeaderFields TestBlock)
-> Either
     (Anchor (HeaderFields TestBlock)) (HeaderFields TestBlock)
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Either a b
AF.last AnchoredFragment (HeaderFields TestBlock)
suffix
        [Header TestBlock] -> Maybe (NonEmpty (Header TestBlock))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ((Header TestBlock -> Bool)
-> [Header TestBlock] -> [Header TestBlock]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Point TestBlock -> Point TestBlock -> Bool
forall a. Eq a => a -> a -> Bool
/= Point TestBlock
connectingPt) (Point TestBlock -> Bool)
-> (Header TestBlock -> Point TestBlock)
-> Header TestBlock
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header TestBlock -> Point TestBlock
forall blk. HasHeader (Header blk) => Header blk -> Point blk
headerPoint) [Header TestBlock]
hdrs)

chainDiffForkTip ::
     ChainDiff (HeaderFields TestBlock)
  -> Maybe (RealPoint TestBlock)
chainDiffForkTip :: ChainDiff (HeaderFields TestBlock) -> Maybe (RealPoint TestBlock)
chainDiffForkTip =
      WithOrigin (RealPoint TestBlock) -> Maybe (RealPoint TestBlock)
forall t. WithOrigin t -> Maybe t
withOriginToMaybe
    (WithOrigin (RealPoint TestBlock) -> Maybe (RealPoint TestBlock))
-> (ChainDiff (HeaderFields TestBlock)
    -> WithOrigin (RealPoint TestBlock))
-> ChainDiff (HeaderFields TestBlock)
-> Maybe (RealPoint TestBlock)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point TestBlock -> WithOrigin (RealPoint TestBlock)
forall blk. Point blk -> WithOrigin (RealPoint blk)
pointToWithOriginRealPoint
    (Point TestBlock -> WithOrigin (RealPoint TestBlock))
-> (ChainDiff (HeaderFields TestBlock) -> Point TestBlock)
-> ChainDiff (HeaderFields TestBlock)
-> WithOrigin (RealPoint TestBlock)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point (HeaderFields TestBlock) -> Point TestBlock
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint
    (Point (HeaderFields TestBlock) -> Point TestBlock)
-> (ChainDiff (HeaderFields TestBlock)
    -> Point (HeaderFields TestBlock))
-> ChainDiff (HeaderFields TestBlock)
-> Point TestBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainDiff (HeaderFields TestBlock)
-> Point (HeaderFields TestBlock)
forall b. HasHeader b => ChainDiff b -> Point b
Diff.getTip

headerToBlockInfo ::
     GetPrevHash blk
  => Header blk
  -> VolatileDB.BlockInfo blk
headerToBlockInfo :: forall blk. GetPrevHash blk => Header blk -> BlockInfo blk
headerToBlockInfo Header blk
hdr = VolatileDB.BlockInfo {
      biHash :: HeaderHash blk
biHash         = Header blk -> HeaderHash blk
forall blk. HasHeader (Header blk) => Header blk -> HeaderHash blk
headerHash Header blk
hdr
    , biSlotNo :: SlotNo
biSlotNo       = Header blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot  Header blk
hdr
    , biBlockNo :: BlockNo
biBlockNo      = Header blk -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo    Header blk
hdr
    , biPrevHash :: ChainHash blk
biPrevHash     = Header blk -> ChainHash blk
forall blk. GetPrevHash blk => Header blk -> ChainHash blk
headerPrevHash Header blk
hdr
    , biIsEBB :: IsEBB
biIsEBB        = Header blk -> IsEBB
forall blk. GetHeader blk => Header blk -> IsEBB
headerToIsEBB Header blk
hdr
    -- We don't care about those two
    , biHeaderOffset :: Word16
biHeaderOffset = Word16
0
    , biHeaderSize :: Word16
biHeaderSize   = Word16
0
    }

headersToBlockInfo ::
     (GetPrevHash blk, Foldable f)
  => f (Header blk)
  -> Map (HeaderHash blk) (VolatileDB.BlockInfo blk)
headersToBlockInfo :: forall blk (f :: * -> *).
(GetPrevHash blk, Foldable f) =>
f (Header blk) -> Map (HeaderHash blk) (BlockInfo blk)
headersToBlockInfo = (Header blk -> Map (HeaderHash blk) (BlockInfo blk))
-> f (Header blk) -> Map (HeaderHash blk) (BlockInfo blk)
forall m a. Monoid m => (a -> m) -> f a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Header blk -> Map (HeaderHash blk) (BlockInfo blk))
 -> f (Header blk) -> Map (HeaderHash blk) (BlockInfo blk))
-> (Header blk -> Map (HeaderHash blk) (BlockInfo blk))
-> f (Header blk)
-> Map (HeaderHash blk) (BlockInfo blk)
forall a b. (a -> b) -> a -> b
$ \Header blk
hdr ->
    HeaderHash blk
-> BlockInfo blk -> Map (HeaderHash blk) (BlockInfo blk)
forall k a. k -> a -> Map k a
Map.singleton (Header blk -> HeaderHash blk
forall blk. HasHeader (Header blk) => Header blk -> HeaderHash blk
headerHash Header blk
hdr) (Header blk -> BlockInfo blk
forall blk. GetPrevHash blk => Header blk -> BlockInfo blk
headerToBlockInfo Header blk
hdr)

instance Arbitrary (ReachableSetup TestBlock) where
  arbitrary :: Gen (ReachableSetup TestBlock)
arbitrary = do
      (AnchoredFragment (Header TestBlock)
currentChain, Maybe (Header TestBlock)
mbAnchorHdr) <- Gen (AnchoredFragment (Header TestBlock), Maybe (Header TestBlock))
generateChain
      (RealPoint TestBlock
forkTip, Maybe (ChainDiff (HeaderFields TestBlock))
fork, Map TestHeaderHash (BlockInfo TestBlock)
forkBlockInfo) <- [(Int,
  Gen
    (RealPoint TestBlock, Maybe (ChainDiff (HeaderFields TestBlock)),
     Map TestHeaderHash (BlockInfo TestBlock)))]
-> Gen
     (RealPoint TestBlock, Maybe (ChainDiff (HeaderFields TestBlock)),
      Map TestHeaderHash (BlockInfo TestBlock))
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
        [ (Int
3, (AnchoredFragment (Header TestBlock), Maybe (Header TestBlock))
-> Gen
     (RealPoint TestBlock, Maybe (ChainDiff (HeaderFields TestBlock)),
      Map TestHeaderHash (BlockInfo TestBlock))
generateConnectedFork    (AnchoredFragment (Header TestBlock)
currentChain, Maybe (Header TestBlock)
mbAnchorHdr))
        , (Int
1, (AnchoredFragment (Header TestBlock), Maybe (Header TestBlock))
-> Gen
     (RealPoint TestBlock, Maybe (ChainDiff (HeaderFields TestBlock)),
      Map TestHeaderHash (BlockInfo TestBlock))
forall {a}.
(AnchoredFragment (Header TestBlock), Maybe (Header TestBlock))
-> Gen
     (RealPoint TestBlock, Maybe a,
      Map TestHeaderHash (BlockInfo TestBlock))
generateDisconnectedFork (AnchoredFragment (Header TestBlock)
currentChain, Maybe (Header TestBlock)
mbAnchorHdr))
        ]
      let blockInfo :: Map TestHeaderHash (BlockInfo TestBlock)
blockInfo = Map TestHeaderHash (BlockInfo TestBlock)
forkBlockInfo
                   Map TestHeaderHash (BlockInfo TestBlock)
-> Map TestHeaderHash (BlockInfo TestBlock)
-> Map TestHeaderHash (BlockInfo TestBlock)
forall a. Semigroup a => a -> a -> a
<> Maybe (Header TestBlock)
-> Map (HeaderHash TestBlock) (BlockInfo TestBlock)
forall blk (f :: * -> *).
(GetPrevHash blk, Foldable f) =>
f (Header blk) -> Map (HeaderHash blk) (BlockInfo blk)
headersToBlockInfo Maybe (Header TestBlock)
mbAnchorHdr
                   Map TestHeaderHash (BlockInfo TestBlock)
-> Map TestHeaderHash (BlockInfo TestBlock)
-> Map TestHeaderHash (BlockInfo TestBlock)
forall a. Semigroup a => a -> a -> a
<> [Header TestBlock]
-> Map (HeaderHash TestBlock) (BlockInfo TestBlock)
forall blk (f :: * -> *).
(GetPrevHash blk, Foldable f) =>
f (Header blk) -> Map (HeaderHash blk) (BlockInfo blk)
headersToBlockInfo (AnchoredFragment (Header TestBlock) -> [Header TestBlock]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst AnchoredFragment (Header TestBlock)
currentChain)
      ReachableSetup TestBlock -> Gen (ReachableSetup TestBlock)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return ReachableSetup { AnchoredFragment (Header TestBlock)
currentChain :: AnchoredFragment (Header TestBlock)
currentChain :: AnchoredFragment (Header TestBlock)
currentChain, RealPoint TestBlock
forkTip :: RealPoint TestBlock
forkTip :: RealPoint TestBlock
forkTip, Maybe (ChainDiff (HeaderFields TestBlock))
fork :: Maybe (ChainDiff (HeaderFields TestBlock))
fork :: Maybe (ChainDiff (HeaderFields TestBlock))
fork, Map (HeaderHash TestBlock) (BlockInfo TestBlock)
Map TestHeaderHash (BlockInfo TestBlock)
blockInfo :: Map (HeaderHash TestBlock) (BlockInfo TestBlock)
blockInfo :: Map TestHeaderHash (BlockInfo TestBlock)
blockInfo }
    where
      generateConnectedFork :: (AnchoredFragment (Header TestBlock), Maybe (Header TestBlock))
-> Gen
     (RealPoint TestBlock, Maybe (ChainDiff (HeaderFields TestBlock)),
      Map TestHeaderHash (BlockInfo TestBlock))
generateConnectedFork (AnchoredFragment (Header TestBlock)
currentChain, Maybe (Header TestBlock)
mbAnchorHdr) = do
          (RealPoint TestBlock
forkTip, ChainDiff (HeaderFields TestBlock)
fork, [Header TestBlock]
headersOnFork) <-
            (AnchoredFragment (Header TestBlock), Maybe (Header TestBlock))
-> Gen (ChainDiff (HeaderFields TestBlock), [Header TestBlock])
generateFork (AnchoredFragment (Header TestBlock)
currentChain, Maybe (Header TestBlock)
mbAnchorHdr)
              Gen (ChainDiff (HeaderFields TestBlock), [Header TestBlock])
-> ((ChainDiff (HeaderFields TestBlock), [Header TestBlock])
    -> Maybe
         (RealPoint TestBlock, ChainDiff (HeaderFields TestBlock),
          [Header TestBlock]))
-> Gen
     (RealPoint TestBlock, ChainDiff (HeaderFields TestBlock),
      [Header TestBlock])
forall a b. Gen a -> (a -> Maybe b) -> Gen b
`suchThatMap` \(ChainDiff (HeaderFields TestBlock)
fork, [Header TestBlock]
headersOnFork) ->
                (, ChainDiff (HeaderFields TestBlock)
fork, [Header TestBlock]
headersOnFork) (RealPoint TestBlock
 -> (RealPoint TestBlock, ChainDiff (HeaderFields TestBlock),
     [Header TestBlock]))
-> Maybe (RealPoint TestBlock)
-> Maybe
     (RealPoint TestBlock, ChainDiff (HeaderFields TestBlock),
      [Header TestBlock])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainDiff (HeaderFields TestBlock) -> Maybe (RealPoint TestBlock)
chainDiffForkTip ChainDiff (HeaderFields TestBlock)
fork
          (RealPoint TestBlock, Maybe (ChainDiff (HeaderFields TestBlock)),
 Map TestHeaderHash (BlockInfo TestBlock))
-> Gen
     (RealPoint TestBlock, Maybe (ChainDiff (HeaderFields TestBlock)),
      Map TestHeaderHash (BlockInfo TestBlock))
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (
              RealPoint TestBlock
forkTip
            , ChainDiff (HeaderFields TestBlock)
-> Maybe (ChainDiff (HeaderFields TestBlock))
forall a. a -> Maybe a
Just ChainDiff (HeaderFields TestBlock)
fork
            , [Header TestBlock]
-> Map (HeaderHash TestBlock) (BlockInfo TestBlock)
forall blk (f :: * -> *).
(GetPrevHash blk, Foldable f) =>
f (Header blk) -> Map (HeaderHash blk) (BlockInfo blk)
headersToBlockInfo [Header TestBlock]
headersOnFork
            )

      generateDisconnectedFork :: (AnchoredFragment (Header TestBlock), Maybe (Header TestBlock))
-> Gen
     (RealPoint TestBlock, Maybe a,
      Map TestHeaderHash (BlockInfo TestBlock))
generateDisconnectedFork (AnchoredFragment (Header TestBlock)
currentChain, Maybe (Header TestBlock)
mbAnchorHdr) = do
          NonEmpty (Header TestBlock)
disconnectedHeaders <- (AnchoredFragment (Header TestBlock), Maybe (Header TestBlock))
-> Gen (NonEmpty (Header TestBlock))
generateDisconnectedHeaders (AnchoredFragment (Header TestBlock)
currentChain, Maybe (Header TestBlock)
mbAnchorHdr)
          RealPoint TestBlock
forkTip <- [RealPoint TestBlock] -> Gen (RealPoint TestBlock)
forall a. HasCallStack => [a] -> Gen a
elements ((Header TestBlock -> RealPoint TestBlock)
-> [Header TestBlock] -> [RealPoint TestBlock]
forall a b. (a -> b) -> [a] -> [b]
map Header TestBlock -> RealPoint TestBlock
forall blk.
(HasHeader (Header blk), HasHeader blk) =>
Header blk -> RealPoint blk
headerRealPoint (NonEmpty (Header TestBlock) -> [Header TestBlock]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (Header TestBlock)
disconnectedHeaders))
          (RealPoint TestBlock, Maybe a,
 Map TestHeaderHash (BlockInfo TestBlock))
-> Gen
     (RealPoint TestBlock, Maybe a,
      Map TestHeaderHash (BlockInfo TestBlock))
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (
              RealPoint TestBlock
forkTip
            , Maybe a
forall a. Maybe a
Nothing
            , NonEmpty (Header TestBlock)
-> Map (HeaderHash TestBlock) (BlockInfo TestBlock)
forall blk (f :: * -> *).
(GetPrevHash blk, Foldable f) =>
f (Header blk) -> Map (HeaderHash blk) (BlockInfo blk)
headersToBlockInfo NonEmpty (Header TestBlock)
disconnectedHeaders
            )

  shrink :: ReachableSetup TestBlock -> [ReachableSetup TestBlock]
shrink ReachableSetup { AnchoredFragment (Header TestBlock)
currentChain :: forall blk. ReachableSetup blk -> AnchoredFragment (Header blk)
currentChain :: AnchoredFragment (Header TestBlock)
currentChain, RealPoint TestBlock
forkTip :: forall blk. ReachableSetup blk -> RealPoint blk
forkTip :: RealPoint TestBlock
forkTip, Maybe (ChainDiff (HeaderFields TestBlock))
fork :: forall blk.
ReachableSetup blk -> Maybe (ChainDiff (HeaderFields blk))
fork :: Maybe (ChainDiff (HeaderFields TestBlock))
fork, Map (HeaderHash TestBlock) (BlockInfo TestBlock)
blockInfo :: forall blk.
ReachableSetup blk -> Map (HeaderHash blk) (BlockInfo blk)
blockInfo :: Map (HeaderHash TestBlock) (BlockInfo TestBlock)
blockInfo } =
      [ReachableSetup TestBlock]
shrinkFork [ReachableSetup TestBlock]
-> [ReachableSetup TestBlock] -> [ReachableSetup TestBlock]
forall a. Semigroup a => a -> a -> a
<> [ReachableSetup TestBlock]
shrinkCurrentChain
    where
      shrinkFork :: [ReachableSetup TestBlock]
shrinkFork = case Maybe (ChainDiff (HeaderFields TestBlock))
fork of
          -- We can't shrink the fork if there is no fork
          Maybe (ChainDiff (HeaderFields TestBlock))
Nothing -> []

          Just (ChainDiff Word64
rollback AnchoredFragment (HeaderFields TestBlock)
suffix) ->
            case AnchoredFragment (HeaderFields TestBlock)
suffix of
              suffix' :: AnchoredFragment (HeaderFields TestBlock)
suffix'@(AnchoredFragment (HeaderFields TestBlock)
_ AF.:> HeaderFields TestBlock
forkTip') AF.:> HeaderFields TestBlock
_ -> ReachableSetup TestBlock -> [ReachableSetup TestBlock]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (ReachableSetup TestBlock -> [ReachableSetup TestBlock])
-> ReachableSetup TestBlock -> [ReachableSetup TestBlock]
forall a b. (a -> b) -> a -> b
$
                ReachableSetup {
                    AnchoredFragment (Header TestBlock)
currentChain :: AnchoredFragment (Header TestBlock)
currentChain :: AnchoredFragment (Header TestBlock)
currentChain
                  , forkTip :: RealPoint TestBlock
forkTip   = SlotNo -> HeaderHash TestBlock -> RealPoint TestBlock
forall blk. SlotNo -> HeaderHash blk -> RealPoint blk
RealPoint (HeaderFields TestBlock -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot HeaderFields TestBlock
forkTip') (HeaderFields TestBlock -> HeaderHash (HeaderFields TestBlock)
forall b. HasHeader b => b -> HeaderHash b
blockHash HeaderFields TestBlock
forkTip')
                  , fork :: Maybe (ChainDiff (HeaderFields TestBlock))
fork      = ChainDiff (HeaderFields TestBlock)
-> Maybe (ChainDiff (HeaderFields TestBlock))
forall a. a -> Maybe a
Just (ChainDiff (HeaderFields TestBlock)
 -> Maybe (ChainDiff (HeaderFields TestBlock)))
-> ChainDiff (HeaderFields TestBlock)
-> Maybe (ChainDiff (HeaderFields TestBlock))
forall a b. (a -> b) -> a -> b
$ Word64
-> AnchoredFragment (HeaderFields TestBlock)
-> ChainDiff (HeaderFields TestBlock)
forall b. Word64 -> AnchoredFragment b -> ChainDiff b
ChainDiff Word64
rollback AnchoredFragment (HeaderFields TestBlock)
suffix'
                  , blockInfo :: Map (HeaderHash TestBlock) (BlockInfo TestBlock)
blockInfo = TestHeaderHash
-> Map TestHeaderHash (BlockInfo TestBlock)
-> Map TestHeaderHash (BlockInfo TestBlock)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (RealPoint TestBlock -> HeaderHash TestBlock
forall blk. RealPoint blk -> HeaderHash blk
realPointHash RealPoint TestBlock
forkTip) Map (HeaderHash TestBlock) (BlockInfo TestBlock)
Map TestHeaderHash (BlockInfo TestBlock)
blockInfo
                  }
              AnchoredFragment (HeaderFields TestBlock)
_ -> []

      shrinkCurrentChain :: [ReachableSetup TestBlock]
shrinkCurrentChain = case Maybe (ChainDiff (HeaderFields TestBlock))
fork of
          -- We don't care much about shrinking this case: the fork is not
          -- connected.
          Maybe (ChainDiff (HeaderFields TestBlock))
Nothing -> []

          Just (ChainDiff Word64
rollback AnchoredFragment (HeaderFields TestBlock)
suffix)
            | AnchoredFragment (Header TestBlock)
currentChain' AF.:> Header TestBlock
curTip <- AnchoredFragment (Header TestBlock)
currentChain
            , Header TestBlock -> Anchor (Header TestBlock)
forall block. HasHeader block => block -> Anchor block
AF.anchorFromBlock Header TestBlock
curTip Anchor (Header TestBlock) -> Anchor (Header TestBlock) -> Bool
forall a. Eq a => a -> a -> Bool
/= Anchor (HeaderFields TestBlock) -> Anchor (Header TestBlock)
forall a b. (HeaderHash a ~ HeaderHash b) => Anchor a -> Anchor b
AF.castAnchor (AnchoredFragment (HeaderFields TestBlock)
-> Anchor (HeaderFields TestBlock)
forall v a b. AnchoredSeq v a b -> a
AF.anchor AnchoredFragment (HeaderFields TestBlock)
suffix)
            -> ReachableSetup TestBlock -> [ReachableSetup TestBlock]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (ReachableSetup TestBlock -> [ReachableSetup TestBlock])
-> ReachableSetup TestBlock -> [ReachableSetup TestBlock]
forall a b. (a -> b) -> a -> b
$ ReachableSetup {
                currentChain :: AnchoredFragment (Header TestBlock)
currentChain = AnchoredFragment (Header TestBlock)
currentChain'
              , forkTip :: RealPoint TestBlock
forkTip      = RealPoint TestBlock
forkTip
              , fork :: Maybe (ChainDiff (HeaderFields TestBlock))
fork         = ChainDiff (HeaderFields TestBlock)
-> Maybe (ChainDiff (HeaderFields TestBlock))
forall a. a -> Maybe a
Just (ChainDiff (HeaderFields TestBlock)
 -> Maybe (ChainDiff (HeaderFields TestBlock)))
-> ChainDiff (HeaderFields TestBlock)
-> Maybe (ChainDiff (HeaderFields TestBlock))
forall a b. (a -> b) -> a -> b
$ Word64
-> AnchoredFragment (HeaderFields TestBlock)
-> ChainDiff (HeaderFields TestBlock)
forall b. Word64 -> AnchoredFragment b -> ChainDiff b
ChainDiff (Word64
rollback Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
1) AnchoredFragment (HeaderFields TestBlock)
suffix
              , blockInfo :: Map (HeaderHash TestBlock) (BlockInfo TestBlock)
blockInfo    = TestHeaderHash
-> Map TestHeaderHash (BlockInfo TestBlock)
-> Map TestHeaderHash (BlockInfo TestBlock)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (Header TestBlock -> HeaderHash TestBlock
forall blk. HasHeader (Header blk) => Header blk -> HeaderHash blk
headerHash Header TestBlock
curTip) Map (HeaderHash TestBlock) (BlockInfo TestBlock)
Map TestHeaderHash (BlockInfo TestBlock)
blockInfo
              }
            | Bool
otherwise
            -> []