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

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

import qualified Cardano.Slotting.Slot as Slot
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 (catMaybes, mapMaybe)
import Ouroboros.Consensus.Block.Abstract (HasHeader)
import Ouroboros.Network.AnchoredFragment
  ( AnchoredFragment
  , AnchoredSeq (Empty)
  , takeWhileOldest
  )
import Test.Consensus.BlockTree
  ( BlockTree (..)
  , BlockTreeBranch (..)
  , addBranch'
  , isAncestorOf
  , isStrictAncestorOf
  , 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)

-- | 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 ::
  ( HasHeader blk
  , Ord blk
  ) =>
  GenesisTestFull blk ->
  StateView blk ->
  [GenesisTestFull blk]
shrinkPeerSchedules :: forall blk.
(HasHeader blk, Ord blk) =>
GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk]
shrinkPeerSchedules genesisTest :: GenesisTestFull blk
genesisTest@GenesisTest{BlockTree blk
gtBlockTree :: BlockTree blk
gtBlockTree :: forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree, PointSchedule blk
gtSchedule :: PointSchedule blk
gtSchedule :: forall blk schedule. GenesisTest blk schedule -> schedule
gtSchedule} StateView blk
_stateView =
  let PointSchedule{Peers (PeerSchedule blk)
psSchedule :: Peers (PeerSchedule blk)
psSchedule :: forall blk. PointSchedule blk -> Peers (PeerSchedule blk)
psSchedule, [PeerId]
psStartOrder :: [PeerId]
psStartOrder :: forall blk. PointSchedule blk -> [PeerId]
psStartOrder} = PointSchedule blk
gtSchedule
      simulationDuration :: Time
simulationDuration = PointSchedule blk -> Time
forall blk. PointSchedule blk -> Time
duration PointSchedule blk
gtSchedule
      trimmedBlockTree :: Peers (PeerSchedule blk) -> BlockTree blk
trimmedBlockTree Peers (PeerSchedule blk)
sch = Peers (PeerSchedule blk) -> BlockTree blk -> BlockTree blk
forall blk.
(Ord blk, HasHeader blk) =>
Peers (PeerSchedule blk) -> BlockTree blk -> BlockTree blk
trimBlockTree' Peers (PeerSchedule blk)
sch BlockTree blk
gtBlockTree
      shrunkAdversarialPeers :: [GenesisTestFull blk]
shrunkAdversarialPeers =
        (PeerSchedule blk -> [PeerSchedule blk])
-> Peers (PeerSchedule blk) -> [Peers (PeerSchedule blk)]
forall a. (a -> [a]) -> Peers a -> [Peers a]
shrinkAdversarialPeers PeerSchedule blk -> [PeerSchedule blk]
forall blk. PeerSchedule blk -> [PeerSchedule blk]
shrinkAdversarialPeer Peers (PeerSchedule blk)
psSchedule
          [Peers (PeerSchedule blk)]
-> (Peers (PeerSchedule blk) -> GenesisTestFull blk)
-> [GenesisTestFull blk]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Peers (PeerSchedule blk)
shrunkSchedule ->
            GenesisTestFull blk
genesisTest
              { gtSchedule =
                  PointSchedule
                    { psSchedule = shrunkSchedule
                    , psStartOrder
                    , psMinEndTime = simulationDuration
                    }
              , gtBlockTree = trimmedBlockTree shrunkSchedule
              }
      shrunkHonestPeers :: [GenesisTestFull blk]
shrunkHonestPeers =
        Peers (PeerSchedule blk) -> [Peers (PeerSchedule blk)]
forall blk. Peers (PeerSchedule blk) -> [Peers (PeerSchedule blk)]
shrinkHonestPeers
          Peers (PeerSchedule blk)
psSchedule
          -- No need to update the tree here, shrinking the honest peers never discards blocks
          [Peers (PeerSchedule blk)]
-> (Peers (PeerSchedule blk) -> GenesisTestFull blk)
-> [GenesisTestFull blk]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Peers (PeerSchedule blk)
shrunkSchedule ->
            GenesisTestFull blk
genesisTest
              { gtSchedule =
                  PointSchedule
                    { psSchedule = shrunkSchedule
                    , psStartOrder
                    , psMinEndTime = simulationDuration
                    }
              }
   in [GenesisTestFull blk]
