{-# 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