{-# 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
$sel:gtBlockTree:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> BlockTree blk
gtBlockTree, PointSchedule TestBlock
gtSchedule :: PointSchedule TestBlock
$sel:gtSchedule:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> schedule
gtSchedule} StateView TestBlock
_stateView =
  let PointSchedule {Peers (PeerSchedule TestBlock)
psSchedule :: Peers (PeerSchedule TestBlock)
$sel:psSchedule:PointSchedule :: forall blk. PointSchedule blk -> Peers (PeerSchedule blk)
psSchedule} = 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
                  , 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
            , 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
$sel:gtSchedule:GenesisTest :: forall blk schedule. GenesisTest blk schedule -> schedule
gtSchedule :: PointSchedule TestBlock
gtSchedule, BlockTree TestBlock
$sel:gtBlockTree:GenesisTest :: 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
        , psMinEndTime = simulationDuration
        }
      , gtBlockTree = trimmedBlockTree
      }

duration :: PointSchedule blk -> Time
duration :: forall blk. PointSchedule blk -> Time
duration PointSchedule {Peers (PeerSchedule blk)
$sel:psSchedule:PointSchedule :: forall blk. PointSchedule blk -> Peers (PeerSchedule blk)
psSchedule :: Peers (PeerSchedule blk)
psSchedule, Time
$sel:psMinEndTime:PointSchedule :: 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
$sel:honestPeers:Peers :: forall a. Peers a -> Map Int a
honestPeers, Map Int a
adversarialPeers :: Map Int a
$sel:adversarialPeers:Peers :: 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)
$sel:honestPeers:Peers :: forall a. Peers a -> Map Int a
honestPeers :: Map Int (PeerSchedule blk)
honestPeers, Map Int (PeerSchedule blk)
$sel:adversarialPeers:Peers :: forall a. Peers a -> Map Int a
adversarialPeers :: Map Int (PeerSchedule blk)
adversarialPeers} = do
  (Int
k, PeerSchedule blk
honestSch) <- Map Int (PeerSchedule blk) -> [(Int, PeerSchedule blk)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Int (PeerSchedule blk)
honestPeers
  PeerSchedule blk
shrunk <- PeerSchedule blk -> [PeerSchedule blk]
forall blk. PeerSchedule blk -> [PeerSchedule blk]
shrinkHonestPeer PeerSchedule blk
honestSch
  Peers (PeerSchedule blk) -> [Peers (PeerSchedule blk)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Peers (PeerSchedule blk) -> [Peers (PeerSchedule blk)])
-> Peers (PeerSchedule blk) -> [Peers (PeerSchedule blk)]
forall a b. (a -> b) -> a -> b
$ Peers
    { $sel:honestPeers:Peers :: Map Int (PeerSchedule blk)
honestPeers = Int
-> PeerSchedule blk
-> Map Int (PeerSchedule blk)
-> Map Int (PeerSchedule blk)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
k PeerSchedule blk
shrunk Map Int (PeerSchedule blk)
honestPeers
    , Map Int (PeerSchedule blk)
$sel:adversarialPeers:Peers :: Map Int (PeerSchedule blk)
adversarialPeers :: Map Int (PeerSchedule blk)
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') ]