shrunkAdversarialPeers [GenesisTestFull blk]
-> [GenesisTestFull blk] -> [GenesisTestFull blk]
forall a. [a] -> [a] -> [a]
++ [GenesisTestFull blk]
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 ::
  ( HasHeader blk
  , Ord blk
  ) =>
  GenesisTestFull blk ->
  StateView blk ->
  [GenesisTestFull blk]
shrinkByRemovingAdversaries :: forall blk.
(HasHeader blk, Ord blk) =>
GenesisTestFull blk -> StateView blk -> [GenesisTestFull blk]
shrinkByRemovingAdversaries genesisTest :: GenesisTestFull blk
genesisTest@GenesisTest{PointSchedule blk
gtSchedule :: forall blk schedule. GenesisTest blk schedule -> schedule
gtSchedule :: PointSchedule blk
gtSchedule, BlockTree blk
gtBlockTree :: forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree :: BlockTree blk
gtBlockTree} StateView blk
_stateView =
  (PeerSchedule blk -> [PeerSchedule blk])
-> Peers (PeerSchedule blk) -> [Peers (PeerSchedule blk)]
forall a. (a -> [a]) -> Peers a -> [Peers a]
shrinkAdversarialPeers ([PeerSchedule blk] -> PeerSchedule blk -> [PeerSchedule blk]
forall a b. a -> b -> a
const []) (PointSchedule blk -> Peers (PeerSchedule blk)
forall blk. PointSchedule blk -> Peers (PeerSchedule blk)
psSchedule PointSchedule blk
gtSchedule) [Peers (PeerSchedule blk)]
-> (Peers (PeerSchedule blk) -> GenesisTestFull blk)
-> [GenesisTestFull blk]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Peers (PeerSchedule blk)
shrunkSchedule ->
    let
      trimmedBlockTree :: BlockTree blk
trimmedBlockTree = Peers (PeerSchedule blk) -> BlockTree blk -> BlockTree blk
forall blk.
(Ord blk, HasHeader blk) =>
Peers (PeerSchedule blk) -> BlockTree blk -> BlockTree blk
trimBlockTree' Peers (PeerSchedule blk)
shrunkSchedule BlockTree blk
gtBlockTree
      simulationDuration :: Time
simulationDuration = PointSchedule blk -> Time
forall blk. PointSchedule blk -> Time
duration PointSchedule blk
gtSchedule
     in
      GenesisTestFull blk
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' ::
  ( Ord blk
  , HasHeader blk
  ) =>
  Peers (PeerSchedule blk) -> BlockTree blk -> BlockTree blk
trimBlockTree' :: forall blk.
(Ord blk, HasHeader blk) =>
Peers (PeerSchedule blk) -> BlockTree blk -> BlockTree blk
trimBlockTree' = [blk] -> BlockTree blk -> BlockTree blk
forall blk.
(Ord blk, HasHeader blk) =>
[blk] -> BlockTree blk -> BlockTree blk
keepOnlyAncestorsOf ([blk] -> BlockTree blk -> BlockTree blk)
-> (Peers (PeerSchedule blk) -> [blk])
-> Peers (PeerSchedule blk)
-> BlockTree blk
-> BlockTree blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Peers (PeerSchedule blk) -> [blk]
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 ::
  forall blk. (Ord blk, HasHeader blk) => [blk] -> BlockTree blk -> BlockTree blk
keepOnlyAncestorsOf :: forall blk.
(Ord blk, HasHeader blk) =>
[blk] -> BlockTree blk -> BlockTree blk
keepOnlyAncestorsOf [blk]
blocks BlockTree blk
bt =
  let leaves :: [blk]
leaves = [blk] -> [blk]
blocksWithoutDescendents [blk]
blocks
      trunk :: AnchoredFragment blk
trunk = [blk] -> AnchoredFragment blk -> AnchoredFragment blk
keepOnlyAncestorsOf' [blk]
leaves (BlockTree blk -> AnchoredFragment blk
forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk BlockTree blk
bt)
      branches :: [AnchoredFragment blk]
