{-# LANGUAGE CPP #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}

#if __GLASGOW_HASKELL__ >= 908
{-# OPTIONS_GHC -Wno-x-partial #-}
#endif

-- REVIEW: There is a `BlockTree` in `Test.Utils.TestBlock`. It relies on
-- different mechanisms but maybe we should rely on that instead to avoid
-- duplication.

module Test.Consensus.BlockTree (
    BlockTree (..)
  , BlockTreeBranch (..)
  , PathAnchoredAtSource (..)
  , addBranch
  , addBranch'
  , allFragments
  , findFragment
  , findPath
  , mkTrunk
  , prettyBlockTree
  ) where

import           Cardano.Slotting.Slot (SlotNo (unSlotNo))
import           Data.Foldable (asum)
import           Data.Function ((&))
import           Data.Functor ((<&>))
import           Data.List (sortOn)
import           Data.Maybe (fromJust, fromMaybe)
import           Data.Ord (Down (Down))
import qualified Data.Vector as Vector
import           Ouroboros.Consensus.Block.Abstract (blockNo, blockSlot,
                     fromWithOrigin, pointSlot, unBlockNo)
import qualified Ouroboros.Network.AnchoredFragment as AF
import           Text.Printf (printf)

-- | Represent a branch of a block tree by a prefix and a suffix. The full
-- fragment (the prefix and suffix catenated) and the trunk suffix (the rest of
-- the trunk after the branch forks off) are provided for practicality.
--
-- INVARIANT: the head of @btbPrefix@ is the anchor of @btbSuffix@.
--
-- INVARIANT: @btbFull == fromJust $ AF.join btbPrefix btbSuffix@.
data BlockTreeBranch blk = BlockTreeBranch {
    forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbPrefix      :: AF.AnchoredFragment blk,
    forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbSuffix      :: AF.AnchoredFragment blk,
    forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbTrunkSuffix :: AF.AnchoredFragment blk,
    forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbFull        :: AF.AnchoredFragment blk
  }
  deriving (Int -> BlockTreeBranch blk -> ShowS
[BlockTreeBranch blk] -> ShowS
BlockTreeBranch blk -> String
(Int -> BlockTreeBranch blk -> ShowS)
-> (BlockTreeBranch blk -> String)
-> ([BlockTreeBranch blk] -> ShowS)
-> Show (BlockTreeBranch blk)
forall blk.
(StandardHash blk, Show blk) =>
Int -> BlockTreeBranch blk -> ShowS
forall blk.
(StandardHash blk, Show blk) =>
[BlockTreeBranch blk] -> ShowS
forall blk.
(StandardHash blk, Show blk) =>
BlockTreeBranch blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall blk.
(StandardHash blk, Show blk) =>
Int -> BlockTreeBranch blk -> ShowS
showsPrec :: Int -> BlockTreeBranch blk -> ShowS
$cshow :: forall blk.
(StandardHash blk, Show blk) =>
BlockTreeBranch blk -> String
show :: BlockTreeBranch blk -> String
$cshowList :: forall blk.
(StandardHash blk, Show blk) =>
[BlockTreeBranch blk] -> ShowS
showList :: [BlockTreeBranch blk] -> ShowS
Show)

-- | Represent a block tree with a main trunk and branches leaving from the
-- trunk in question. All the branches are represented by their prefix to and
-- suffix from the intersection point.
--
-- INVARIANT: The branches' prefixes share the same anchor as the trunk and are
-- fully contained in the trunk.
--
-- INVARIANT: The branches' suffixes are anchored in the trunk and do not
-- contain any blocks in common with the trunk.
--
-- INVARIANT: The branches' suffixes do not contain any block in common with one
-- another.
--
-- INVARIANT: for all @BlockTreeBranch{..}@ in the tree, @btTrunk == fromJust $
-- AF.join btbPrefix btbTrunkSuffix@.
--
-- REVIEW: Find another name so as not to clash with 'BlockTree' from
-- `unstable-consensus-testlib/Test/Util/TestBlock.hs`.
data BlockTree blk = BlockTree {
    forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk    :: AF.AnchoredFragment blk,
    forall blk. BlockTree blk -> [BlockTreeBranch blk]
btBranches :: [BlockTreeBranch blk]
  }
  deriving (Int -> BlockTree blk -> ShowS
[BlockTree blk] -> ShowS
BlockTree blk -> String
(Int -> BlockTree blk -> ShowS)
-> (BlockTree blk -> String)
-> ([BlockTree blk] -> ShowS)
-> Show (BlockTree blk)
forall blk.
(StandardHash blk, Show blk) =>
Int -> BlockTree blk -> ShowS
forall blk.
(StandardHash blk, Show blk) =>
[BlockTree blk] -> ShowS
forall blk. (StandardHash blk, Show blk) => BlockTree blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall blk.
(StandardHash blk, Show blk) =>
Int -> BlockTree blk -> ShowS
showsPrec :: Int -> BlockTree blk -> ShowS
$cshow :: forall blk. (StandardHash blk, Show blk) => BlockTree blk -> String
show :: BlockTree blk -> String
$cshowList :: forall blk.
(StandardHash blk, Show blk) =>
[BlockTree blk] -> ShowS
showList :: [BlockTree blk] -> ShowS
Show)

-- | Make a block tree made of only a trunk.
mkTrunk :: AF.AnchoredFragment blk -> BlockTree blk
mkTrunk :: forall blk. AnchoredFragment blk -> BlockTree blk
mkTrunk AnchoredFragment blk
btTrunk = BlockTree { AnchoredFragment blk
btTrunk :: AnchoredFragment blk
btTrunk :: AnchoredFragment blk
btTrunk, btBranches :: [BlockTreeBranch blk]
btBranches = [] }

-- | Add a branch to an existing block tree.
--
-- Yields @Nothing@ if the given fragment does not intersect with the trunk or its anchor.
--
-- FIXME: we should enforce that the branch's prefix shares the same anchor as
-- the trunk.
--
-- FIXME: we should enforce that the new branch' suffix does not contain any
-- block in common with an existing branch.
addBranch :: AF.HasHeader blk => AF.AnchoredFragment blk -> BlockTree blk -> Maybe (BlockTree blk)
addBranch :: forall blk.
HasHeader blk =>
AnchoredFragment blk -> BlockTree blk -> Maybe (BlockTree blk)
addBranch AnchoredFragment blk
branch BlockTree blk
bt = do
  (btbPrefix, _, btbTrunkSuffix, btbSuffix) <- AnchoredFragment blk
-> AnchoredFragment blk
-> Maybe
     (AnchoredFragment blk, AnchoredFragment blk, AnchoredFragment blk,
      AnchoredFragment blk)
forall block1 block2.
(HasHeader block1, HasHeader block2,
 HeaderHash block1 ~ HeaderHash block2) =>
AnchoredFragment block1
-> AnchoredFragment block2
-> Maybe
     (AnchoredFragment block1, AnchoredFragment block2,
      AnchoredFragment block1, AnchoredFragment block2)
AF.intersect (BlockTree blk -> AnchoredFragment blk
forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk BlockTree blk
bt) AnchoredFragment blk
branch
  -- NOTE: We could use the monadic bind for @Maybe@ here but we would rather
  -- catch bugs quicker.
  let btbFull = Maybe (AnchoredFragment blk) -> AnchoredFragment blk
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (AnchoredFragment blk) -> AnchoredFragment blk)
-> Maybe (AnchoredFragment blk) -> AnchoredFragment blk
forall a b. (a -> b) -> a -> b
$ AnchoredFragment blk
-> AnchoredFragment blk -> Maybe (AnchoredFragment blk)
forall block.
HasHeader block =>
AnchoredFragment block
-> AnchoredFragment block -> Maybe (AnchoredFragment block)
AF.join AnchoredFragment blk
btbPrefix AnchoredFragment blk
btbSuffix
  pure $ bt { btBranches = BlockTreeBranch { .. } : btBranches bt }

-- | Same as @addBranch@ but calls to 'error' if the former yields 'Nothing'.
addBranch' :: AF.HasHeader blk => AF.AnchoredFragment blk -> BlockTree blk -> BlockTree blk
addBranch' :: forall blk.
HasHeader blk =>
AnchoredFragment blk -> BlockTree blk -> BlockTree blk
addBranch' AnchoredFragment blk
branch BlockTree blk
blockTree =
  BlockTree blk -> Maybe (BlockTree blk) -> BlockTree blk
forall a. a -> Maybe a -> a
fromMaybe (String -> BlockTree blk
forall a. HasCallStack => String -> a
error String
"addBranch': precondition does not hold") (Maybe (BlockTree blk) -> BlockTree blk)
-> Maybe (BlockTree blk) -> BlockTree blk
forall a b. (a -> b) -> a -> b
$ AnchoredFragment blk -> BlockTree blk -> Maybe (BlockTree blk)
forall blk.
HasHeader blk =>
AnchoredFragment blk -> BlockTree blk -> Maybe (BlockTree blk)
addBranch AnchoredFragment blk
branch BlockTree blk
blockTree

-- | Return all the full fragments from the root of the tree.
allFragments :: BlockTree blk -> [AF.AnchoredFragment blk]
allFragments :: forall blk. BlockTree blk -> [AnchoredFragment blk]
allFragments BlockTree blk
bt = BlockTree blk -> AnchoredFragment blk
forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk BlockTree blk
bt AnchoredFragment blk
-> [AnchoredFragment blk] -> [AnchoredFragment blk]
forall a. a -> [a] -> [a]
: (BlockTreeBranch blk -> AnchoredFragment blk)
-> [BlockTreeBranch blk] -> [AnchoredFragment blk]
forall a b. (a -> b) -> [a] -> [b]
map BlockTreeBranch blk -> AnchoredFragment blk
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbFull (BlockTree blk -> [BlockTreeBranch blk]
forall blk. BlockTree blk -> [BlockTreeBranch blk]
btBranches BlockTree blk
bt)

-- | Look for a point in the block tree and return a fragment going from the
-- root of the tree to the point in question.
findFragment :: AF.HasHeader blk => AF.Point blk -> BlockTree blk -> Maybe (AF.AnchoredFragment blk)
findFragment :: forall blk.
HasHeader blk =>
Point blk -> BlockTree blk -> Maybe (AnchoredFragment blk)
findFragment Point blk
point BlockTree blk
blockTree =
  BlockTree blk -> [AnchoredFragment blk]
forall blk. BlockTree blk -> [AnchoredFragment blk]
allFragments BlockTree blk
blockTree
    [AnchoredFragment blk]
-> ([AnchoredFragment blk]
    -> [Maybe (AnchoredFragment blk, AnchoredFragment blk)])
-> [Maybe (AnchoredFragment blk, AnchoredFragment blk)]
forall a b. a -> (a -> b) -> b
& (AnchoredFragment blk
 -> Maybe (AnchoredFragment blk, AnchoredFragment blk))
-> [AnchoredFragment blk]
-> [Maybe (AnchoredFragment blk, AnchoredFragment blk)]
forall a b. (a -> b) -> [a] -> [b]
map (\AnchoredFragment blk
fragment -> AnchoredFragment blk
-> Point blk -> Maybe (AnchoredFragment blk, AnchoredFragment blk)
forall block1 block2.
(HasHeader block1, HeaderHash block1 ~ HeaderHash block2) =>
AnchoredFragment block1
-> Point block2
-> Maybe (AnchoredFragment block1, AnchoredFragment block1)
AF.splitAfterPoint AnchoredFragment blk
fragment Point blk
point)
    [Maybe (AnchoredFragment blk, AnchoredFragment blk)]
-> ([Maybe (AnchoredFragment blk, AnchoredFragment blk)]
    -> Maybe (AnchoredFragment blk, AnchoredFragment blk))
-> Maybe (AnchoredFragment blk, AnchoredFragment blk)
forall a b. a -> (a -> b) -> b
& [Maybe (AnchoredFragment blk, AnchoredFragment blk)]
-> Maybe (AnchoredFragment blk, AnchoredFragment blk)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
    Maybe (AnchoredFragment blk, AnchoredFragment blk)
-> ((AnchoredFragment blk, AnchoredFragment blk)
    -> AnchoredFragment blk)
-> Maybe (AnchoredFragment blk)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (AnchoredFragment blk, AnchoredFragment blk)
-> AnchoredFragment blk
forall a b. (a, b) -> a
fst

-- | See 'findPath'.
newtype PathAnchoredAtSource = PathAnchoredAtSource Bool

-- | @findPath source target blockTree@ finds a path from the @source@ point to
-- the @target@ point in the @blockTree@ and returns it as an anchored fragment
-- It returns @Nothing@ when either of @source@ are @target@ are not in the
-- 'BlockTree'. There are two interesting properties on this fragment:
--
--   1. Whether the returned fragment is anchored at the @source@.
--   2. Whether the returned fragment is empty.
--
-- Together, those two properties form four interesting cases:
--
--   a. If the fragment is anchored at the @source@ and is empty, then @source
--      == target@.
--
--   b. If the fragment is anchored at the @source@ and is not empty, then
--      @source@ is an ancestor of @target@ and the fragment contains all the
--      blocks between them, @target@ included.
--
--   c. If the fragment is not anchored at the @source@ and is empty, then
--      @target@ is an ancestor of @source@.
--
--   d. If the fragment is not anchored at the @source@ and is not empty, then
--      it is anchored at the youngest common ancestor of both @source@ and
--      @target@ and contains all the blocks between that ancestor and @target@.
findPath ::
  AF.HasHeader blk =>
  AF.Point blk ->
  AF.Point blk ->
  BlockTree blk ->
  Maybe (PathAnchoredAtSource, AF.AnchoredFragment blk)
findPath :: forall blk.
HasHeader blk =>
Point blk
-> Point blk
-> BlockTree blk
-> Maybe (PathAnchoredAtSource, AnchoredFragment blk)
findPath Point blk
source Point blk
target BlockTree blk
blockTree = do
  sourceFragment <- Point blk -> BlockTree blk -> Maybe (AnchoredFragment blk)
forall blk.
HasHeader blk =>
Point blk -> BlockTree blk -> Maybe (AnchoredFragment blk)
findFragment Point blk
source BlockTree blk
blockTree
  targetFragment <- findFragment target blockTree
  (_, _, _, targetSuffix) <- AF.intersect sourceFragment targetFragment
  pure (
    PathAnchoredAtSource (AF.anchorPoint targetSuffix == source),
    targetSuffix
    )

-- | Pretty prints a block tree for human readability. For instance:
--
--     slots:  0  1  2  3  4  5  6  7  8  9
--     trunk:  0─────1──2──3──4─────5──6──7
--                      ╰─────3──4─────5
--
-- Returns a list of strings intended to be catenated with a newline.
prettyBlockTree :: AF.HasHeader blk => BlockTree blk -> [String]
prettyBlockTree :: forall blk. HasHeader blk => BlockTree blk -> [String]
prettyBlockTree BlockTree blk
blockTree =
  [String
"slots:   " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords ((SlotNo -> String) -> [SlotNo] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Word64 -> String
forall r. PrintfType r => String -> r
printf String
"%2d" (Word64 -> String) -> (SlotNo -> Word64) -> SlotNo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotNo -> Word64
unSlotNo) [SlotNo
veryFirstSlot .. SlotNo
veryLastSlot])]
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [AnchoredFragment blk -> String
forall blk. HasHeader blk => AnchoredFragment blk -> String
printTrunk AnchoredFragment blk
honestFragment]
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (((Int, AnchoredFragment blk) -> String)
-> [(Int, AnchoredFragment blk)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> AnchoredFragment blk -> String)
-> (Int, AnchoredFragment blk) -> String
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> AnchoredFragment blk -> String
forall blk. HasHeader blk => Int -> AnchoredFragment blk -> String
printBranch) [(Int, AnchoredFragment blk)]
adversarialFragments)

  where
    honestFragment :: AnchoredFragment blk
