{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}

module Test.Consensus.PointSchedule.Shrinking
  ( -- | Exported only for testing (that is, checking the properties of the function)
    shrinkByRemovingAdversaries
  , shrinkHonestPeer
  , shrinkHonestPeers
  , shrinkPeerSchedules
  ) where

import Control.Monad.Class.MonadTime.SI
  ( DiffTime
  , Time
  , addTime
  , diffTime
  )
import Data.Containers.ListUtils (nubOrd)
import Data.Foldable (toList)
import Data.Functor ((<&>))
import qualified Data.Map.Strict as Map
import Data.Maybe (mapMaybe)
import Ouroboros.Network.AnchoredFragment
  ( AnchoredFragment
  , AnchoredSeq (Empty)
  , takeWhileOldest
  )
import Test.Consensus.BlockTree
  ( BlockTree (..)
  , BlockTreeBranch (..)
  , addBranch'
  , mkTrunk
  )
import Test.Consensus.PeerSimulator.StateView (StateView)
import Test.Consensus.PointSchedule
  ( GenesisTest (..)
  , GenesisTestFull
  , PeerSchedule
  , PointSchedule (..)
  , peerSchedulesBlocks
  )
import Test.Consensus.PointSchedule.Peers (Peers (..))
import Test.Consensus.PointSchedule.SinglePeer (SchedulePoint (..))
import Test.QuickCheck (shrinkList)
import Test.Util.TestBlock
  ( TestBlock
  , isAncestorOf
  , isStrictAncestorOf
  )

-- | Shrink a 'PointSchedule'. We use a different logic to shrink honest and
-- adversarial peers. For adversarial peers, we just remove arbitrary points,
-- or peers altogether. For honest peers, we "speed up" the schedule by merging
-- adjacent points.
-- The block tree is trimmed to keep only parts that are necessary for the shrunk
-- schedules.
shrinkPeerSchedules ::
  GenesisTestFull TestBlock ->
  StateView TestBlock ->
  [GenesisTestFull TestBlock]
shrinkPeerSchedules :: GenesisTestFull TestBlock
-> StateView TestBlock -> [GenesisTestFull TestBlock]
shrinkPeerSchedules genesisTest :: GenesisTestFull TestBlock
genesisTest@GenesisTest{BlockTree TestBlock
gtBlockTree :: BlockTree TestBlock
gtBlockTree :: forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree, PointSchedule TestBlock
gtSchedule :: PointSchedule TestBlock
gtSchedule :: forall blk schedule. GenesisTest blk schedule -> schedule
gtSchedule} StateView TestBlock
_stateView =
  let PointSchedule{Peers (PeerSchedule TestBlock)
psSchedule :: Peers (PeerSchedule TestBlock)
psSchedule :: forall blk. PointSchedule blk -> Peers (PeerSchedule blk)
psSchedule, [PeerId]
psStartOrder :: [PeerId]
psStartOrder :: forall blk. PointSchedule blk -> [PeerId]
psStartOrder} = PointSchedule TestBlock
gtSchedule
      simulationDuration :: Time
simulationDuration = PointSchedule TestBlock -> Time
forall blk. PointSchedule blk -> Time
duration PointSchedule TestBlock
gtSchedule
      trimmedBlockTree :: Peers (PeerSchedule TestBlock) -> BlockTree TestBlock
trimmedBlockTree Peers (PeerSchedule TestBlock)
sch = Peers (PeerSchedule TestBlock)
-> BlockTree TestBlock -> BlockTree TestBlock
trimBlockTree' Peers (PeerSchedule TestBlock)
sch BlockTree TestBlock
gtBlockTree
      shrunkAdversarialPeers :: [GenesisTestFull TestBlock]
shrunkAdversarialPeers =
        (PeerSchedule TestBlock -> [PeerSchedule TestBlock])