branches = (BlockTreeBranch blk -> Maybe (AnchoredFragment blk))
-> [BlockTreeBranch blk] -> [AnchoredFragment blk]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (AnchoredFragment blk -> Maybe (AnchoredFragment blk)
forall {v} {a} {b}.
Anchorable v a b =>
AnchoredSeq v a b -> Maybe (AnchoredSeq v a b)
fragmentToMaybe (AnchoredFragment blk -> Maybe (AnchoredFragment blk))
-> (BlockTreeBranch blk -> AnchoredFragment blk)
-> BlockTreeBranch blk
-> Maybe (AnchoredFragment blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [blk] -> AnchoredFragment blk -> AnchoredFragment blk
keepOnlyAncestorsOf' [blk]
leaves (AnchoredFragment blk -> AnchoredFragment blk)
-> (BlockTreeBranch blk -> AnchoredFragment blk)
-> BlockTreeBranch blk
-> AnchoredFragment blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockTreeBranch blk -> AnchoredFragment blk
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbSuffix) (BlockTree blk -> [BlockTreeBranch blk]
forall blk. BlockTree blk -> [BlockTreeBranch blk]
btBranches BlockTree blk
bt)
   in (AnchoredFragment blk -> BlockTree blk -> BlockTree blk)
-> BlockTree blk -> [AnchoredFragment blk] -> BlockTree blk
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr AnchoredFragment blk -> BlockTree blk -> BlockTree blk
forall blk.
HasHeader blk =>
AnchoredFragment blk -> BlockTree blk -> BlockTree blk
addBranch' (AnchoredFragment blk -> BlockTree blk
forall blk. HasHeader blk => AnchoredFragment blk -> BlockTree blk
mkTrunk AnchoredFragment blk
trunk) [AnchoredFragment blk]
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' :: [blk] -> AnchoredFragment blk -> AnchoredFragment blk
  keepOnlyAncestorsOf' :: [blk] -> AnchoredFragment blk -> AnchoredFragment blk
keepOnlyAncestorsOf' [blk]
leaves = (blk -> Bool) -> AnchoredFragment blk -> AnchoredFragment blk
forall v a b.
Anchorable v a b =>
(b -> Bool) -> AnchoredSeq v a b -> AnchoredSeq v a b
takeWhileOldest (\blk
block -> (BlockTree blk -> WithOrigin blk -> WithOrigin blk -> Bool
forall blk.
(HasHeader blk, Eq blk) =>
BlockTree blk -> WithOrigin blk -> WithOrigin blk -> Bool
isAncestorOf BlockTree blk
bt (blk -> WithOrigin blk
forall t. t -> WithOrigin t
Slot.at blk
block)) (WithOrigin blk -> Bool) -> [WithOrigin blk] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
`any` (blk -> WithOrigin blk) -> [blk] -> [WithOrigin blk]
forall a b. (a -> b) -> [a] -> [b]
map blk -> WithOrigin blk
forall t. t -> WithOrigin t
Slot.at [blk]
leaves)

  -- \| Return a subset of the given blocks containing only the ones that do
  -- not have any other descendents in the set.
  blocksWithoutDescendents :: [blk] -> [blk]
  blocksWithoutDescendents :: [blk] -> [blk]
blocksWithoutDescendents [blk]
bs =
    let bs' :: [WithOrigin blk]
bs' = (blk -> WithOrigin blk) -> [blk] -> [WithOrigin blk]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap blk -> WithOrigin blk
forall t. t -> WithOrigin t
Slot.at ([blk] -> [WithOrigin blk]) -> [blk] -> [WithOrigin blk]
forall a b. (a -> b) -> a -> b
$ [blk] -> [blk]
forall a. Ord a => [a] -> [a]
nubOrd [blk]
bs
     in [Maybe blk] -> [blk]
forall a. [Maybe a] -> [a]
catMaybes [WithOrigin blk -> Maybe blk
forall t. WithOrigin t -> Maybe t
Slot.withOriginToMaybe WithOrigin blk
b | WithOrigin blk
b <- [WithOrigin blk]
bs', Bool -> Bool
not ((BlockTree blk -> WithOrigin blk -> WithOrigin blk -> Bool
forall blk.
(HasHeader blk, Eq blk) =>
BlockTree blk -> WithOrigin blk -> WithOrigin blk -> Bool
isStrictAncestorOf BlockTree blk
bt WithOrigin blk
b) (WithOrigin blk -> Bool) -> [WithOrigin blk] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
`any` [WithOrigin blk]
bs')]