honestFragment = BlockTree blk -> AnchoredFragment blk
forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk BlockTree blk
blockTree
    adversarialFragments :: [(Int, AnchoredFragment blk)]
adversarialFragments =
        ((Int, AnchoredFragment blk) -> Down (WithOrigin SlotNo))
-> [(Int, AnchoredFragment blk)] -> [(Int, AnchoredFragment blk)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (WithOrigin SlotNo -> Down (WithOrigin SlotNo)
forall a. a -> Down a
Down (WithOrigin SlotNo -> Down (WithOrigin SlotNo))
-> ((Int, AnchoredFragment blk) -> WithOrigin SlotNo)
-> (Int, AnchoredFragment blk)
-> Down (WithOrigin SlotNo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point blk -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot (Point blk -> WithOrigin SlotNo)
-> ((Int, AnchoredFragment blk) -> Point blk)
-> (Int, AnchoredFragment blk)
-> WithOrigin SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment blk -> Point blk
forall block. AnchoredFragment block -> Point block
AF.anchorPoint (AnchoredFragment blk -> Point blk)
-> ((Int, AnchoredFragment blk) -> AnchoredFragment blk)
-> (Int, AnchoredFragment blk)
-> Point blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, AnchoredFragment blk) -> AnchoredFragment blk
forall a b. (a, b) -> b
snd)
      ([(Int, AnchoredFragment blk)] -> [(Int, AnchoredFragment blk)])
-> [(Int, AnchoredFragment blk)] -> [(Int, AnchoredFragment blk)]
forall a b. (a -> b) -> a -> b
$ [Int] -> [AnchoredFragment blk] -> [(Int, AnchoredFragment blk)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..]
      ([AnchoredFragment blk] -> [(Int, AnchoredFragment blk)])
-> [AnchoredFragment blk] -> [(Int, AnchoredFragment blk)]
forall a b. (a -> b) -> a -> b
$ (BlockTreeBranch blk -> AnchoredFragment blk)
-> [BlockTreeBranch blk] -> [AnchoredFragment blk]
forall a b. (a -> b) -> [a] -> [b]
map BlockTreeBranch blk -> AnchoredFragment blk
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbSuffix (BlockTree blk -> [BlockTreeBranch blk]
forall blk. BlockTree blk -> [BlockTreeBranch blk]
btBranches BlockTree blk
blockTree)

    veryFirstSlot :: SlotNo
veryFirstSlot = AnchoredFragment blk -> SlotNo
forall blk. AnchoredFragment blk -> SlotNo
firstNo (AnchoredFragment blk -> SlotNo) -> AnchoredFragment blk -> SlotNo
forall a b. (a -> b) -> a -> b
$ AnchoredFragment blk
honestFragment

    veryLastSlot :: SlotNo
veryLastSlot =
      (SlotNo -> SlotNo -> SlotNo) -> SlotNo -> [SlotNo] -> SlotNo
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl SlotNo -> SlotNo -> SlotNo
forall a. Ord a => a -> a -> a
max SlotNo
0 ([SlotNo] -> SlotNo) -> [SlotNo] -> SlotNo
forall a b. (a -> b) -> a -> b
$
        (AnchoredFragment blk -> SlotNo)
-> [AnchoredFragment blk] -> [SlotNo]
forall a b. (a -> b) -> [a] -> [b]
map
          AnchoredFragment blk -> SlotNo
forall blk. HasHeader blk => AnchoredFragment blk -> SlotNo
lastNo
          (AnchoredFragment blk
honestFragment AnchoredFragment blk
-> [AnchoredFragment blk] -> [AnchoredFragment blk]
forall a. a -> [a] -> [a]
: ((Int, AnchoredFragment blk) -> AnchoredFragment blk)
-> [(Int, AnchoredFragment blk)] -> [AnchoredFragment blk]
forall a b. (a -> b) -> [a] -> [b]
map (Int, AnchoredFragment blk) -> AnchoredFragment blk
forall a b. (a, b) -> b
snd [(Int, AnchoredFragment blk)]
adversarialFragments)

    printTrunk :: AF.HasHeader blk => AF.AnchoredFragment blk -> String
    printTrunk :: forall blk. HasHeader blk => AnchoredFragment blk -> String
printTrunk = (SlotNo -> String) -> AnchoredFragment blk -> String
forall blk.
HasHeader blk =>
(SlotNo -> String) -> AnchoredFragment blk -> String
printLine (\SlotNo
_ -> String
"trunk:  ─")

    printBranch :: AF.HasHeader blk => Int -> AF.AnchoredFragment blk -> String
    printBranch :: forall blk. HasHeader blk => Int -> AnchoredFragment blk -> String
printBranch Int
idx = (SlotNo -> String) -> AnchoredFragment blk -> String
forall blk.
HasHeader blk =>
(SlotNo -> String) -> AnchoredFragment blk -> String
printLine ((SlotNo -> String) -> AnchoredFragment blk -> String)
-> (SlotNo -> String) -> AnchoredFragment blk -> String
forall a b. (a -> b) -> a -> b
$ \SlotNo
firstSlot ->
      let sidx :: String
sidx = String
"  (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
idx String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
          pad :: String
pad = Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
6 Char
' '
          prefix :: String
prefix = String
sidx String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> ShowS
forall a. Int -> [a] -> [a]
drop (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
sidx) String
pad
       in
       String
prefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (SlotNo -> Word64
unSlotNo (SlotNo
firstSlot SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
- SlotNo
veryFirstSlot))) Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" ╰─"

    printLine :: AF.HasHeader blk => (SlotNo -> String) -> AF.AnchoredFragment blk -> String
    printLine :: forall blk.