-> Peers (PeerSchedule TestBlock)
-> [Peers (PeerSchedule TestBlock)]
forall a. (a -> [a]) -> Peers a -> [Peers a]
shrinkAdversarialPeers PeerSchedule TestBlock -> [PeerSchedule TestBlock]
forall blk. PeerSchedule blk -> [PeerSchedule blk]
shrinkAdversarialPeer Peers (PeerSchedule TestBlock)
psSchedule
          [Peers (PeerSchedule TestBlock)]
-> (Peers (PeerSchedule TestBlock) -> GenesisTestFull TestBlock)
-> [GenesisTestFull TestBlock]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Peers (PeerSchedule TestBlock)
shrunkSchedule ->
            GenesisTestFull TestBlock
genesisTest
              { gtSchedule =
                  PointSchedule
                    { psSchedule = shrunkSchedule
                    , psStartOrder
                    , psMinEndTime = simulationDuration
                    }
              , gtBlockTree = trimmedBlockTree shrunkSchedule
              }
      shrunkHonestPeers :: [GenesisTestFull TestBlock]
shrunkHonestPeers =
        Peers (PeerSchedule TestBlock) -> [Peers (PeerSchedule TestBlock)]
forall blk. Peers (PeerSchedule blk) -> [Peers (PeerSchedule blk)]
shrinkHonestPeers
          Peers (PeerSchedule TestBlock)
psSchedule
          -- No need to update the tree here, shrinking the honest peers never discards blocks
          [Peers (PeerSchedule TestBlock)]
-> (Peers (PeerSchedule TestBlock) -> GenesisTestFull TestBlock)
-> [GenesisTestFull TestBlock]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Peers (PeerSchedule TestBlock)
shrunkSchedule ->
            GenesisTestFull TestBlock
genesisTest
              { gtSchedule =
                  PointSchedule
                    { psSchedule = shrunkSchedule
                    , psStartOrder
                    , psMinEndTime = simulationDuration
                    }
              }
   in [GenesisTestFull TestBlock]
shrunkAdversarialPeers [GenesisTestFull TestBlock]
-> [GenesisTestFull TestBlock] -> [GenesisTestFull TestBlock]
forall a. [a] -> [a] -> [a]
++ [GenesisTestFull TestBlock]
shrunkHonestPeers

-- | Shrink a 'PointSchedule' by removing adversaries. This does not affect
-- the honest peers; and it does not remove ticks from the schedules of the
-- remaining adversaries.
shrinkByRemovingAdversaries ::
  GenesisTestFull TestBlock ->
  StateView TestBlock ->
  [GenesisTestFull TestBlock]
shrinkByRemovingAdversaries :: GenesisTestFull TestBlock
-> StateView TestBlock -> [GenesisTestFull TestBlock]
shrinkByRemovingAdversaries genesisTest :: GenesisTestFull TestBlock
genesisTest@GenesisTest{PointSchedule TestBlock
gtSchedule :: forall blk schedule. GenesisTest blk schedule -> schedule
gtSchedule :: PointSchedule TestBlock
gtSchedule, BlockTree TestBlock
gtBlockTree :: forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree :: BlockTree TestBlock
gtBlockTree} StateView TestBlock
_stateView =
  (PeerSchedule TestBlock -> [PeerSchedule TestBlock])
-> Peers (PeerSchedule TestBlock)
-> [Peers (PeerSchedule TestBlock)]
forall a. (a -> [a]) -> Peers a -> [Peers a]
shrinkAdversarialPeers ([PeerSchedule TestBlock]
-> PeerSchedule TestBlock -> [PeerSchedule TestBlock]
forall a b. a -> b -> a
const []) (PointSchedule TestBlock -> Peers (PeerSchedule TestBlock)
forall blk. PointSchedule blk -> Peers (PeerSchedule blk)
psSchedule PointSchedule TestBlock
gtSchedule) [Peers (PeerSchedule TestBlock)]
-> (Peers (PeerSchedule TestBlock) -> GenesisTestFull TestBlock)
-> [GenesisTestFull TestBlock]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Peers (PeerSchedule TestBlock)
shrunkSchedule ->
    let
      trimmedBlockTree :: BlockTree TestBlock