HasHeader blk =>
(SlotNo -> String) -> AnchoredFragment blk -> String
printLine SlotNo -> String
printHeader AnchoredFragment blk
fragment =
      let firstSlot :: SlotNo
firstSlot = AnchoredFragment blk -> SlotNo
forall blk. AnchoredFragment blk -> SlotNo
firstNo AnchoredFragment blk
fragment
          lastSlot :: SlotNo
lastSlot = AnchoredFragment blk -> SlotNo
forall blk. HasHeader blk => AnchoredFragment blk -> SlotNo
lastNo AnchoredFragment blk
fragment
      in SlotNo -> String
printHeader SlotNo
firstSlot String -> ShowS
forall a. [a] -> [a] -> [a]
++ SlotNo -> SlotNo -> AnchoredFragment blk -> String
forall blk.
HasHeader blk =>
SlotNo -> SlotNo -> AnchoredFragment blk -> String
printFragment SlotNo
firstSlot SlotNo
lastSlot AnchoredFragment blk
fragment

    printFragment :: AF.HasHeader blk => SlotNo -> SlotNo -> AF.AnchoredFragment blk -> String
    printFragment :: forall blk.
HasHeader blk =>
SlotNo -> SlotNo -> AnchoredFragment blk -> String
printFragment SlotNo
firstSlot SlotNo
lastSlot AnchoredFragment blk
fragment =
      AnchoredFragment blk