trimmedBlockTree = Peers (PeerSchedule TestBlock)
-> BlockTree TestBlock -> BlockTree TestBlock
trimBlockTree' Peers (PeerSchedule TestBlock)
shrunkSchedule BlockTree TestBlock
gtBlockTree
      simulationDuration :: Time
simulationDuration = PointSchedule TestBlock -> Time
forall blk. PointSchedule blk -> Time
duration PointSchedule TestBlock
gtSchedule
     in
      GenesisTestFull TestBlock
genesisTest
        { gtSchedule =
            PointSchedule
              { psSchedule = shrunkSchedule
              , psStartOrder = psStartOrder gtSchedule
              , psMinEndTime = simulationDuration
              }
        , gtBlockTree = trimmedBlockTree
        }

duration :: PointSchedule blk -> Time
duration :: forall blk. PointSchedule blk -> Time
duration PointSchedule{Peers (PeerSchedule blk)
psSchedule :: forall blk. PointSchedule blk -> Peers (PeerSchedule blk)
psSchedule :: Peers (PeerSchedule blk)
psSchedule, Time
psMinEndTime :: forall blk. PointSchedule blk -> Time
psMinEndTime :: Time
psMinEndTime} =
  [Time] -> Time
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Time] -> Time) -> [Time] -> Time
forall a b. (a -> b) -> a -> b
$ Time
psMinEndTime Time -> [Time] -> [Time]
forall a. a -> [a] -> [a]
: [Time
t | PeerSchedule blk
sch <- Peers (PeerSchedule blk) -> [PeerSchedule blk]
forall a. Peers a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Peers (PeerSchedule blk)
psSchedule, (Time
t, SchedulePoint blk
_) <- Int -> PeerSchedule blk -> PeerSchedule blk
forall a. Int -> [a] -> [a]
take Int
1 (PeerSchedule blk -> PeerSchedule blk
forall a. [a] -> [a]
reverse PeerSchedule blk
sch)]