fragment
        AnchoredFragment blk -> (AnchoredFragment blk -> [blk]) -> [blk]
forall a b. a -> (a -> b) -> b
& AnchoredFragment blk -> [blk]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst
        -- Turn the fragment into a list of (SlotNo, Just BlockNo)
        [blk] -> ([blk] -> [(Int, Maybe Word64)]) -> [(Int, Maybe Word64)]
forall a b. a -> (a -> b) -> b
& (blk -> (Int, Maybe Word64)) -> [blk] -> [(Int, Maybe Word64)]
forall a b. (a -> b) -> [a] -> [b]
map (\blk
block -> (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (SlotNo -> Word64
unSlotNo (blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot blk
block) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- SlotNo -> Word64
unSlotNo SlotNo
firstSlot), Word64 -> Maybe Word64
forall a. a -> Maybe a
Just (BlockNo -> Word64
unBlockNo (blk -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo blk
block))))
        -- Update only the Vector elements that have blocks in them
        [(Int, Maybe Word64)]
-> ([(Int, Maybe Word64)] -> [Maybe Word64]) -> [Maybe Word64]
forall a b. a -> (a -> b) -> b
& Vector (Maybe Word64) -> [Maybe Word64]
forall a. Vector a -> [a]
Vector.toList (Vector (Maybe Word64) -> [Maybe Word64])
-> ([(Int, Maybe Word64)] -> Vector (Maybe Word64))
-> [(Int, Maybe Word64)]
-> [Maybe Word64]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vector (Maybe Word64)
forall {a}. Vector (Maybe a)
slotRange Vector (Maybe Word64)
-> [(Int, Maybe Word64)] -> Vector (Maybe Word64)
forall a. Vector a -> [(Int, a)] -> Vector a
Vector.//)
        [Maybe Word64] -> ([Maybe Word64] -> [String]) -> [String]
forall a b. a -> (a -> b) -> b
& (Maybe Word64 -> String) -> [Maybe Word64] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> (Word64 -> String) -> Maybe Word64 -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"  " (String -> Word64 -> String
forall r. PrintfType r => String -> r
printf String
"%2d"))
        [String] -> ([String] -> String) -> String
forall a b. a -> (a -> b) -> b
& [String] -> String
unwords
        String -> ShowS -> String
forall a b. a -> (a -> b) -> b
& (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' then Char
'─' else Char
c)
      where
        -- Initialize a Vector with the length of the fragment containing only Nothings
        slotRange :: Vector (Maybe a)
slotRange = Int -> Maybe a -> Vector (Maybe a)
forall a. Int -> a -> Vector a
Vector.replicate (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (SlotNo -> Word64
unSlotNo SlotNo
lastSlot Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- SlotNo -> Word64
unSlotNo SlotNo
firstSlot Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1)) Maybe a
forall a. Maybe a
Nothing

    lastNo ::  AF.HasHeader blk => AF.AnchoredFragment blk -> SlotNo
    lastNo :: forall blk. HasHeader blk => AnchoredFragment blk -> SlotNo
lastNo = SlotNo -> WithOrigin SlotNo -> SlotNo
forall t. t -> WithOrigin t -> t
fromWithOrigin SlotNo
0 (WithOrigin SlotNo -> SlotNo)
-> (AnchoredFragment blk -> WithOrigin SlotNo)
-> AnchoredFragment blk
-> SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment blk -> WithOrigin SlotNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin SlotNo
AF.headSlot

    firstNo :: AF.AnchoredFragment blk -> SlotNo
    firstNo :: forall blk. AnchoredFragment blk -> SlotNo
firstNo AnchoredFragment blk
frag =
      case AnchoredFragment blk -> Anchor blk
forall v a b. AnchoredSeq v a b -> a
AF.anchor AnchoredFragment blk
frag of
        Anchor blk
AF.AnchorGenesis     -> SlotNo
0
        AF.Anchor SlotNo
slotNo HeaderHash blk
_ BlockNo
_ -> SlotNo
slotNo SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
1