-- | Shrink a 'PeerSchedule' by removing ticks from it. The other ticks are kept
-- unchanged.
shrinkAdversarialPeer :: PeerSchedule blk -> [PeerSchedule blk]
shrinkAdversarialPeer :: forall blk. PeerSchedule blk -> [PeerSchedule blk]
shrinkAdversarialPeer = ((Time, SchedulePoint blk) -> [(Time, SchedulePoint blk)])
-> [(Time, SchedulePoint blk)] -> [[(Time, SchedulePoint blk)]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ([(Time, SchedulePoint blk)]
-> (Time, SchedulePoint blk) -> [(Time, SchedulePoint blk)]
forall a b. a -> b -> a
const [])

-- | Shrink the 'others' field of a 'Peers' structure by attempting to remove
-- peers or by shrinking their values using the given shrinking function.
shrinkAdversarialPeers :: (a -> [a]) -> Peers a -> [Peers a]
shrinkAdversarialPeers :: forall a. (a -> [a]) -> Peers a -> [Peers a]
shrinkAdversarialPeers a -> [a]
shrink Peers{Map Int a
honestPeers :: Map Int a
honestPeers :: forall a. Peers a -> Map Int a
honestPeers, Map Int a
adversarialPeers :: Map Int a
adversarialPeers :: forall a. Peers a -> Map Int a
adversarialPeers} =
  ([(Int, a)] -> Peers a) -> [[(Int, a)]] -> [Peers a]
forall a b. (a -> b) -> [a] -> [b]
map (Map Int a -> Map Int a -> Peers a
forall a. Map Int a -> Map Int a -> Peers a
Peers Map Int a
honestPeers (Map Int a -> Peers a)
-> ([(Int, a)] -> Map Int a) -> [(Int, a)] -> Peers a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, a)] -> Map Int a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList) ([[(Int, a)]] -> [Peers a]) -> [[(Int, a)]] -> [Peers a]
forall a b. (a -> b) -> a -> b
$
    ((Int, a) -> [(Int, a)]) -> [(Int, a)] -> [[(Int, a)]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ((a -> [a]) -> (Int, a) -> [(Int, a)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> (Int, a) -> f (Int, b)
traverse a -> [a]
shrink) ([(Int, a)] -> [[(Int, a)]]) -> [(Int, a)] -> [[(Int, a)]]
forall a b. (a -> b) -> a -> b
$
      Map Int a -> [(Int, a)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Int a
adversarialPeers

-- | Shrinks honest peers by removing ticks. Because we are manipulating
-- 'PeerSchedule' at this point, there is no proper notion of a tick. Instead,
-- we remove points from the honest 'PeerSchedule', and move all other points sooner.
--
-- We check that this operation does not changes the final state of the honest peers,
-- that is, it keeps the same final tip point, header point, and block point.
--
-- NOTE: This operation makes the honest peers end their schedule sooner, which *may*
-- trigger disconnections when the timeout for MsgAwaitReply is reached. In those cases,
-- it is probably more pertinent to disable this timeout in tests than to disable shrinking.
shrinkHonestPeers :: Peers (PeerSchedule blk) -> [Peers (PeerSchedule blk)]
shrinkHonestPeers :: forall blk. Peers (PeerSchedule blk) -> [Peers (PeerSchedule blk)]
shrinkHonestPeers Peers{Map Int (PeerSchedule blk)
honestPeers :: forall a. Peers a -> Map Int a
honestPeers :: Map Int (PeerSchedule blk)
honestPeers, Map Int (PeerSchedule blk)
adversarialPeers :: forall a. Peers a -> Map Int a
adversarialPeers :: Map Int (PeerSchedule blk)
adversarialPeers} = do
  (k, honestSch) <- Map Int (PeerSchedule blk) -> [(Int, PeerSchedule blk)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Int (PeerSchedule blk)
honestPeers
  shrunk <- shrinkHonestPeer honestSch
  pure $
    Peers
      { honestPeers = Map.insert k shrunk honestPeers
      , adversarialPeers
      }

shrinkHonestPeer :: PeerSchedule blk -> [PeerSchedule blk]
shrinkHonestPeer :: forall blk. PeerSchedule blk -> [PeerSchedule blk]
shrinkHonestPeer PeerSchedule blk
sch =
  ((Time, DiffTime) -> Maybe (PeerSchedule blk))
-> [(Time, DiffTime)] -> [PeerSchedule blk]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (PeerSchedule blk -> (Time, DiffTime) -> Maybe (PeerSchedule blk)
forall blk.
PeerSchedule blk -> (Time, DiffTime) -> Maybe (PeerSchedule blk)
speedUpTheSchedule PeerSchedule blk
sch) [(Time, DiffTime)]
splits
 where
  -- \| A list of non-zero time intervals between successive points of the honest schedule
  splits :: [(Time, DiffTime)]
  splits :: [(Time, DiffTime)]
splits =
    (((Time, SchedulePoint blk), (Time, SchedulePoint blk))
 -> Maybe (Time, DiffTime))
-> [((Time, SchedulePoint blk), (Time, SchedulePoint blk))]
-> [(Time, DiffTime)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
      ( \((Time
t1, SchedulePoint blk
_), (Time
t2, SchedulePoint blk
_)) ->
          if Time
t1 Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Time
t2
            then Maybe (Time, DiffTime)
forall a. Maybe a
Nothing
            else (Time, DiffTime) -> Maybe (Time, DiffTime)
forall a. a -> Maybe a
Just (Time
t1, Time -> Time -> DiffTime
diffTime Time
t2 Time
t1)
      )
      (PeerSchedule blk
-> PeerSchedule blk
-> [((Time, SchedulePoint blk), (Time, SchedulePoint blk))]
forall a b. [a] -> [b] -> [(a, b)]
zip PeerSchedule blk
sch (Int -> PeerSchedule blk -> PeerSchedule blk
forall a. Int -> [a] -> [a]
drop Int
1 PeerSchedule blk
sch))

-- | Speeds up _the_ schedule (that is, the one that we are actually trying to
-- speed up) after `at` time, by `speedUpBy`. This "speeding up" is done by
-- removing `speedUpBy` to all points after `at`, and removing those points if
-- they fall before `at`. We check that the operation doesn't change the final
-- state of the peer, i.e. it doesn't remove all TP, HP, and BP in the sped up
-- part.
speedUpTheSchedule :: PeerSchedule blk -> (Time, DiffTime) -> Maybe (PeerSchedule blk)
speedUpTheSchedule :: forall blk.
PeerSchedule blk -> (Time, DiffTime) -> Maybe (PeerSchedule blk)
speedUpTheSchedule PeerSchedule blk
sch (Time
at, DiffTime
speedUpBy) =
  if Bool
stillValid then PeerSchedule blk -> Maybe (PeerSchedule blk)
forall a. a -> Maybe a
Just (PeerSchedule blk -> Maybe (PeerSchedule blk))
-> PeerSchedule blk -> Maybe (PeerSchedule blk)
forall a b. (a -> b) -> a -> b
$ PeerSchedule blk
beforeSplit PeerSchedule blk -> PeerSchedule blk -> PeerSchedule blk
forall a. [a] -> [a] -> [a]
++ PeerSchedule blk
spedUpSchedule else Maybe (PeerSchedule blk)
forall a. Maybe a
Nothing
 where
  (PeerSchedule blk
beforeSplit, PeerSchedule blk
afterSplit) = ((Time, SchedulePoint blk) -> Bool)
-> PeerSchedule blk -> (PeerSchedule blk, PeerSchedule blk)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< Time
at) (Time -> Bool)
-> ((Time, SchedulePoint blk) -> Time)
-> (Time, SchedulePoint blk)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Time, SchedulePoint blk) -> Time
forall a b. (a, b) -> a
fst) PeerSchedule blk
sch
  threshold :: Time
threshold = DiffTime -> Time -> Time
addTime DiffTime
speedUpBy Time
at
  spedUpSchedule :: PeerSchedule blk
spedUpSchedule =
    ((Time, SchedulePoint blk) -> Maybe (Time, SchedulePoint blk))
-> PeerSchedule blk -> PeerSchedule blk
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
      (\(Time
t, SchedulePoint blk
p) -> if Time
t Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< Time
threshold then Maybe (Time, SchedulePoint blk)
forall a. Maybe a
Nothing else (Time, SchedulePoint blk) -> Maybe (Time, SchedulePoint blk)
forall a. a -> Maybe a
Just (DiffTime -> Time -> Time
addTime (-DiffTime
speedUpBy) Time
t, SchedulePoint blk
p))
      PeerSchedule blk
afterSplit
  stillValid :: Bool
stillValid =
    (PeerSchedule blk -> Bool
forall {a} {blk}. [(a, SchedulePoint blk)] -> Bool
hasTP PeerSchedule blk
spedUpSchedule Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== PeerSchedule blk -> Bool
forall {a} {blk}. [(a, SchedulePoint blk)] -> Bool
hasTP PeerSchedule blk
afterSplit)
      Bool -> Bool -> Bool
&& (PeerSchedule blk -> Bool
forall {a} {blk}. [(a, SchedulePoint blk)] -> Bool
hasHP PeerSchedule blk
spedUpSchedule Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== PeerSchedule blk -> Bool
forall {a} {blk}. [(a, SchedulePoint blk)] -> Bool
hasHP PeerSchedule blk
afterSplit)
      Bool -> Bool -> Bool
&& (PeerSchedule blk -> Bool
forall {a} {blk}. [(a, SchedulePoint blk)] -> Bool
hasBP PeerSchedule blk
spedUpSchedule Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== PeerSchedule blk -> Bool
forall {a} {blk}. [(a, SchedulePoint blk)] -> Bool
hasBP PeerSchedule blk
afterSplit)
  hasTP :: [(a, SchedulePoint blk)] -> Bool
hasTP = ((a, SchedulePoint blk) -> Bool)
-> [(a, SchedulePoint blk)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\case (a
_, ScheduleTipPoint WithOrigin blk
_) -> Bool
True; (a, SchedulePoint blk)
_ -> Bool
False)
  hasHP :: [(a, SchedulePoint blk)] -> Bool
hasHP = ((a, SchedulePoint blk) -> Bool)
-> [(a, SchedulePoint blk)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\case (a
_, ScheduleHeaderPoint WithOrigin blk
_) -> Bool
True; (a, SchedulePoint blk)
_ -> Bool
False)
  hasBP :: [(a, SchedulePoint blk)] -> Bool
hasBP = ((a, SchedulePoint blk) -> Bool)
-> [(a, SchedulePoint blk)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\case (a
_, ScheduleBlockPoint WithOrigin blk
_) -> Bool
True; (a, SchedulePoint blk)
_ -> Bool
False)

-- | Remove blocks from the given block tree that are not necessary for the
-- given peer schedules. If entire branches are unused, they are removed. If the
-- trunk is unused, then it remains as an empty anchored fragment.
trimBlockTree' :: Peers (PeerSchedule TestBlock) -> BlockTree TestBlock -> BlockTree TestBlock
trimBlockTree' :: Peers (PeerSchedule TestBlock)
-> BlockTree TestBlock -> BlockTree TestBlock
trimBlockTree' = [TestBlock] -> BlockTree TestBlock -> BlockTree TestBlock
keepOnlyAncestorsOf ([TestBlock] -> BlockTree TestBlock -> BlockTree TestBlock)
-> (Peers (PeerSchedule TestBlock) -> [TestBlock])
-> Peers (PeerSchedule TestBlock)
-> BlockTree TestBlock
-> BlockTree TestBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Peers (PeerSchedule TestBlock) -> [TestBlock]
forall blk. Peers (PeerSchedule blk) -> [blk]
peerSchedulesBlocks

-- | Given some blocks and a block tree, keep only the prefix of the block tree
-- that contains ancestors of the given blocks.
keepOnlyAncestorsOf :: [TestBlock] -> BlockTree TestBlock -> BlockTree TestBlock
keepOnlyAncestorsOf :: [TestBlock] -> BlockTree TestBlock -> BlockTree TestBlock
keepOnlyAncestorsOf [TestBlock]
blocks BlockTree TestBlock
bt =
  let leaves :: [TestBlock]
leaves = [TestBlock] -> [TestBlock]
blocksWithoutDescendents [TestBlock]
blocks
      trunk :: AnchoredFragment TestBlock
trunk = [TestBlock]
-> AnchoredFragment TestBlock -> AnchoredFragment TestBlock
keepOnlyAncestorsOf' [TestBlock]
leaves (BlockTree TestBlock -> AnchoredFragment TestBlock
forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk BlockTree TestBlock
bt)
      branches :: [AnchoredFragment TestBlock]
branches = (BlockTreeBranch TestBlock -> Maybe (AnchoredFragment TestBlock))
-> [BlockTreeBranch TestBlock] -> [AnchoredFragment TestBlock]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (AnchoredFragment TestBlock -> Maybe (AnchoredFragment TestBlock)
forall {v} {a} {b}.
Anchorable v a b =>
AnchoredSeq v a b -> Maybe (AnchoredSeq v a b)
fragmentToMaybe (AnchoredFragment TestBlock -> Maybe (AnchoredFragment TestBlock))
-> (BlockTreeBranch TestBlock -> AnchoredFragment TestBlock)
-> BlockTreeBranch TestBlock
-> Maybe (AnchoredFragment TestBlock)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TestBlock]
-> AnchoredFragment TestBlock -> AnchoredFragment TestBlock
keepOnlyAncestorsOf' [TestBlock]
leaves (AnchoredFragment TestBlock -> AnchoredFragment TestBlock)
-> (BlockTreeBranch TestBlock -> AnchoredFragment TestBlock)
-> BlockTreeBranch TestBlock
-> AnchoredFragment TestBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockTreeBranch TestBlock -> AnchoredFragment TestBlock
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbSuffix) (BlockTree TestBlock -> [BlockTreeBranch TestBlock]
forall blk. BlockTree blk -> [BlockTreeBranch blk]
btBranches BlockTree TestBlock
bt)
   in (AnchoredFragment TestBlock
 -> BlockTree TestBlock -> BlockTree TestBlock)
-> BlockTree TestBlock
-> [AnchoredFragment TestBlock]
-> BlockTree TestBlock
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr AnchoredFragment TestBlock
-> BlockTree TestBlock -> BlockTree TestBlock
forall blk.
HasHeader blk =>
AnchoredFragment blk -> BlockTree blk -> BlockTree blk
addBranch' (AnchoredFragment TestBlock -> BlockTree TestBlock
forall blk. AnchoredFragment blk -> BlockTree blk
mkTrunk AnchoredFragment TestBlock
trunk) [AnchoredFragment TestBlock]
branches
 where
  fragmentToMaybe :: AnchoredSeq v a b -> Maybe (AnchoredSeq v a b)
fragmentToMaybe (Empty a
_) = Maybe (AnchoredSeq v a b)
forall a. Maybe a
Nothing
  fragmentToMaybe AnchoredSeq v a b
fragment = AnchoredSeq v a b -> Maybe (AnchoredSeq v a b)
forall a. a -> Maybe a
Just AnchoredSeq v a b
fragment

  -- \| Given some blocks and a fragment, keep only the prefix of the fragment
  -- that contains ancestors of the given blocks.
  keepOnlyAncestorsOf' :: [TestBlock] -> AnchoredFragment TestBlock -> AnchoredFragment TestBlock
  keepOnlyAncestorsOf' :: [TestBlock]
-> AnchoredFragment TestBlock -> AnchoredFragment TestBlock
keepOnlyAncestorsOf' [TestBlock]
leaves = (TestBlock -> Bool)
-> AnchoredFragment TestBlock -> AnchoredFragment TestBlock
forall v a b.
Anchorable v a b =>
(b -> Bool) -> AnchoredSeq v a b -> AnchoredSeq v a b
takeWhileOldest (\TestBlock
block -> (TestBlock
block TestBlock -> TestBlock -> Bool
`isAncestorOf`) (TestBlock -> Bool) -> [TestBlock] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
`any` [TestBlock]
leaves)

  -- \| Return a subset of the given blocks containing only the ones that do
  -- not have any other descendents in the set.
  blocksWithoutDescendents :: [TestBlock] -> [TestBlock]
  blocksWithoutDescendents :: [TestBlock] -> [TestBlock]
blocksWithoutDescendents [TestBlock]
bs =
    let bs' :: [TestBlock]
bs' = [TestBlock] -> [TestBlock]
forall a. Ord a => [a] -> [a]
nubOrd [TestBlock]
bs
     in [TestBlock
b | TestBlock
b <- [TestBlock]
bs', Bool -> Bool
not ((TestBlock
b TestBlock -> TestBlock -> Bool
`isStrictAncestorOf`) (TestBlock -> Bool) -> [TestBlock] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
`any` [TestBlock]
bs')]