{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

-- | A pretty-printer and tracer that shows the current peer simulator state in
-- a block tree, highlighting the candidate fragments, selection, and forks in
-- different colors, omitting uninteresting segments.
module Test.Consensus.PeerSimulator.StateDiagram
  ( PeerSimState (..)
  , RenderConfig (..)
  , defaultRenderConfig
  , peerSimStateDiagram
  , peerSimStateDiagramSTMTracer
  , peerSimStateDiagramSTMTracerDebug
  , peerSimStateDiagramTracer
  , peerSimStateDiagramWith
  ) where

import Cardano.Slotting.Block (BlockNo (BlockNo))
import Cardano.Slotting.Slot
  ( SlotNo (SlotNo)
  , WithOrigin (..)
  , fromWithOrigin
  , withOrigin
  )
import Control.Monad (guard)
import Control.Monad.State.Strict
  ( State
  , gets
  , modify'
  , runState
  , state
  )
import Control.Tracer (Tracer (Tracer), debugTracer, traceWith)
import Data.Bifunctor (first)
import Data.Foldable as Foldable (foldl', foldr')
import Data.List (intersperse, mapAccumL, sort, transpose)
import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty, (<|))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Map (Map)
import Data.Map.Strict ((!?))
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Monoid (First (..))
import Data.String (IsString (fromString))
import Data.Vector (Vector)
import qualified Data.Vector as Vector
import qualified Data.Vector.Mutable as MV
import Data.Word (Word64)
import qualified Debug.Trace as Debug
import GHC.Exts (IsList (..))
import Ouroboros.Consensus.Block
  ( ChainHash (BlockHash)
  , GetHeader
  , Header
  , StandardHash
  , WithOrigin (NotOrigin)
  , blockHash
  , blockNo
  , blockSlot
  , getHeader
  )
import Ouroboros.Consensus.Util (eitherToMaybe)
import Ouroboros.Consensus.Util.Condense (Condense (..))
import Ouroboros.Consensus.Util.IOLike
  ( IOLike
  , MonadSTM (STM)
  , atomically
  , modifyTVar
  , readTVar
  , uncheckedNewTVarM
  )
import Ouroboros.Network.AnchoredFragment (anchor, anchorToSlotNo)
import qualified Ouroboros.Network.AnchoredFragment as AF
import Ouroboros.Network.Block (HeaderHash)
import Test.Consensus.BlockTree
  ( BlockTree (btBranches, btTrunk)
  , BlockTreeBranch (btbSuffix)
  , deforestBlockTree
  , prettyBlockTree
  )
import Test.Consensus.PointSchedule.NodeState
  ( NodeState (..)
  , genesisNodeState
  )
import Test.Consensus.PointSchedule.Peers (PeerId (..))

enableDebug :: Bool
enableDebug :: Bool
enableDebug = Bool
False

debugRender :: String -> a -> a
debugRender :: forall a. [Char] -> a -> a
debugRender
  | Bool
enableDebug =
      [Char] -> a -> a
forall a. [Char] -> a -> a
Debug.trace
  | Bool
otherwise =
      (a -> a) -> [Char] -> a -> a
forall a b. a -> b -> a
const a -> a
forall a. a -> a
id

----------------------------------------------------------------------------------------------------
-- Colors
----------------------------------------------------------------------------------------------------

data SGR
  = Color Word64
  | BgColor Word64
  | Bold
  | Reset
  | Keep

renderSgr :: [SGR] -> String
renderSgr :: [SGR] -> [Char]
renderSgr =
  (SGR -> [Char]) -> [SGR] -> [Char]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((SGR -> [Char]) -> [SGR] -> [Char])
-> (SGR -> [Char]) -> [SGR] -> [Char]
forall a b. (a -> b) -> a -> b
$ \case
    Color Word64
n -> [Char] -> [Char]
sgr ([Char]
"38;5;" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
n)
    BgColor Word64
n -> [Char] -> [Char]
sgr ([Char]
"48;5;" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
n)
    SGR
Bold -> [Char] -> [Char]
sgr [Char]
"1"
    SGR
Reset -> [Char] -> [Char]
sgr [Char]
"0"
    SGR
Keep -> [Char]
""
 where
  sgr :: [Char] -> [Char]
sgr [Char]
x = [Char]
"\ESC[" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"m"

data Col
  = ColAspect (NonEmpty Aspect) Col
  | Col [SGR] Col
  | ColString String
  | ColCat [Col]

instance IsString Col where
  fromString :: [Char] -> Col
fromString = [Char] -> Col
ColString

instance IsList Col where
  type Item Col = Col
  fromList :: [Item Col] -> Col
fromList = [Item Col] -> Col
[Col] -> Col
ColCat
  toList :: Col -> [Item Col]
toList = \case
    ColCat [Col]
cols -> [Item Col]
[Col]
cols
    Col
c -> [Item Col
Col
c]

instance Semigroup Col where
  Col
l <> :: Col -> Col -> Col
<> Col
r = [Col] -> Col
ColCat [Col
l, Col
r]

instance Monoid Col where
  mempty :: Col
mempty = Col
""

colLength :: Col -> Int
colLength :: Col -> Int
colLength = \case
  ColAspect NonEmpty Aspect
_ Col
c -> Col -> Int
colLength Col
c
  Col [SGR]
_ Col
c -> Col -> Int
colLength Col
c
  ColString [Char]
s -> [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
s
  ColCat [Col]
cs -> [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (Col -> Int
colLength (Col -> Int) -> [Col] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Col]
cs)

data Colors
  = Colors
  { Colors -> [Word64]
candidates :: [Word64]
  , Colors -> Maybe Word64
selection :: Maybe Word64
  , Colors -> Word64
slotNumber :: Word64
  , Colors -> Map PeerId Word64
cache :: Map PeerId Word64
  , Colors -> [[SGR]]
stack :: [[SGR]]
  }

candidateColor :: PeerId -> Colors -> (Maybe Word64, Colors)
candidateColor :: PeerId -> Colors -> (Maybe Word64, Colors)
candidateColor PeerId
pid s :: Colors
s@Colors{[Word64]
candidates :: Colors -> [Word64]
candidates :: [Word64]
candidates, Map PeerId Word64
cache :: Colors -> Map PeerId Word64
cache :: Map PeerId Word64
cache}
  | Just Word64
c <- Maybe Word64
cached =
      (Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
c, Colors
s)
  | Word64
h : [Word64]
t <- (Word64 -> Bool) -> [Word64] -> [Word64]
forall a. (a -> Bool) -> [a] -> [a]
filter Word64 -> Bool
unused [Word64]
candidates =
      (Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
h, Colors
s{candidates = t, cache = Map.insert pid h cache})
  | Bool
otherwise =
      (Maybe Word64
forall a. Maybe a
Nothing, Colors
s)
 where
  cached :: Maybe Word64
cached = Map PeerId Word64
cache Map PeerId Word64 -> PeerId -> Maybe Word64
forall k a. Ord k => Map k a -> k -> Maybe a
!? PeerId
pid
  unused :: Word64 -> Bool
unused Word64
c = Bool -> Bool
not (Word64 -> Map PeerId Word64 -> Bool
forall a. Eq a => a -> Map PeerId a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Word64
c Map PeerId Word64
cache)

getColor :: Bool -> Aspect -> State Colors (Maybe [SGR])
getColor :: Bool -> Aspect -> State Colors (Maybe [SGR])
getColor Bool
bg = \case
  Aspect
Selection -> do
    c <- (Colors -> Maybe Word64) -> StateT Colors Identity (Maybe Word64)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Colors -> Maybe Word64
selection
    pure (Just (Bold : maybe [] (pure . mkColor) c))
  Candidate PeerId
pid ->
    PeerId -> State Colors (Maybe [SGR])
peerColor PeerId
pid
  Aspect
Fork -> Maybe [SGR] -> State Colors (Maybe [SGR])
forall a. a -> StateT Colors Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [SGR]
forall a. Maybe a
Nothing
  Aspect
SlotNumber -> do
    c <- (Colors -> Word64) -> StateT Colors Identity Word64
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Colors -> Word64
slotNumber
    pure (Just [mkColor c])
  TipPoint PeerId
pid ->
    PeerId -> State Colors (Maybe [SGR])
peerColor PeerId
pid
 where
  peerColor :: PeerId -> State Colors (Maybe [SGR])
peerColor PeerId
pid =
    (Word64 -> [SGR]) -> Maybe Word64 -> Maybe [SGR]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SGR -> [SGR]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SGR -> [SGR]) -> (Word64 -> SGR) -> Word64 -> [SGR]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> SGR
mkColor) (Maybe Word64 -> Maybe [SGR])
-> StateT Colors Identity (Maybe Word64)
-> State Colors (Maybe [SGR])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Colors -> (Maybe Word64, Colors))
-> StateT Colors Identity (Maybe Word64)
forall a. (Colors -> (a, Colors)) -> StateT Colors Identity a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (PeerId -> Colors -> (Maybe Word64, Colors)
candidateColor PeerId
pid)
  mkColor :: Word64 -> SGR
mkColor
    | Bool
bg = Word64 -> SGR
BgColor
    | Bool
otherwise = Word64 -> SGR
Color

getColors :: NonEmpty Aspect -> State Colors [SGR]
getColors :: NonEmpty Aspect -> State Colors [SGR]
getColors NonEmpty Aspect
aspects = do
  (main, rest) <- Bool -> [Aspect] -> StateT Colors Identity ([SGR], [Aspect])
findColor Bool
False (NonEmpty Aspect -> [Aspect]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Aspect
aspects)
  (bg, _) <- findColor True rest
  pure (main ++ bg)
 where
  findColor :: Bool -> [Aspect] -> StateT Colors Identity ([SGR], [Aspect])
findColor Bool
bg (Aspect
h : [Aspect]
t) =
    Bool -> Aspect -> State Colors (Maybe [SGR])
getColor Bool
bg Aspect
h State Colors (Maybe [SGR])
-> (Maybe [SGR] -> StateT Colors Identity ([SGR], [Aspect]))
-> StateT Colors Identity ([SGR], [Aspect])
forall a b.
StateT Colors Identity a
-> (a -> StateT Colors Identity b) -> StateT Colors Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just [SGR]
c -> ([SGR], [Aspect]) -> StateT Colors Identity ([SGR], [Aspect])
forall a. a -> StateT Colors Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([SGR]
c, [Aspect]
t)
      Maybe [SGR]
Nothing -> Bool -> [Aspect] -> StateT Colors Identity ([SGR], [Aspect])
findColor Bool
bg [Aspect]
t
  findColor Bool
_ [] = ([SGR], [Aspect]) -> StateT Colors Identity ([SGR], [Aspect])
forall a. a -> StateT Colors Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [])

renderCol :: Col -> State Colors String
renderCol :: Col -> State Colors [Char]
renderCol Col
col =
  Col -> State Colors [Char]
spin Col
col
 where
  spin :: Col -> State Colors [Char]
spin = \case
    ColAspect NonEmpty Aspect
aspects Col
sub -> do
      sgr <- NonEmpty Aspect -> State Colors [SGR]
getColors NonEmpty Aspect
aspects
      withSgr sgr sub
    Col [SGR]
sgr Col
sub ->
      [SGR] -> Col -> State Colors [Char]
withSgr [SGR]
sgr Col
sub
    ColString [Char]
s -> [Char] -> State Colors [Char]
forall a. a -> StateT Colors Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
s
    ColCat [Col]
cols -> [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Char]] -> [Char])
-> StateT Colors Identity [[Char]] -> State Colors [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Col -> State Colors [Char])
-> [Col] -> StateT Colors Identity [[Char]]
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) -> [a] -> f [b]
traverse Col -> State Colors [Char]
spin [Col]
cols

  withSgr :: [SGR] -> Col -> State Colors [Char]
withSgr [SGR]
sgr Col
sub = do
    pre <- [SGR] -> State Colors [SGR]
forall {m :: * -> *}. MonadState Colors m => [SGR] -> m [SGR]
push [SGR]
sgr
    s <- spin sub
    pop
    pure (renderSgr sgr ++ s ++ renderSgr pre)

  push :: [SGR] -> m [SGR]
push [SGR]
sgr =
    (Colors -> ([SGR], Colors)) -> m [SGR]
forall a. (Colors -> (a, Colors)) -> m a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state ((Colors -> ([SGR], Colors)) -> m [SGR])
-> (Colors -> ([SGR], Colors)) -> m [SGR]
forall a b. (a -> b) -> a -> b
$ \case
      s :: Colors
s@Colors{stack :: Colors -> [[SGR]]
stack = []} -> ([SGR
Reset], Colors
s{stack = [sgr, [Reset]]})
      s :: Colors
s@Colors{stack :: Colors -> [[SGR]]
stack = [SGR]
h : [[SGR]]
t} -> ([SGR
Reset], Colors
s{stack = sgr : h : t})

  pop :: StateT Colors Identity ()
pop = (Colors -> Colors) -> StateT Colors Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' ((Colors -> Colors) -> StateT Colors Identity ())
-> (Colors -> Colors) -> StateT Colors Identity ()
forall a b. (a -> b) -> a -> b
$ \s :: Colors
s@Colors{[[SGR]]
stack :: Colors -> [[SGR]]
stack :: [[SGR]]
stack} -> Colors
s{stack = drop 1 stack}

runCol :: [Word64] -> Maybe Word64 -> Word64 -> Map PeerId Word64 -> State Colors a -> (a, Colors)
runCol :: forall a.
[Word64]
-> Maybe Word64
-> Word64
-> Map PeerId Word64
-> State Colors a
-> (a, Colors)
runCol [Word64]
cand Maybe Word64
selection Word64
slotNumber Map PeerId Word64
cache State Colors a
s =
  State Colors a -> Colors -> (a, Colors)
forall s a. State s a -> s -> (a, s)
runState State Colors a
s Colors{candidates :: [Word64]
candidates = [Word64]
cand, Maybe Word64
selection :: Maybe Word64
selection :: Maybe Word64
selection, Word64
slotNumber :: Word64
slotNumber :: Word64
slotNumber, Map PeerId Word64
cache :: Map PeerId Word64
cache :: Map PeerId Word64
cache, stack :: [[SGR]]
stack = []}

----------------------------------------------------------------------------------------------------
-- Slots
----------------------------------------------------------------------------------------------------

slotInt :: SlotNo -> Int
slotInt :: SlotNo -> Int
slotInt (SlotNo Word64
s) = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
s

blockInt :: BlockNo -> Int
blockInt :: BlockNo -> Int
blockInt (BlockNo Word64
s) = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
s

data Range
  = Range
  { Range -> Int
from :: Int
  , Range -> Int
to :: Int
  }
  deriving (Int -> Range -> [Char] -> [Char]
[Range] -> [Char] -> [Char]
Range -> [Char]
(Int -> Range -> [Char] -> [Char])
-> (Range -> [Char]) -> ([Range] -> [Char] -> [Char]) -> Show Range
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> Range -> [Char] -> [Char]
showsPrec :: Int -> Range -> [Char] -> [Char]
$cshow :: Range -> [Char]
show :: Range -> [Char]
$cshowList :: [Range] -> [Char] -> [Char]
showList :: [Range] -> [Char] -> [Char]
Show, Range -> Range -> Bool
(Range -> Range -> Bool) -> (Range -> Range -> Bool) -> Eq Range
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Range -> Range -> Bool
== :: Range -> Range -> Bool
$c/= :: Range -> Range -> Bool
/= :: Range -> Range -> Bool
Eq, Eq Range
Eq Range =>
(Range -> Range -> Ordering)
-> (Range -> Range -> Bool)
-> (Range -> Range -> Bool)
-> (Range -> Range -> Bool)
-> (Range -> Range -> Bool)
-> (Range -> Range -> Range)
-> (Range -> Range -> Range)
-> Ord Range
Range -> Range -> Bool
Range -> Range -> Ordering
Range -> Range -> Range
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Range -> Range -> Ordering
compare :: Range -> Range -> Ordering
$c< :: Range -> Range -> Bool
< :: Range -> Range -> Bool
$c<= :: Range -> Range -> Bool
<= :: Range -> Range -> Bool
$c> :: Range -> Range -> Bool
> :: Range -> Range -> Bool
$c>= :: Range -> Range -> Bool
>= :: Range -> Range -> Bool
$cmax :: Range -> Range -> Range
max :: Range -> Range -> Range
$cmin :: Range -> Range -> Range
min :: Range -> Range -> Range
Ord)

instance Condense Range where
  condense :: Range -> [Char]
condense (Range Int
from Int
to) = [Char]
"[" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Condense a => a -> [Char]
condense Int
from [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"," [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Condense a => a -> [Char]
condense Int
to [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"]"

data Aspect
  = Fork
  | Selection
  | Candidate PeerId
  | SlotNumber
  | TipPoint PeerId
  deriving (Aspect -> Aspect -> Bool
(Aspect -> Aspect -> Bool)
-> (Aspect -> Aspect -> Bool) -> Eq Aspect
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Aspect -> Aspect -> Bool
== :: Aspect -> Aspect -> Bool
$c/= :: Aspect -> Aspect -> Bool
/= :: Aspect -> Aspect -> Bool
Eq, Int -> Aspect -> [Char] -> [Char]
[Aspect] -> [Char] -> [Char]
Aspect -> [Char]
(Int -> Aspect -> [Char] -> [Char])
-> (Aspect -> [Char])
-> ([Aspect] -> [Char] -> [Char])
-> Show Aspect
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> Aspect -> [Char] -> [Char]
showsPrec :: Int -> Aspect -> [Char] -> [Char]
$cshow :: Aspect -> [Char]
show :: Aspect -> [Char]
$cshowList :: [Aspect] -> [Char] -> [Char]
showList :: [Aspect] -> [Char] -> [Char]
Show, Eq Aspect
Eq Aspect =>
(Aspect -> Aspect -> Ordering)
-> (Aspect -> Aspect -> Bool)
-> (Aspect -> Aspect -> Bool)
-> (Aspect -> Aspect -> Bool)
-> (Aspect -> Aspect -> Bool)
-> (Aspect -> Aspect -> Aspect)
-> (Aspect -> Aspect -> Aspect)
-> Ord Aspect
Aspect -> Aspect -> Bool
Aspect -> Aspect -> Ordering
Aspect -> Aspect -> Aspect
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Aspect -> Aspect -> Ordering
compare :: Aspect -> Aspect -> Ordering
$c< :: Aspect -> Aspect -> Bool
< :: Aspect -> Aspect -> Bool
$c<= :: Aspect -> Aspect -> Bool
<= :: Aspect -> Aspect -> Bool
$c> :: Aspect -> Aspect -> Bool
> :: Aspect -> Aspect -> Bool
$c>= :: Aspect -> Aspect -> Bool
>= :: Aspect -> Aspect -> Bool
$cmax :: Aspect -> Aspect -> Aspect
max :: Aspect -> Aspect -> Aspect
$cmin :: Aspect -> Aspect -> Aspect
min :: Aspect -> Aspect -> Aspect
Ord)

instance Condense Aspect where
  condense :: Aspect -> [Char]
condense = \case
    Aspect
Selection -> [Char]
"s"
    Candidate PeerId
_ -> [Char]
"c"
    Aspect
Fork -> [Char]
"f"
    Aspect
SlotNumber -> [Char]
"n"
    TipPoint PeerId
_ -> [Char]
"t"

data AspectEdge
  = EdgeLeft
  | EdgeRight
  | NoEdge
  deriving Int -> AspectEdge -> [Char] -> [Char]
[AspectEdge] -> [Char] -> [Char]
AspectEdge -> [Char]
(Int -> AspectEdge -> [Char] -> [Char])
-> (AspectEdge -> [Char])
-> ([AspectEdge] -> [Char] -> [Char])
-> Show AspectEdge
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> AspectEdge -> [Char] -> [Char]
showsPrec :: Int -> AspectEdge -> [Char] -> [Char]
$cshow :: AspectEdge -> [Char]
show :: AspectEdge -> [Char]
$cshowList :: [AspectEdge] -> [Char] -> [Char]
showList :: [AspectEdge] -> [Char] -> [Char]
Show

data SlotAspect
  = SlotAspect
  { SlotAspect -> Aspect
slotAspect :: Aspect
  , SlotAspect -> AspectEdge
edge :: AspectEdge
  }
  deriving Int -> SlotAspect -> [Char] -> [Char]
[SlotAspect] -> [Char] -> [Char]
SlotAspect -> [Char]
(Int -> SlotAspect -> [Char] -> [Char])
-> (SlotAspect -> [Char])
-> ([SlotAspect] -> [Char] -> [Char])
-> Show SlotAspect
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> SlotAspect -> [Char] -> [Char]
showsPrec :: Int -> SlotAspect -> [Char] -> [Char]
$cshow :: SlotAspect -> [Char]
show :: SlotAspect -> [Char]
$cshowList :: [SlotAspect] -> [Char] -> [Char]
showList :: [SlotAspect] -> [Char] -> [Char]
Show

data SlotCapacity
  = SlotOutside
  | SlotBlock Int
  | SlotEmpty
  deriving Int -> SlotCapacity -> [Char] -> [Char]
[SlotCapacity] -> [Char] -> [Char]
SlotCapacity -> [Char]
(Int -> SlotCapacity -> [Char] -> [Char])
-> (SlotCapacity -> [Char])
-> ([SlotCapacity] -> [Char] -> [Char])
-> Show SlotCapacity
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> SlotCapacity -> [Char] -> [Char]
showsPrec :: Int -> SlotCapacity -> [Char] -> [Char]
$cshow :: SlotCapacity -> [Char]
show :: SlotCapacity -> [Char]
$cshowList :: [SlotCapacity] -> [Char] -> [Char]
showList :: [SlotCapacity] -> [Char] -> [Char]
Show

instance Condense SlotCapacity where
  condense :: SlotCapacity -> [Char]
condense = \case
    SlotCapacity
SlotOutside -> [Char]
""
    SlotBlock Int
n -> [Char]
"-" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Condense a => a -> [Char]
condense Int
n
    SlotCapacity
SlotEmpty -> [Char]
""

data Slot
  = Slot
  { Slot -> WithOrigin Int
num :: WithOrigin Int
  , Slot -> SlotCapacity
capacity :: SlotCapacity
  , Slot -> [SlotAspect]
aspects :: [SlotAspect]
  }
  deriving Int -> Slot -> [Char] -> [Char]
[Slot] -> [Char] -> [Char]
Slot -> [Char]
(Int -> Slot -> [Char] -> [Char])
-> (Slot -> [Char]) -> ([Slot] -> [Char] -> [Char]) -> Show Slot
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> Slot -> [Char] -> [Char]
showsPrec :: Int -> Slot -> [Char] -> [Char]
$cshow :: Slot -> [Char]
show :: Slot -> [Char]
$cshowList :: [Slot] -> [Char] -> [Char]
showList :: [Slot] -> [Char] -> [Char]
Show

instance Condense Slot where
  condense :: Slot -> [Char]
condense Slot{WithOrigin Int
num :: Slot -> WithOrigin Int
num :: WithOrigin Int
num, SlotCapacity
capacity :: Slot -> SlotCapacity
capacity :: SlotCapacity
capacity} =
    [Char]
sn [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SlotCapacity -> [Char]
forall a. Condense a => a -> [Char]
condense SlotCapacity
capacity
   where
    sn :: [Char]
sn = case WithOrigin Int
num of
      WithOrigin Int
Origin -> [Char]
"G"
      At Int
n -> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n

----------------------------------------------------------------------------------------------------
-- Slots vectors
----------------------------------------------------------------------------------------------------

data BranchSlots blk
  = BranchSlots
  { forall blk. BranchSlots blk -> AnchoredFragment (Header blk)
frag :: AF.AnchoredFragment (Header blk)
  , forall blk. BranchSlots blk -> Vector Slot
slots :: Vector Slot
  , forall blk. BranchSlots blk -> [PeerId]
cands :: [PeerId]
  , forall blk. BranchSlots blk -> Word64
forkNo :: Word64
  }

deriving instance (Show (Header blk), StandardHash blk) => Show (BranchSlots blk)

addAspect :: Aspect -> Range -> Bool -> Vector Slot -> Vector Slot
addAspect :: Aspect -> Range -> Bool -> Vector Slot -> Vector Slot
addAspect Aspect
slotAspect (Range Int
l Int
u) Bool
overFork Vector Slot
slots =
  [Char] -> Vector Slot -> Vector Slot
forall a. [Char] -> a -> a
debugRender ((Int, Int, Aspect) -> [Char]
forall a. Show a => a -> [Char]
show (Int
l, Int
u, Aspect
slotAspect)) (Vector Slot -> Vector Slot) -> Vector Slot -> Vector Slot
forall a b. (a -> b) -> a -> b
$
    [Char] -> Vector Slot -> Vector Slot
forall a. [Char] -> a -> a
debugRender ([(Int, Slot)] -> [Char]
forall a. Condense a => a -> [Char]
condense (Vector (Int, Slot) -> [(Int, Slot)]
forall a. Vector a -> [a]
Vector.toList ((Int, Slot) -> (Int, Slot)
ins ((Int, Slot) -> (Int, Slot))
-> Vector (Int, Slot) -> Vector (Int, Slot)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector (Int, Slot)
sub))) (Vector Slot -> Vector Slot) -> Vector Slot -> Vector Slot
forall a b. (a -> b) -> a -> b
$
      Vector Slot -> Vector (Int, Slot) -> Vector Slot
forall a. Vector a -> Vector (Int, a) -> Vector a
Vector.update Vector Slot
slots ((Int, Slot) -> (Int, Slot)
ins ((Int, Slot) -> (Int, Slot))
-> Vector (Int, Slot) -> Vector (Int, Slot)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector (Int, Slot)
sub)
 where
  ins :: (Int, Slot) -> (Int, Slot)
ins (Int
i, Slot
slot) =
    (Int
i, Slot
slot{aspects = newAspect : aspects slot})
   where
    newAspect :: SlotAspect
newAspect = SlotAspect{Aspect
slotAspect :: Aspect
slotAspect :: Aspect
slotAspect, edge :: AspectEdge
edge = Int -> AspectEdge
mkEdge Int
i}

  mkEdge :: Int -> AspectEdge
mkEdge Int
i
    | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
l Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
overFork = AspectEdge
EdgeLeft
    | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
u = AspectEdge
EdgeRight
    | Bool
otherwise = AspectEdge
NoEdge

  sub :: Vector (Int, Slot)
sub = Int -> Int -> Vector (Int, Slot) -> Vector (Int, Slot)
forall a. Int -> Int -> Vector a -> Vector a
Vector.slice Int
l Int
count (Vector Slot -> Vector (Int, Slot)
forall a. Vector a -> Vector (Int, a)
Vector.indexed Vector Slot
slots)

  count :: Int
count = Int
u Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1

initSlots :: AF.HasHeader blk => Int -> Range -> AF.AnchoredFragment blk -> Vector Slot
initSlots :: forall blk.
HasHeader blk =>
Int -> Range -> AnchoredFragment blk -> Vector Slot
initSlots Int
lastSlot (Range Int
l Int
u) AnchoredFragment blk
blocks =
  [Slot] -> Vector Slot
forall a. [a] -> Vector a
Vector.fromList (([blk], [Slot]) -> [Slot]
forall a b. (a, b) -> b
snd (([blk] -> Int -> ([blk], Slot))
-> [blk] -> [Int] -> ([blk], [Slot])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL [blk] -> Int -> ([blk], Slot)
step (AnchoredFragment blk -> [blk]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst AnchoredFragment blk
blocks) [-Int
1 .. Int
lastSlot]))
 where
  step :: [blk] -> Int -> ([blk], Slot)
step [blk]
bs Int
cur
    | Int
cur Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -Int
1 =
        ([blk]
bs, Slot{num :: WithOrigin Int
num = WithOrigin Int
forall t. WithOrigin t
Origin, capacity :: SlotCapacity
capacity = SlotCapacity
SlotOutside, aspects :: [SlotAspect]
aspects = []})
    | blk
b : [blk]
rest <- [blk]
bs
    , Int
s <- SlotNo -> Int
slotInt (blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot blk
b)
    , Int
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
cur =
        ([blk]
rest, Int -> SlotCapacity -> Slot
mkSlot Int
cur (Int -> SlotCapacity
SlotBlock (BlockNo -> Int
blockInt (blk -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo blk
b))))
    | Int
cur Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Bool -> Bool -> Bool
&& Int
cur Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
u =
        ([blk]
bs, Int -> SlotCapacity -> Slot
mkSlot Int
cur SlotCapacity
SlotEmpty)
    | Bool
otherwise =
        ([blk]
bs, Int -> SlotCapacity -> Slot
mkSlot Int
cur SlotCapacity
SlotOutside)

  mkSlot :: Int -> SlotCapacity -> Slot
mkSlot Int
num SlotCapacity
capacity =
    Slot{num :: WithOrigin Int
num = Int -> WithOrigin Int
forall t. t -> WithOrigin t
At Int
num, SlotCapacity
capacity :: SlotCapacity
capacity :: SlotCapacity
capacity, aspects :: [SlotAspect]
aspects = []}

-- | Get the fork number of the 'BlockTreeBranch' a block is on. /Some/ fork
-- numbers are generated during the creation of the test 'BlockTree' in
-- 'Test.Consensus.Genesis.Setup.GenChains.genChainsWithExtraHonestPeers'.
-- There, for 'TestBlock's, these fork numbers are stored in the 'TestHash'
-- by the 'IssueTestBlock' operations.
-- Here, new fork numbers are created so that the pretty printing machinery
-- works independently of the block type; this poses no problem because the
-- exact fork numbers stored in 'TestBlock's are irrelevant as long as they
-- uniquely determine each 'BlockTreeBranch'.
--
-- POSTCONDITION: All blocks on the same branch suffix share fork number.
-- POSTCONDITION: Each 'BlockTreeBranch' has a distinct fork number.
hashForkNo :: AF.HasHeader blk => BlockTree blk -> HeaderHash blk -> Word64
hashForkNo :: forall blk.
HasHeader blk =>
BlockTree blk -> HeaderHash blk -> Word64
hashForkNo BlockTree blk
bt HeaderHash blk
hash =
  let forkFirstBlocks :: Map (ChainHash blk) Word64
forkFirstBlocks =
        -- A map assigning numbers to forked nodes. If any of these is in our
        -- ancestry, we are on a branch and have a fork number.
        [(ChainHash blk, Word64)] -> Map (ChainHash blk) Word64
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ChainHash blk, Word64)] -> Map (ChainHash blk) Word64)
-> [(ChainHash blk, Word64)] -> Map (ChainHash blk) Word64
forall a b. (a -> b) -> a -> b
$ do
          -- `btBranches` are not sorted in a meaningful way, so the fork
          -- numbers assigned here are meant only to distinguish them.
          (btb, ix) <- [BlockTreeBranch blk]
-> [Word64] -> [(BlockTreeBranch blk, Word64)]
forall a b. [a] -> [b] -> [(a, b)]
zip (BlockTree blk -> [BlockTreeBranch blk]
forall blk. BlockTree blk -> [BlockTreeBranch blk]
btBranches BlockTree blk
bt) [Word64
1 ..]
          -- The first block in a branch is the /last/ (i.e. leftmost or oldest) one.
          -- See the documentation of `Test.Util.TestBlock.TestHash`
          -- in relation to this order.
          let firstBlockHash = (Anchor blk -> ChainHash blk)
-> (blk -> ChainHash blk)
-> Either (Anchor blk) blk
-> ChainHash blk
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Anchor blk -> ChainHash blk
forall block. Anchor block -> ChainHash block
AF.anchorToHash (HeaderHash blk -> ChainHash blk
forall {k} (b :: k). HeaderHash b -> ChainHash b
BlockHash (HeaderHash blk -> ChainHash blk)
-> (blk -> HeaderHash blk) -> blk -> ChainHash blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash) (Either (Anchor blk) blk -> ChainHash blk)
-> (AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
    -> Either (Anchor blk) blk)
-> AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
-> ChainHash blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
-> Either (Anchor blk) blk
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Either a b
AF.last (AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk -> ChainHash blk)
-> AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
-> ChainHash blk
forall a b. (a -> b) -> a -> b
$ BlockTreeBranch blk
-> AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbSuffix BlockTreeBranch blk
btb
          pure $ (firstBlockHash, ix)
      blockAncestry :: [blk]
blockAncestry = (AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk -> [blk])
-> Maybe (AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk)
-> [blk]
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk -> [blk]
forall v a b. AnchoredSeq v a b -> [b]
AF.toNewestFirst (Maybe (AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk) -> [blk])
-> Maybe (AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk)
-> [blk]
forall a b. (a -> b) -> a -> b
$ HeaderHash blk
-> Map
     (HeaderHash blk) (AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk)
-> Maybe (AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup HeaderHash blk
hash (Map
   (HeaderHash blk) (AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk)
 -> Maybe (AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk))
-> Map
     (HeaderHash blk) (AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk)
-> Maybe (AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk)
forall a b. (a -> b) -> a -> b
$ BlockTree blk
-> Map
     (HeaderHash blk) (AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk)
forall blk. BlockTree blk -> DeforestedBlockTree blk
deforestBlockTree BlockTree blk
bt
   in -- Get the fork number of the most recent forked node in the ancestry.
      Word64 -> Maybe Word64 -> Word64
forall a. a -> Maybe a -> a
fromMaybe Word64
0 (Maybe Word64 -> Word64) -> Maybe Word64 -> Word64
forall a b. (a -> b) -> a -> b
$
        First Word64 -> Maybe Word64
forall a. First a -> Maybe a
getFirst (First Word64 -> Maybe Word64) -> First Word64 -> Maybe Word64
forall a b. (a -> b) -> a -> b
$
          ((blk -> First Word64) -> [blk] -> First Word64)
-> [blk] -> (blk -> First Word64) -> First Word64
forall a b c. (a -> b -> c) -> b -> a -> c
flip (blk -> First Word64) -> [blk] -> First Word64
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap [blk]
blockAncestry ((blk -> First Word64) -> First Word64)
-> (blk -> First Word64) -> First Word64
forall a b. (a -> b) -> a -> b
$
            \blk
blk ->
              Maybe Word64 -> First Word64
forall a. Maybe a -> First a
First (Maybe Word64 -> First Word64) -> Maybe Word64 -> First Word64
forall a b. (a -> b) -> a -> b
$
                let h :: ChainHash blk
h = HeaderHash blk -> ChainHash blk
forall {k} (b :: k). HeaderHash b -> ChainHash b
BlockHash (HeaderHash blk -> ChainHash blk)
-> HeaderHash blk -> ChainHash blk
forall a b. (a -> b) -> a -> b
$ blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash blk
blk
                 in ChainHash blk -> Map (ChainHash blk) Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ChainHash blk
h Map (ChainHash blk) Word64
forkFirstBlocks

blockForkNo :: AF.HasHeader blk => BlockTree blk -> ChainHash blk -> Word64
blockForkNo :: forall blk.
HasHeader blk =>
BlockTree blk -> ChainHash blk -> Word64
blockForkNo BlockTree blk
bt = \case
  BlockHash HeaderHash blk
h -> BlockTree blk -> HeaderHash blk -> Word64
forall blk.
HasHeader blk =>
BlockTree blk -> HeaderHash blk -> Word64
hashForkNo BlockTree blk
bt HeaderHash blk
h
  ChainHash blk
_ -> Word64
0

initBranch ::
  forall blk.
  (GetHeader blk, AF.HasHeader blk) =>
  BlockTree blk ->
  Int ->
  Range ->
  AF.AnchoredFragment blk ->
  BranchSlots blk
initBranch :: forall blk.
(GetHeader blk, HasHeader blk) =>
BlockTree blk
-> Int -> Range -> AnchoredFragment blk -> BranchSlots blk
initBranch BlockTree blk
bt Int
lastSlot Range
fragRange AnchoredFragment blk
fragment =
  BranchSlots
    { frag :: AnchoredFragment (Header blk)
frag = (blk -> Header blk)
-> AnchoredFragment blk -> AnchoredFragment (Header blk)
forall block2 block1.
(HasHeader block2, HeaderHash block1 ~ HeaderHash block2) =>
(block1 -> block2)
-> AnchoredFragment block1 -> AnchoredFragment block2
AF.mapAnchoredFragment blk -> Header blk
forall blk. GetHeader blk => blk -> Header blk
getHeader AnchoredFragment blk
fragment
    , slots :: Vector Slot
slots = Int -> Range -> AnchoredFragment blk -> Vector Slot
forall blk.
HasHeader blk =>
Int -> Range -> AnchoredFragment blk -> Vector Slot
initSlots Int
lastSlot Range
fragRange AnchoredFragment blk
fragment
    , cands :: [PeerId]
cands = []
    , forkNo :: Word64
forkNo = BlockTree blk -> ChainHash blk -> Word64
forall blk.
HasHeader blk =>
BlockTree blk -> ChainHash blk -> Word64
blockForkNo BlockTree blk
bt (AnchoredFragment blk -> ChainHash blk
forall block.
HasHeader block =>
AnchoredFragment block -> ChainHash block
AF.headHash AnchoredFragment blk
fragment)
    }

data TreeSlots blk
  = TreeSlots
  { forall blk. TreeSlots blk -> Int
lastSlot :: Int
  , forall blk. TreeSlots blk -> [BranchSlots blk]
branches :: [BranchSlots blk]
  }

deriving instance (StandardHash blk, Show (Header blk)) => Show (TreeSlots blk)

initTree :: (AF.HasHeader blk, GetHeader blk) => BlockTree blk -> TreeSlots blk
initTree :: forall blk.
(HasHeader blk, GetHeader blk) =>
BlockTree blk -> TreeSlots blk
initTree BlockTree blk
blockTree =
  TreeSlots{Int
lastSlot :: Int
lastSlot :: Int
lastSlot, branches :: [BranchSlots blk]
branches = BranchSlots blk
trunk BranchSlots blk -> [BranchSlots blk] -> [BranchSlots blk]
forall a. a -> [a] -> [a]
: [BranchSlots blk]
branches}
 where
  trunk :: BranchSlots blk
trunk = (Range, AnchoredFragment blk) -> BranchSlots blk
initFR (Range, AnchoredFragment blk)
trunkRange

  branches :: [BranchSlots blk]
branches = (Range, AnchoredFragment blk) -> BranchSlots blk
initFR ((Range, AnchoredFragment blk) -> BranchSlots blk)
-> [(Range, AnchoredFragment blk)] -> [BranchSlots blk]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Range, AnchoredFragment blk)]
branchRanges

  initFR :: (Range, AnchoredFragment blk) -> BranchSlots blk
initFR = (Range -> AnchoredFragment blk -> BranchSlots blk)
-> (Range, AnchoredFragment blk) -> BranchSlots blk
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (BlockTree blk
-> Int -> Range -> AnchoredFragment blk -> BranchSlots blk
forall blk.
(GetHeader blk, HasHeader blk) =>
BlockTree blk
-> Int -> Range -> AnchoredFragment blk -> BranchSlots blk
initBranch BlockTree blk
blockTree Int
lastSlot)

  lastSlot :: Int
lastSlot = ((Range, AnchoredFragment blk) -> Int -> Int)
-> Int -> [(Range, AnchoredFragment blk)] -> Int
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Int -> Int -> Int)
-> ((Range, AnchoredFragment blk) -> Int)
-> (Range, AnchoredFragment blk)
-> Int
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Range -> Int
to (Range -> Int)
-> ((Range, AnchoredFragment blk) -> Range)
-> (Range, AnchoredFragment blk)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Range, AnchoredFragment blk) -> Range
forall a b. (a, b) -> a
fst)) Int
0 ((Range, AnchoredFragment blk)
trunkRange (Range, AnchoredFragment blk)
-> [(Range, AnchoredFragment blk)]
-> [(Range, AnchoredFragment blk)]
forall a. a -> [a] -> [a]
: [(Range, AnchoredFragment blk)]
branchRanges)

  trunkRange :: (Range, AnchoredFragment blk)
trunkRange = AnchoredFragment blk -> (Range, AnchoredFragment blk)
forall {block}.
HasHeader block =>
AnchoredFragment block -> (Range, AnchoredFragment block)
withRange (BlockTree blk -> AnchoredFragment blk
forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk BlockTree blk
blockTree)

  branchRanges :: [(Range, AnchoredFragment blk)]
branchRanges = AnchoredFragment blk -> (Range, AnchoredFragment blk)
forall {block}.
HasHeader block =>
AnchoredFragment block -> (Range, AnchoredFragment block)
withRange (AnchoredFragment blk -> (Range, AnchoredFragment blk))
-> (BlockTreeBranch blk -> AnchoredFragment blk)
-> BlockTreeBranch blk
-> (Range, AnchoredFragment blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockTreeBranch blk -> AnchoredFragment blk
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbSuffix (BlockTreeBranch blk -> (Range, AnchoredFragment blk))
-> [BlockTreeBranch blk] -> [(Range, AnchoredFragment blk)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockTree blk -> [BlockTreeBranch blk]
forall blk. BlockTree blk -> [BlockTreeBranch blk]
btBranches BlockTree blk
blockTree

  withRange :: AnchoredFragment block -> (Range, AnchoredFragment block)
withRange AnchoredFragment block
f = (AnchoredFragment block -> Range
forall {block}. HasHeader block => AnchoredFragment block -> Range
mkRange AnchoredFragment block
f, AnchoredFragment block
f)

  mkRange :: AnchoredFragment block -> Range
mkRange AnchoredFragment block
f =
    Int -> Int -> Range
Range Int
l Int
u
   where
    l :: Int
l = Int -> (SlotNo -> Int) -> WithOrigin SlotNo -> Int
forall b t. b -> (t -> b) -> WithOrigin t -> b
withOrigin Int
0 SlotNo -> Int
slotInt (AnchoredFragment block -> WithOrigin SlotNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin SlotNo
AF.lastSlot AnchoredFragment block
f)
    u :: Int
u = Int -> (SlotNo -> Int) -> WithOrigin SlotNo -> Int
forall b t. b -> (t -> b) -> WithOrigin t -> b
withOrigin Int
0 SlotNo -> Int
slotInt (AnchoredFragment block -> WithOrigin SlotNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin SlotNo
AF.headSlot AnchoredFragment block
f)

commonRange ::
  (Eq (Header blk), AF.HasHeader (Header blk)) =>
  AF.AnchoredFragment (Header blk) ->
  AF.AnchoredFragment (Header blk) ->
  Maybe (Range, Bool)
commonRange :: forall blk.
(Eq (Header blk), HasHeader (Header blk)) =>
AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Maybe (Range, Bool)
commonRange AnchoredFragment (Header blk)
branch AnchoredFragment (Header blk)
segment = do
  (preB, preS, _, _) <- AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Maybe
     (AnchoredFragment (Header blk), AnchoredFragment (Header blk),
      AnchoredFragment (Header blk), AnchoredFragment (Header 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 AnchoredFragment (Header blk)
branch AnchoredFragment (Header blk)
segment
  lower <- findLower (AF.toNewestFirst preB) (AF.toNewestFirst preS)
  upper <- eitherToMaybe (AF.head preB)
  let
    aB = AnchoredFragment (Header blk) -> Anchor (Header blk)
forall v a b. AnchoredSeq v a b -> a
anchor AnchoredFragment (Header blk)
preB
    aS = AnchoredFragment (Header blk) -> Anchor (Header blk)
forall v a b. AnchoredSeq v a b -> a
anchor AnchoredFragment (Header blk)
preS
    asB = Anchor (Header blk) -> WithOrigin SlotNo
forall block. Anchor block -> WithOrigin SlotNo
anchorToSlotNo Anchor (Header blk)
aB
    asS = Anchor (Header blk) -> WithOrigin SlotNo
forall block. Anchor block -> WithOrigin SlotNo
anchorToSlotNo Anchor (Header blk)
aS
    l = Header blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header blk
lower
    u = Header blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header blk
upper
    overFork = WithOrigin SlotNo
asS WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< WithOrigin SlotNo
asB Bool -> Bool -> Bool
&& Anchor (Header blk)
aB Anchor (Header blk) -> Anchor (Header blk) -> Bool
forall a. Eq a => a -> a -> Bool
== AnchoredFragment (Header blk) -> Anchor (Header blk)
forall v a b. AnchoredSeq v a b -> a
anchor AnchoredFragment (Header blk)
branch
  guard (u >= l)
  pure (Range (slotInt l + (if overFork then 0 else 1)) (slotInt u + 1), overFork)
 where
  findLower :: [a] -> [a] -> Maybe a
findLower [a]
preB [a]
preS =
    (Maybe a -> (a, a) -> Maybe a) -> Maybe a -> [(a, a)] -> Maybe a
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl' Maybe a -> (a, a) -> Maybe a
forall {a}. Eq a => Maybe a -> (a, a) -> Maybe a
step Maybe a
forall a. Maybe a
Nothing ([a] -> [a] -> [(a, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
preB [a]
preS)
  step :: Maybe a -> (a, a) -> Maybe a
step Maybe a
prev (a
b1, a
b2)
    | a
b1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b2 = a -> Maybe a
forall a. a -> Maybe a
Just a
b1
    | Bool
otherwise = Maybe a
prev

addFragRange ::
  (Eq (Header blk), AF.HasHeader (Header blk)) =>
  Aspect ->
  AF.AnchoredFragment (Header blk) ->
  TreeSlots blk ->
  TreeSlots blk
addFragRange :: forall blk.
(Eq (Header blk), HasHeader (Header blk)) =>
Aspect
-> AnchoredFragment (Header blk) -> TreeSlots blk -> TreeSlots blk
addFragRange Aspect
aspect AnchoredFragment (Header blk)
selection TreeSlots{Int
lastSlot :: forall blk. TreeSlots blk -> Int
lastSlot :: Int
lastSlot, [BranchSlots blk]
branches :: forall blk. TreeSlots blk -> [BranchSlots blk]
branches :: [BranchSlots blk]
branches} =
  TreeSlots{Int
lastSlot :: Int
lastSlot :: Int
lastSlot, branches :: [BranchSlots blk]
branches = BranchSlots blk -> BranchSlots blk
forBranch (BranchSlots blk -> BranchSlots blk)
-> [BranchSlots blk] -> [BranchSlots blk]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BranchSlots blk]
branches}
 where
  forBranch :: BranchSlots blk -> BranchSlots blk
forBranch branch :: BranchSlots blk
branch@BranchSlots{AnchoredFragment (Header blk)
frag :: forall blk. BranchSlots blk -> AnchoredFragment (Header blk)
frag :: AnchoredFragment (Header blk)
frag, Vector Slot
slots :: forall blk. BranchSlots blk -> Vector Slot
slots :: Vector Slot
slots, [PeerId]
cands :: forall blk. BranchSlots blk -> [PeerId]
cands :: [PeerId]
cands} =
    case AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Maybe (Range, Bool)
forall blk.
(Eq (Header blk), HasHeader (Header blk)) =>
AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Maybe (Range, Bool)
commonRange AnchoredFragment (Header blk)
frag AnchoredFragment (Header blk)
selection of
      Just (Range
range, Bool
overFork) -> BranchSlots blk
branch{slots = addAspect aspect range overFork slots, cands = addCandidate cands}
      Maybe (Range, Bool)
_ -> BranchSlots blk
branch

  addCandidate :: [PeerId] -> [PeerId]
addCandidate [PeerId]
old
    | Candidate PeerId
peerId <- Aspect
aspect = PeerId
peerId PeerId -> [PeerId] -> [PeerId]
forall a. a -> [a] -> [a]
: [PeerId]
old
    | Bool
otherwise = [PeerId]
old

addCandidateRange ::
  (Eq (Header blk), AF.HasHeader (Header blk)) =>
  TreeSlots blk ->
  (PeerId, AF.AnchoredFragment (Header blk)) ->
  TreeSlots blk
addCandidateRange :: forall blk.
(Eq (Header blk), HasHeader (Header blk)) =>
TreeSlots blk
-> (PeerId, AnchoredFragment (Header blk)) -> TreeSlots blk
addCandidateRange TreeSlots blk
treeSlots (PeerId
pid, AnchoredFragment (Header blk)
candidate) =
  Aspect
-> AnchoredFragment (Header blk) -> TreeSlots blk -> TreeSlots blk
forall blk.
(Eq (Header blk), HasHeader (Header blk)) =>
Aspect
-> AnchoredFragment (Header blk) -> TreeSlots blk -> TreeSlots blk
addFragRange (PeerId -> Aspect
Candidate PeerId
pid) AnchoredFragment (Header blk)
candidate TreeSlots blk
treeSlots

updateSlot :: Int -> (Slot -> Slot) -> Vector Slot -> Vector Slot
updateSlot :: Int -> (Slot -> Slot) -> Vector Slot -> Vector Slot
updateSlot Int
i Slot -> Slot
f =
  (forall s. MVector s Slot -> ST s ()) -> Vector Slot -> Vector Slot
forall a.
(forall s. MVector s a -> ST s ()) -> Vector a -> Vector a
Vector.modify (\MVector s Slot
mv -> MVector (PrimState (ST s)) Slot -> (Slot -> Slot) -> Int -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> (a -> a) -> Int -> m ()
MV.modify MVector s Slot
MVector (PrimState (ST s)) Slot
mv Slot -> Slot
f Int
i)

addForks :: TreeSlots blk -> TreeSlots blk
addForks :: forall blk. TreeSlots blk -> TreeSlots blk
addForks treeSlots :: TreeSlots blk
treeSlots@TreeSlots{[BranchSlots blk]
branches :: forall blk. TreeSlots blk -> [BranchSlots blk]
branches :: [BranchSlots blk]
branches} =
  TreeSlots blk
treeSlots{branches = addFork <$> branches}
 where
  addFork :: BranchSlots blk -> BranchSlots blk
addFork fr :: BranchSlots blk
fr@BranchSlots{AnchoredFragment (Header blk)
frag :: forall blk. BranchSlots blk -> AnchoredFragment (Header blk)
frag :: AnchoredFragment (Header blk)
frag, Vector Slot
slots :: forall blk. BranchSlots blk -> Vector Slot
slots :: Vector Slot
slots, Word64
forkNo :: forall blk. BranchSlots blk -> Word64
forkNo :: Word64
forkNo}
    | Word64
forkNo Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0 =
        BranchSlots blk
fr
    | Bool
otherwise =
        BranchSlots blk
fr{slots = updateSlot s update slots}
   where
    update :: Slot -> Slot
update Slot
slot =
      Slot
slot
        { capacity = SlotEmpty
        , aspects = SlotAspect{slotAspect = Fork, edge = NoEdge} : aspects slot
        }
    s :: Int
s = SlotNo -> Int
slotInt (SlotNo -> (SlotNo -> SlotNo) -> WithOrigin SlotNo -> SlotNo
forall b t. b -> (t -> b) -> WithOrigin t -> b
withOrigin SlotNo
0 (SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
1) (Anchor (Header blk) -> WithOrigin SlotNo
forall block. Anchor block -> WithOrigin SlotNo
anchorToSlotNo (AnchoredFragment (Header blk) -> Anchor (Header blk)
forall v a b. AnchoredSeq v a b -> a
anchor AnchoredFragment (Header blk)
frag)))

addTipPoint ::
  forall blk.
  AF.HasHeader blk =>
  BlockTree blk ->
  PeerId ->
  WithOrigin blk ->
  TreeSlots blk ->
  TreeSlots blk
addTipPoint :: forall blk.
HasHeader blk =>
BlockTree blk
-> PeerId -> WithOrigin blk -> TreeSlots blk -> TreeSlots blk
addTipPoint BlockTree blk
bt PeerId
pid (NotOrigin blk
b) TreeSlots{Int
lastSlot :: forall blk. TreeSlots blk -> Int
lastSlot :: Int
lastSlot, [BranchSlots blk]
branches :: forall blk. TreeSlots blk -> [BranchSlots blk]
branches :: [BranchSlots blk]
branches} =
  TreeSlots{Int
lastSlot :: Int
lastSlot :: Int
lastSlot, branches :: [BranchSlots blk]
branches = BranchSlots blk -> BranchSlots blk
tryBranch (BranchSlots blk -> BranchSlots blk)
-> [BranchSlots blk] -> [BranchSlots blk]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BranchSlots blk]
branches}
 where
  tryBranch :: BranchSlots blk -> BranchSlots blk
tryBranch branch :: BranchSlots blk
branch@BranchSlots{Word64
forkNo :: forall blk. BranchSlots blk -> Word64
forkNo :: Word64
forkNo, Vector Slot
slots :: forall blk. BranchSlots blk -> Vector Slot
slots :: Vector Slot
slots}
    | Word64
tipForkNo Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
forkNo =
        BranchSlots blk
branch{slots = updateSlot (slotInt (blockSlot b + 1)) update slots}
    | Bool
otherwise =
        BranchSlots blk
branch
   where
    update :: Slot -> Slot
update Slot
slot =
      Slot
slot{aspects = SlotAspect{slotAspect = TipPoint pid, edge = NoEdge} : aspects slot}

  tipForkNo :: Word64
tipForkNo = BlockTree blk -> HeaderHash blk -> Word64
forall blk.
HasHeader blk =>
BlockTree blk -> HeaderHash blk -> Word64
hashForkNo BlockTree blk
bt (blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash blk
b)
addTipPoint BlockTree blk
_ PeerId
_ WithOrigin blk
_ TreeSlots blk
treeSlots = TreeSlots blk
treeSlots

addPoints ::
  AF.HasHeader blk => BlockTree blk -> Map PeerId (NodeState blk) -> TreeSlots blk -> TreeSlots blk
addPoints :: forall blk.
HasHeader blk =>
BlockTree blk
-> Map PeerId (NodeState blk) -> TreeSlots blk -> TreeSlots blk
addPoints BlockTree blk
bt Map PeerId (NodeState blk)
peerPoints TreeSlots blk
treeSlots =
  (TreeSlots blk -> (PeerId, NodeState blk) -> TreeSlots blk)
-> TreeSlots blk -> [(PeerId, NodeState blk)] -> TreeSlots blk
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl' TreeSlots blk -> (PeerId, NodeState blk) -> TreeSlots blk
step TreeSlots blk
treeSlots (Map PeerId (NodeState blk) -> [(PeerId, NodeState blk)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PeerId (NodeState blk)
peerPoints)
 where
  step :: TreeSlots blk -> (PeerId, NodeState blk) -> TreeSlots blk
step TreeSlots blk
z (PeerId
pid, NodeState blk
ap) = BlockTree blk
-> PeerId -> WithOrigin blk -> TreeSlots blk -> TreeSlots blk
forall blk.
HasHeader blk =>
BlockTree blk
-> PeerId -> WithOrigin blk -> TreeSlots blk -> TreeSlots blk
addTipPoint BlockTree blk
bt PeerId
pid (NodeState blk -> WithOrigin blk
forall blk. NodeState blk -> WithOrigin blk
nsTip NodeState blk
ap) TreeSlots blk
z

----------------------------------------------------------------------------------------------------
-- Cells
----------------------------------------------------------------------------------------------------

data CellSort
  = CellHere (NonEmpty Aspect)
  | CellOther
  deriving Int -> CellSort -> [Char] -> [Char]
[CellSort] -> [Char] -> [Char]
CellSort -> [Char]
(Int -> CellSort -> [Char] -> [Char])
-> (CellSort -> [Char])
-> ([CellSort] -> [Char] -> [Char])
-> Show CellSort
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> CellSort -> [Char] -> [Char]
showsPrec :: Int -> CellSort -> [Char] -> [Char]
$cshow :: CellSort -> [Char]
show :: CellSort -> [Char]
$cshowList :: [CellSort] -> [Char] -> [Char]
showList :: [CellSort] -> [Char] -> [Char]
Show

instance Condense CellSort where
  condense :: CellSort -> [Char]
condense = \case
    CellHere NonEmpty Aspect
a -> [Char]
"h" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Aspect] -> [Char]
forall a. Condense a => a -> [Char]
condense (NonEmpty Aspect -> [Item (NonEmpty Aspect)]
forall l. IsList l => l -> [Item l]
toList NonEmpty Aspect
a)
    CellSort
CellOther -> [Char]
"o"

data FragCell
  = FragCell
  { FragCell -> Maybe [Char]
fcLabel :: Maybe String
  , FragCell -> CellSort
fcSort :: CellSort
  , FragCell -> [Aspect]
fcLineAspects :: [Aspect]
  }
  deriving Int -> FragCell -> [Char] -> [Char]
[FragCell] -> [Char] -> [Char]
FragCell -> [Char]
(Int -> FragCell -> [Char] -> [Char])
-> (FragCell -> [Char])
-> ([FragCell] -> [Char] -> [Char])
-> Show FragCell
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> FragCell -> [Char] -> [Char]
showsPrec :: Int -> FragCell -> [Char] -> [Char]
$cshow :: FragCell -> [Char]
show :: FragCell -> [Char]
$cshowList :: [FragCell] -> [Char] -> [Char]
showList :: [FragCell] -> [Char] -> [Char]
Show

instance Condense FragCell where
  condense :: FragCell -> [Char]
condense (FragCell Maybe [Char]
l CellSort
s [Aspect]
a) =
    [Char]
lb [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CellSort -> [Char]
forall a. Condense a => a -> [Char]
condense CellSort
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Aspect] -> [Char]
forall a. Condense a => a -> [Char]
condense [Aspect]
a
   where
    lb :: [Char]
lb = case Maybe [Char]
l of
      Just [Char]
x -> [Char]
x
      Maybe [Char]
Nothing -> [Char]
"-"

data Cell
  = Cell FragCell
  | CellEmpty
  | CellSlotNo (WithOrigin Int)
  | CellPeers [PeerId]
  deriving Int -> Cell -> [Char] -> [Char]
[Cell] -> [Char] -> [Char]
Cell -> [Char]
(Int -> Cell -> [Char] -> [Char])
-> (Cell -> [Char]) -> ([Cell] -> [Char] -> [Char]) -> Show Cell
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> Cell -> [Char] -> [Char]
showsPrec :: Int -> Cell -> [Char] -> [Char]
$cshow :: Cell -> [Char]
show :: Cell -> [Char]
$cshowList :: [Cell] -> [Char] -> [Char]
showList :: [Cell] -> [Char] -> [Char]
Show

instance Condense Cell where
  condense :: Cell -> [Char]
condense = \case
    Cell FragCell
c -> FragCell -> [Char]
forall a. Condense a => a -> [Char]
condense FragCell
c
    Cell
CellEmpty -> [Char]
"E"
    CellSlotNo WithOrigin Int
n -> [Char]
"S" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ WithOrigin Int -> [Char]
forall a. Show a => a -> [Char]
show WithOrigin Int
n
    CellPeers [PeerId]
_ -> [Char]
"L"

mainAspects :: [SlotAspect] -> Maybe (NonEmpty Aspect)
mainAspects :: [SlotAspect] -> Maybe (NonEmpty Aspect)
mainAspects =
  [Aspect] -> Maybe (NonEmpty Aspect)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([Aspect] -> Maybe (NonEmpty Aspect))
-> ([SlotAspect] -> [Aspect])
-> [SlotAspect]
-> Maybe (NonEmpty Aspect)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Aspect] -> [Aspect]
forall a. Ord a => [a] -> [a]
sort ([Aspect] -> [Aspect])
-> ([SlotAspect] -> [Aspect]) -> [SlotAspect] -> [Aspect]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SlotAspect -> Aspect) -> [SlotAspect] -> [Aspect]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SlotAspect -> Aspect
slotAspect

lineAspects :: [SlotAspect] -> [Aspect]
lineAspects :: [SlotAspect] -> [Aspect]
lineAspects =
  [Aspect] -> [Aspect]
forall a. Ord a => [a] -> [a]
sort ([Aspect] -> [Aspect])
-> ([SlotAspect] -> [Aspect]) -> [SlotAspect] -> [Aspect]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SlotAspect -> Maybe Aspect) -> [SlotAspect] -> [Aspect]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe SlotAspect -> Maybe Aspect
check
 where
  check :: SlotAspect -> Maybe Aspect
check SlotAspect{AspectEdge
edge :: SlotAspect -> AspectEdge
edge :: AspectEdge
edge, Aspect
slotAspect :: SlotAspect -> Aspect
slotAspect :: Aspect
slotAspect}
    | AspectEdge
EdgeLeft <- AspectEdge
edge =
        Maybe Aspect
forall a. Maybe a
Nothing
    | Bool
otherwise =
        Aspect -> Maybe Aspect
forall a. a -> Maybe a
Just Aspect
slotAspect

prependList :: [a] -> NonEmpty a -> NonEmpty a
prependList :: forall a. [a] -> NonEmpty a -> NonEmpty a
prependList = \case
  [] -> NonEmpty a -> NonEmpty a
forall a. a -> a
id
  a
h : [a]
t -> ((a
h a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
t) NonEmpty a -> NonEmpty a -> NonEmpty a
forall a. Semigroup a => a -> a -> a
<>)

branchCells :: BranchSlots blk -> NonEmpty Cell
branchCells :: forall blk. BranchSlots blk -> NonEmpty Cell
branchCells BranchSlots{[PeerId]
cands :: forall blk. BranchSlots blk -> [PeerId]
cands :: [PeerId]
cands, Vector Slot
slots :: forall blk. BranchSlots blk -> Vector Slot
slots :: Vector Slot
slots} =
  [Cell] -> NonEmpty Cell -> NonEmpty Cell
forall a. [a] -> NonEmpty a -> NonEmpty a
prependList (Slot -> Cell
fragCell (Slot -> Cell) -> [Slot] -> [Cell]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector Slot -> [Slot]
forall a. Vector a -> [a]
Vector.toList Vector Slot
slots) (Cell -> NonEmpty Cell
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Cell
peers)
 where
  fragCell :: Slot -> Cell
fragCell Slot{SlotCapacity
capacity :: Slot -> SlotCapacity
capacity :: SlotCapacity
capacity, [SlotAspect]
aspects :: Slot -> [SlotAspect]
aspects :: [SlotAspect]
aspects}
    | SlotCapacity
SlotOutside <- SlotCapacity
capacity =
        Cell
CellEmpty
    | Bool
otherwise
    , CellSort
cellSort <- CellSort
-> (NonEmpty Aspect -> CellSort)
-> Maybe (NonEmpty Aspect)
-> CellSort
forall b a. b -> (a -> b) -> Maybe a -> b
maybe CellSort
CellOther NonEmpty Aspect -> CellSort
CellHere ([SlotAspect] -> Maybe (NonEmpty Aspect)
mainAspects [SlotAspect]
aspects) =
        FragCell -> Cell
Cell (Maybe [Char] -> CellSort -> [Aspect] -> FragCell
FragCell (SlotCapacity -> Maybe [Char]
content SlotCapacity
capacity) CellSort
cellSort ([SlotAspect] -> [Aspect]
lineAspects [SlotAspect]
aspects))

  content :: SlotCapacity -> Maybe [Char]
content = \case
    SlotBlock Int
num -> [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
num)
    SlotCapacity
_ -> Maybe [Char]
forall a. Maybe a
Nothing

  peers :: Cell
peers = [PeerId] -> Cell
CellPeers [PeerId]
cands

slotNoCells :: Int -> NonEmpty Cell
slotNoCells :: Int -> NonEmpty Cell
slotNoCells Int
lastSlot =
  WithOrigin Int -> Cell
CellSlotNo WithOrigin Int
forall t. WithOrigin t
Origin Cell -> [Cell] -> NonEmpty Cell
forall a. a -> [a] -> NonEmpty a
:| (WithOrigin Int -> Cell
CellSlotNo (WithOrigin Int -> Cell) -> (Int -> WithOrigin Int) -> Int -> Cell
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> WithOrigin Int
forall t. t -> WithOrigin t
At (Int -> Cell) -> [Int] -> [Cell]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
0 .. Int
lastSlot]) [Cell] -> [Cell] -> [Cell]
forall a. [a] -> [a] -> [a]
++ [Cell
CellEmpty]

treeCells :: TreeSlots blk -> NonEmpty (NonEmpty Cell)
treeCells :: forall blk. TreeSlots blk -> NonEmpty (NonEmpty Cell)
treeCells TreeSlots{Int
lastSlot :: forall blk. TreeSlots blk -> Int
lastSlot :: Int
lastSlot, [BranchSlots blk]
branches :: forall blk. TreeSlots blk -> [BranchSlots blk]
branches :: [BranchSlots blk]
branches} =
  Int -> NonEmpty Cell
slotNoCells Int
lastSlot NonEmpty Cell -> [NonEmpty Cell] -> NonEmpty (NonEmpty Cell)
forall a. a -> [a] -> NonEmpty a
:| (BranchSlots blk -> NonEmpty Cell
forall blk. BranchSlots blk -> NonEmpty Cell
branchCells (BranchSlots blk -> NonEmpty Cell)
-> [BranchSlots blk] -> [NonEmpty Cell]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BranchSlots blk]
branches)

----------------------------------------------------------------------------------------------------
-- Render cells
----------------------------------------------------------------------------------------------------

newtype SlotWidth
  = SlotWidth Int
  deriving (SlotWidth -> SlotWidth -> Bool
(SlotWidth -> SlotWidth -> Bool)
-> (SlotWidth -> SlotWidth -> Bool) -> Eq SlotWidth
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SlotWidth -> SlotWidth -> Bool
== :: SlotWidth -> SlotWidth -> Bool
$c/= :: SlotWidth -> SlotWidth -> Bool
/= :: SlotWidth -> SlotWidth -> Bool
Eq, Int -> SlotWidth -> [Char] -> [Char]
[SlotWidth] -> [Char] -> [Char]
SlotWidth -> [Char]
(Int -> SlotWidth -> [Char] -> [Char])
-> (SlotWidth -> [Char])
-> ([SlotWidth] -> [Char] -> [Char])
-> Show SlotWidth
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> SlotWidth -> [Char] -> [Char]
showsPrec :: Int -> SlotWidth -> [Char] -> [Char]
$cshow :: SlotWidth -> [Char]
show :: SlotWidth -> [Char]
$cshowList :: [SlotWidth] -> [Char] -> [Char]
showList :: [SlotWidth] -> [Char] -> [Char]
Show, Eq SlotWidth
Eq SlotWidth =>
(SlotWidth -> SlotWidth -> Ordering)
-> (SlotWidth -> SlotWidth -> Bool)
-> (SlotWidth -> SlotWidth -> Bool)
-> (SlotWidth -> SlotWidth -> Bool)
-> (SlotWidth -> SlotWidth -> Bool)
-> (SlotWidth -> SlotWidth -> SlotWidth)
-> (SlotWidth -> SlotWidth -> SlotWidth)
-> Ord SlotWidth
SlotWidth -> SlotWidth -> Bool
SlotWidth -> SlotWidth -> Ordering
SlotWidth -> SlotWidth -> SlotWidth
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SlotWidth -> SlotWidth -> Ordering
compare :: SlotWidth -> SlotWidth -> Ordering
$c< :: SlotWidth -> SlotWidth -> Bool
< :: SlotWidth -> SlotWidth -> Bool
$c<= :: SlotWidth -> SlotWidth -> Bool
<= :: SlotWidth -> SlotWidth -> Bool
$c> :: SlotWidth -> SlotWidth -> Bool
> :: SlotWidth -> SlotWidth -> Bool
$c>= :: SlotWidth -> SlotWidth -> Bool
>= :: SlotWidth -> SlotWidth -> Bool
$cmax :: SlotWidth -> SlotWidth -> SlotWidth
max :: SlotWidth -> SlotWidth -> SlotWidth
$cmin :: SlotWidth -> SlotWidth -> SlotWidth
min :: SlotWidth -> SlotWidth -> SlotWidth
Ord, Integer -> SlotWidth
SlotWidth -> SlotWidth
SlotWidth -> SlotWidth -> SlotWidth
(SlotWidth -> SlotWidth -> SlotWidth)
-> (SlotWidth -> SlotWidth -> SlotWidth)
-> (SlotWidth -> SlotWidth -> SlotWidth)
-> (SlotWidth -> SlotWidth)
-> (SlotWidth -> SlotWidth)
-> (SlotWidth -> SlotWidth)
-> (Integer -> SlotWidth)
-> Num SlotWidth
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: SlotWidth -> SlotWidth -> SlotWidth
+ :: SlotWidth -> SlotWidth -> SlotWidth
$c- :: SlotWidth -> SlotWidth -> SlotWidth
- :: SlotWidth -> SlotWidth -> SlotWidth
$c* :: SlotWidth -> SlotWidth -> SlotWidth
* :: SlotWidth -> SlotWidth -> SlotWidth
$cnegate :: SlotWidth -> SlotWidth
negate :: SlotWidth -> SlotWidth
$cabs :: SlotWidth -> SlotWidth
abs :: SlotWidth -> SlotWidth
$csignum :: SlotWidth -> SlotWidth
signum :: SlotWidth -> SlotWidth
$cfromInteger :: Integer -> SlotWidth
fromInteger :: Integer -> SlotWidth
Num)

data RenderSlot
  = SlotEllipsis Int
  | RenderSlot Int SlotWidth (NonEmpty Cell)
  deriving Int -> RenderSlot -> [Char] -> [Char]
[RenderSlot] -> [Char] -> [Char]
RenderSlot -> [Char]
(Int -> RenderSlot -> [Char] -> [Char])
-> (RenderSlot -> [Char])
-> ([RenderSlot] -> [Char] -> [Char])
-> Show RenderSlot
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> RenderSlot -> [Char] -> [Char]
showsPrec :: Int -> RenderSlot -> [Char] -> [Char]
$cshow :: RenderSlot -> [Char]
show :: RenderSlot -> [Char]
$cshowList :: [RenderSlot] -> [Char] -> [Char]
showList :: [RenderSlot] -> [Char] -> [Char]
Show

data RenderCell
  = CellEllipsis
  | RenderCell SlotWidth Cell
  deriving Int -> RenderCell -> [Char] -> [Char]
[RenderCell] -> [Char] -> [Char]
RenderCell -> [Char]
(Int -> RenderCell -> [Char] -> [Char])
-> (RenderCell -> [Char])
-> ([RenderCell] -> [Char] -> [Char])
-> Show RenderCell
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> RenderCell -> [Char] -> [Char]
showsPrec :: Int -> RenderCell -> [Char] -> [Char]
$cshow :: RenderCell -> [Char]
show :: RenderCell -> [Char]
$cshowList :: [RenderCell] -> [Char] -> [Char]
showList :: [RenderCell] -> [Char] -> [Char]
Show

instance Condense RenderCell where
  condense :: RenderCell -> [Char]
condense = \case
    RenderCell
CellEllipsis -> [Char]
" .. "
    RenderCell SlotWidth
_ Cell
cell -> Cell -> [Char]
forall a. Condense a => a -> [Char]
condense Cell
cell

slotWidth :: NonEmpty Cell -> SlotWidth
slotWidth :: NonEmpty Cell -> SlotWidth
slotWidth =
  NonEmpty SlotWidth -> SlotWidth
forall a. Ord a => NonEmpty a -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (NonEmpty SlotWidth -> SlotWidth)
-> (NonEmpty Cell -> NonEmpty SlotWidth)
-> NonEmpty Cell
-> SlotWidth
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cell -> SlotWidth) -> NonEmpty Cell -> NonEmpty SlotWidth
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Cell -> SlotWidth
cellWidth
 where
  cellWidth :: Cell -> SlotWidth
cellWidth = \case
    Cell FragCell{fcLabel :: FragCell -> Maybe [Char]
fcLabel = Just [Char]
label, CellSort
fcSort :: FragCell -> CellSort
fcSort :: CellSort
fcSort} -> Int -> SlotWidth
SlotWidth ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
label) SlotWidth -> SlotWidth -> SlotWidth
forall a. Num a => a -> a -> a
+ CellSort -> SlotWidth
sortWidth CellSort
fcSort
    CellPeers [PeerId]
peerIds -> Int -> SlotWidth
SlotWidth ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (PeerId -> Int
forall {a}. Show a => a -> Int
labelWidth (PeerId -> Int) -> [PeerId] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PeerId]
peerIds))
    Cell
_ -> SlotWidth
1

  labelWidth :: a -> Int
labelWidth a
pid = Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (a -> [Char]
forall a. Show a => a -> [Char]
show a
pid)

  sortWidth :: CellSort -> SlotWidth
sortWidth = \case
    CellHere NonEmpty Aspect
as -> NonEmpty SlotWidth -> SlotWidth
forall a. Num a => NonEmpty a -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (Aspect -> SlotWidth
pointWidth (Aspect -> SlotWidth) -> NonEmpty Aspect -> NonEmpty SlotWidth
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty Aspect
as)
    CellSort
_ -> SlotWidth
0

  pointWidth :: Aspect -> SlotWidth
pointWidth = \case
    TipPoint PeerId
_ -> SlotWidth
1
    Aspect
_ -> SlotWidth
0

contiguous :: [(Int, Bool, a)] -> [[(Int, a)]]
contiguous :: forall a. [(Int, Bool, a)] -> [[(Int, a)]]
contiguous ((Int
i0, Bool
_, a
a0) : [(Int, Bool, a)]
rest) =
  (NonEmpty (Int, a), [[Item (NonEmpty (Int, a))]])
-> [[Item (NonEmpty (Int, a))]]
forall {l}. IsList l => (l, [[Item l]]) -> [[Item l]]
result (((NonEmpty (Int, a), [[(Int, a)]])
 -> (Int, Bool, a) -> (NonEmpty (Int, a), [[(Int, a)]]))
-> (NonEmpty (Int, a), [[(Int, a)]])
-> [(Int, Bool, a)]
-> (NonEmpty (Int, a), [[(Int, a)]])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl' (NonEmpty (Int, a), [[(Int, a)]])
-> (Int, Bool, a) -> (NonEmpty (Int, a), [[(Int, a)]])
forall {a} {b}.
(Eq a, Num a) =>
(NonEmpty (a, b), [[(a, b)]])
-> (a, Bool, b) -> (NonEmpty (a, b), [[(a, b)]])
step ((Int, a) -> NonEmpty (Int, a)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
i0, a
a0), []) [(Int, Bool, a)]
rest)
 where
  result :: (l, [[Item l]]) -> [[Item l]]
result (l
cur, [[Item l]]
res) = [[Item l]] -> [[Item l]]
forall a. [a] -> [a]
reverse ([Item l] -> [Item l]
forall a. [a] -> [a]
reverse (l -> [Item l]
forall l. IsList l => l -> [Item l]
toList l
cur) [Item l] -> [[Item l]] -> [[Item l]]
forall a. a -> [a] -> [a]
: [[Item l]]
res)

  step :: (NonEmpty (a, b), [[(a, b)]])
-> (a, Bool, b) -> (NonEmpty (a, b), [[(a, b)]])
step (cur :: NonEmpty (a, b)
cur@((a
prev, b
_) :| [(a, b)]
_), [[(a, b)]]
res) (a
i, Bool
force, b
a)
    | a
i a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
prev a -> a -> a
forall a. Num a => a -> a -> a
+ a
1 Bool -> Bool -> Bool
|| Bool
force =
        ((a
i, b
a) (a, b) -> NonEmpty (a, b) -> NonEmpty (a, b)
forall a. a -> NonEmpty a -> NonEmpty a
<| NonEmpty (a, b)
cur, [[(a, b)]]
res)
    | Bool
otherwise =
        ((a, b) -> NonEmpty (a, b)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
i, b
a), [(a, b)] -> [(a, b)]
forall a. [a] -> [a]
reverse (NonEmpty (a, b) -> [Item (NonEmpty (a, b))]
forall l. IsList l => l -> [Item l]
toList NonEmpty (a, b)
cur) [(a, b)] -> [[(a, b)]] -> [[(a, b)]]
forall a. a -> [a] -> [a]
: [[(a, b)]]
res)
contiguous [] = []

cellSlots :: Int -> [(Int, Bool, NonEmpty Cell)] -> [RenderSlot]
cellSlots :: Int -> [(Int, Bool, NonEmpty Cell)] -> [RenderSlot]
cellSlots Int
branches =
  [[RenderSlot]] -> [RenderSlot]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[RenderSlot]] -> [RenderSlot])
-> ([(Int, Bool, NonEmpty Cell)] -> [[RenderSlot]])
-> [(Int, Bool, NonEmpty Cell)]
-> [RenderSlot]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RenderSlot] -> [[RenderSlot]] -> [[RenderSlot]]
forall a. a -> [a] -> [a]
intersperse [Int -> RenderSlot
SlotEllipsis Int
branches] ([[RenderSlot]] -> [[RenderSlot]])
-> ([(Int, Bool, NonEmpty Cell)] -> [[RenderSlot]])
-> [(Int, Bool, NonEmpty Cell)]
-> [[RenderSlot]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Int, NonEmpty Cell)] -> [RenderSlot])
-> [[(Int, NonEmpty Cell)]] -> [[RenderSlot]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Int, NonEmpty Cell) -> RenderSlot)
-> [(Int, NonEmpty Cell)] -> [RenderSlot]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int -> NonEmpty Cell -> RenderSlot)
-> (Int, NonEmpty Cell) -> RenderSlot
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> NonEmpty Cell -> RenderSlot
withMaxSize)) ([[(Int, NonEmpty Cell)]] -> [[RenderSlot]])
-> ([(Int, Bool, NonEmpty Cell)] -> [[(Int, NonEmpty Cell)]])
-> [(Int, Bool, NonEmpty Cell)]
-> [[RenderSlot]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, Bool, NonEmpty Cell)] -> [[(Int, NonEmpty Cell)]]
forall a. [(Int, Bool, a)] -> [[(Int, a)]]
contiguous
 where
  withMaxSize :: Int -> NonEmpty Cell -> RenderSlot
withMaxSize Int
slot NonEmpty Cell
cells = Int -> SlotWidth -> NonEmpty Cell -> RenderSlot
RenderSlot Int
slot (NonEmpty Cell -> SlotWidth
slotWidth NonEmpty Cell
cells) NonEmpty Cell
cells

pruneCells :: NonEmpty (NonEmpty Cell) -> [RenderSlot]
pruneCells :: NonEmpty (NonEmpty Cell) -> [RenderSlot]
pruneCells NonEmpty (NonEmpty Cell)
branches =
  -- debugRender (unlines (condense <$> branches)) $
  Int -> [(Int, Bool, NonEmpty Cell)] -> [RenderSlot]
cellSlots
    (NonEmpty (NonEmpty Cell) -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty (NonEmpty Cell)
branches)
    (((WithOrigin Int, NonEmpty Cell)
 -> Maybe (Int, Bool, NonEmpty Cell))
-> [(WithOrigin Int, NonEmpty Cell)]
-> [(Int, Bool, NonEmpty Cell)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (WithOrigin Int, NonEmpty Cell) -> Maybe (Int, Bool, NonEmpty Cell)
cellSlot ([WithOrigin Int]
-> [NonEmpty Cell] -> [(WithOrigin Int, NonEmpty Cell)]
forall a b. [a] -> [b] -> [(a, b)]
zip [WithOrigin Int]
slotRange (NonEmpty (NonEmpty Cell) -> [NonEmpty Cell]
forall a. NonEmpty a -> [a]
NonEmpty.toList (NonEmpty (NonEmpty Cell) -> NonEmpty (NonEmpty Cell)
forall a. NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a)
NonEmpty.transpose NonEmpty (NonEmpty Cell)
branches))))
 where
  cellSlot :: (WithOrigin Int, NonEmpty Cell) -> Maybe (Int, Bool, NonEmpty Cell)
  cellSlot :: (WithOrigin Int, NonEmpty Cell) -> Maybe (Int, Bool, NonEmpty Cell)
cellSlot (WithOrigin Int
num, NonEmpty Cell
frags)
    | let noEll :: Bool
noEll = (Cell -> Bool) -> NonEmpty Cell -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Cell -> Bool
forceNoEllipsis NonEmpty Cell
frags
    , Bool
noEll Bool -> Bool -> Bool
|| (Cell -> Bool) -> NonEmpty Cell -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Cell -> Bool
essential NonEmpty Cell
frags =
        WithOrigin Int
-> Bool -> NonEmpty Cell -> Maybe (Int, Bool, NonEmpty Cell)
forall {a} {b} {c}.
Num a =>
WithOrigin a -> b -> c -> Maybe (a, b, c)
keep WithOrigin Int
num Bool
noEll NonEmpty Cell
frags
    | Bool
otherwise =
        Maybe (Int, Bool, NonEmpty Cell)
forall a. Maybe a
Nothing

  keep :: WithOrigin a -> b -> c -> Maybe (a, b, c)
keep WithOrigin a
num b
noEll c
frags = (a, b, c) -> Maybe (a, b, c)
forall a. a -> Maybe a
Just (a -> WithOrigin a -> a
forall t. t -> WithOrigin t -> t
fromWithOrigin (-a
1) WithOrigin a
num, b
noEll, c
frags)

  essential :: Cell -> Bool
essential = \case
    Cell FragCell{fcSort :: FragCell -> CellSort
fcSort = CellHere NonEmpty Aspect
_} -> Bool
True
    Cell
_ -> Bool
False

  forceNoEllipsis :: Cell -> Bool
forceNoEllipsis = \case
    CellPeers [PeerId]
_ -> Bool
True
    Cell
_ -> Bool
False

  slotRange :: [WithOrigin Int]
slotRange = WithOrigin Int
forall t. WithOrigin t
Origin WithOrigin Int -> [WithOrigin Int] -> [WithOrigin Int]
forall a. a -> [a] -> [a]
: (Int -> WithOrigin Int
forall t. t -> WithOrigin t
At (Int -> WithOrigin Int) -> [Int] -> [WithOrigin Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
0 ..])

----------------------------------------------------------------------------------------------------
-- Render
----------------------------------------------------------------------------------------------------

data RenderConfig
  = RenderConfig
  { RenderConfig -> Int
lineWidth :: Int
  , RenderConfig -> [Char]
ellipsis :: String
  , RenderConfig -> Int
slotDistance :: Int
  , RenderConfig -> Char
boringChar :: Char
  , RenderConfig -> Char
candidateChar :: Char
  , RenderConfig -> Char
selectionChar :: Char
  , RenderConfig -> Char
forkChar :: Char
  , RenderConfig -> [Word64]
candidateColors :: [Word64]
  , RenderConfig -> Map PeerId Word64
cachedPeers :: Map PeerId Word64
  , RenderConfig -> Maybe Word64
selectionColor :: Maybe Word64
  , RenderConfig -> Word64
slotNumberColor :: Word64
  }

padCell :: RenderConfig -> Char -> SlotWidth -> String -> String
padCell :: RenderConfig -> Char -> SlotWidth -> [Char] -> [Char]
padCell RenderConfig{Int
slotDistance :: RenderConfig -> Int
slotDistance :: Int
slotDistance} Char
padChar (SlotWidth Int
w) [Char]
s
  | Int
pad Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = [Char]
s
  | Bool
otherwise = Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate Int
pad Char
padChar [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s
 where
  pad :: Int
pad = Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
slotDistance

lineChar :: RenderConfig -> [Aspect] -> Char
lineChar :: RenderConfig -> [Aspect] -> Char
lineChar RenderConfig
config [Aspect]
aspects
  | Aspect -> [Aspect] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Aspect
Selection [Aspect]
aspects =
      RenderConfig -> Char
selectionChar RenderConfig
config
  | (Aspect -> Bool) -> [Aspect] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Aspect -> Bool
isCandidate [Aspect]
aspects =
      RenderConfig -> Char
candidateChar RenderConfig
config
  | Bool
otherwise =
      RenderConfig -> Char
boringChar RenderConfig
config
 where
  isCandidate :: Aspect -> Bool
isCandidate = \case
    Candidate PeerId
_ -> Bool
True
    Aspect
_ -> Bool
False

colorAspects :: [Aspect] -> [Aspect]
colorAspects :: [Aspect] -> [Aspect]
colorAspects =
  (Aspect -> Bool) -> [Aspect] -> [Aspect]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Aspect -> Bool) -> [Aspect] -> [Aspect])
-> (Aspect -> Bool) -> [Aspect] -> [Aspect]
forall a b. (a -> b) -> a -> b
$ \case
    Aspect
Fork -> Bool
False
    Aspect
Selection -> Bool
False
    TipPoint PeerId
_ -> Bool
False
    Aspect
_ -> Bool
True

renderLine :: RenderConfig -> SlotWidth -> [Aspect] -> Int -> Col
renderLine :: RenderConfig -> SlotWidth -> [Aspect] -> Int -> Col
renderLine config :: RenderConfig
config@RenderConfig{Int
slotDistance :: RenderConfig -> Int
slotDistance :: Int
slotDistance, Char
forkChar :: RenderConfig -> Char
forkChar :: Char
forkChar} (SlotWidth Int
width) [Aspect]
aspects Int
labelWidth =
  case [Aspect] -> [Aspect]
colorAspects [Aspect]
aspects of
    [] -> [Char] -> Col
ColString [Char]
lineString
    [Aspect]
colors -> [Col] -> Col
ColCat [NonEmpty Aspect -> Col -> Col
ColAspect (Aspect -> NonEmpty Aspect
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Aspect
color) ([Char] -> Col
ColString [Char
c]) | (Char
c, Aspect
color) <- [Char] -> [Aspect] -> [(Char, Aspect)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Char]
lineString ([Aspect] -> [Aspect]
forall a. HasCallStack => [a] -> [a]
cycle [Aspect]
colors)]
 where
  lineString :: [Char]
lineString
    | Aspect -> [Aspect] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Aspect
Fork [Aspect]
aspects = Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
lineWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Char
' ' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char
forkChar]
    | Bool
otherwise = Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate Int
lineWidth Char
lc
  lineWidth :: Int
lineWidth = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
labelWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
slotDistance)
  lc :: Char
lc = RenderConfig -> [Aspect] -> Char
lineChar RenderConfig
config [Aspect]
aspects

labelColor :: CellSort -> Maybe (NonEmpty Aspect)
labelColor :: CellSort -> Maybe (NonEmpty Aspect)
labelColor = \case
  CellSort
CellOther -> Maybe (NonEmpty Aspect)
forall a. Maybe a
Nothing
  CellHere NonEmpty Aspect
aspects ->
    [Aspect] -> Maybe (NonEmpty Aspect)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([Aspect] -> [Aspect]
colorAspects (NonEmpty Aspect -> [Item (NonEmpty Aspect)]
forall l. IsList l => l -> [Item l]
toList NonEmpty Aspect
aspects))

renderSpecifiedLabel :: String -> CellSort -> Col
renderSpecifiedLabel :: [Char] -> CellSort -> Col
renderSpecifiedLabel [Char]
label CellSort
srt =
  case CellSort -> Maybe (NonEmpty Aspect)
labelColor CellSort
srt of
    Maybe (NonEmpty Aspect)
Nothing -> Col
text
    Just NonEmpty Aspect
as -> NonEmpty Aspect -> Col -> Col
ColAspect NonEmpty Aspect
as Col
text
 where
  text :: Col
text = [Char] -> Col
ColString [Char]
label

renderLabel :: Maybe String -> CellSort -> Col
renderLabel :: Maybe [Char] -> CellSort -> Col
renderLabel Maybe [Char]
label CellSort
srt
  | Just [Char]
specified <- Maybe [Char]
label =
      [Char] -> CellSort -> Col
renderSpecifiedLabel [Char]
specified CellSort
srt
  | Bool
otherwise =
      Col
""

renderPoint :: CellSort -> Col
renderPoint :: CellSort -> Col
renderPoint = \case
  CellHere NonEmpty Aspect
aspects ->
    [Col] -> Col
forall a. Monoid a => [a] -> a
mconcat ((Aspect -> Maybe Col) -> [Aspect] -> [Col]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Aspect -> Maybe Col
pointMarker (NonEmpty Aspect -> [Item (NonEmpty Aspect)]
forall l. IsList l => l -> [Item l]
toList NonEmpty Aspect
aspects))
  CellSort
_ -> Col
""
 where
  pointMarker :: Aspect -> Maybe Col
pointMarker = \case
    TipPoint PeerId
pid -> Col -> Maybe Col
forall a. a -> Maybe a
Just (NonEmpty Aspect -> Col -> Col
ColAspect (Aspect -> NonEmpty Aspect
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PeerId -> Aspect
TipPoint PeerId
pid)) Col
"↑")
    Aspect
_ -> Maybe Col
forall a. Maybe a
Nothing

renderFragCell :: RenderConfig -> SlotWidth -> FragCell -> Col
renderFragCell :: RenderConfig -> SlotWidth -> FragCell -> Col
renderFragCell RenderConfig
config SlotWidth
width FragCell{Maybe [Char]
fcLabel :: FragCell -> Maybe [Char]
fcLabel :: Maybe [Char]
fcLabel, CellSort
fcSort :: FragCell -> CellSort
fcSort :: CellSort
fcSort, [Aspect]
fcLineAspects :: FragCell -> [Aspect]
fcLineAspects :: [Aspect]
fcLineAspects} =
  RenderConfig -> SlotWidth -> [Aspect] -> Int -> Col
renderLine RenderConfig
config SlotWidth
width [Aspect]
fcLineAspects (Col -> Int
colLength Col
label) Col -> Col -> Col
forall a. Semigroup a => a -> a -> a
<> Col
label
 where
  label :: Col
label = Maybe [Char] -> CellSort -> Col
renderLabel Maybe [Char]
fcLabel CellSort
fcSort Col -> Col -> Col
forall a. Semigroup a => a -> a -> a
<> CellSort -> Col
renderPoint CellSort
fcSort

renderSlotNo :: RenderConfig -> SlotWidth -> WithOrigin Int -> Col
renderSlotNo :: RenderConfig -> SlotWidth -> WithOrigin Int -> Col
renderSlotNo RenderConfig
config SlotWidth
width WithOrigin Int
num =
  NonEmpty Aspect -> Col -> Col
ColAspect (Aspect -> NonEmpty Aspect
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Aspect
SlotNumber) ([Char] -> Col
ColString (RenderConfig -> Char -> SlotWidth -> [Char] -> [Char]
padCell RenderConfig
config Char
' ' SlotWidth
width [Char]
label))
 where
  label :: [Char]
label = case WithOrigin Int
num of
    WithOrigin Int
Origin -> [Char]
"G"
    At Int
s -> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
s

renderPeers :: [PeerId] -> Col
renderPeers :: [PeerId] -> Col
renderPeers [PeerId]
peers =
  [Col] -> Col
ColCat [NonEmpty Aspect -> Col -> Col
ColAspect (Aspect -> NonEmpty Aspect
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PeerId -> Aspect
Candidate PeerId
p)) ([Char] -> Col
ColString ([Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PeerId -> [Char]
forall a. Show a => a -> [Char]
show PeerId
p)) | PeerId
p <- [PeerId]
peers]

renderCell :: RenderConfig -> RenderCell -> Col
renderCell :: RenderConfig -> RenderCell -> Col
renderCell config :: RenderConfig
config@RenderConfig{[Char]
ellipsis :: RenderConfig -> [Char]
ellipsis :: [Char]
ellipsis} = \case
  RenderCell SlotWidth
width (Cell FragCell
cell) -> RenderConfig -> SlotWidth -> FragCell -> Col
renderFragCell RenderConfig
config SlotWidth
width FragCell
cell
  RenderCell SlotWidth
width (Cell
CellEmpty) -> [Char] -> Col
ColString (RenderConfig -> Char -> SlotWidth -> [Char] -> [Char]
padCell RenderConfig
config Char
' ' SlotWidth
width [Char]
"")
  RenderCell SlotWidth
width (CellSlotNo WithOrigin Int
n) -> RenderConfig -> SlotWidth -> WithOrigin Int -> Col
renderSlotNo RenderConfig
config SlotWidth
width WithOrigin Int
n
  RenderCell SlotWidth
_ (CellPeers [PeerId]
peers) -> [PeerId] -> Col
renderPeers [PeerId]
peers
  RenderCell
CellEllipsis -> [Char] -> Col
ColString [Char]
ellipsis

renderBranch :: RenderConfig -> [RenderCell] -> Col
renderBranch :: RenderConfig -> [RenderCell] -> Col
renderBranch RenderConfig
config [RenderCell]
cells =
  [Char] -> Col -> Col
forall a. [Char] -> a -> a
debugRender ([RenderCell] -> [Char]
forall a. Condense a => a -> [Char]
condense [RenderCell]
cells) (Col -> Col) -> Col -> Col
forall a b. (a -> b) -> a -> b
$
    (RenderCell -> Col) -> [RenderCell] -> Col
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (RenderConfig -> RenderCell -> Col
renderCell RenderConfig
config) [RenderCell]
cells

-- | Use w + 2 because we want the effective width, which includes the line segment.
renderSlotWidth :: Int -> RenderSlot -> Int
renderSlotWidth :: Int -> RenderSlot -> Int
renderSlotWidth Int
ellipsisWidth = \case
  SlotEllipsis Int
_ -> Int
ellipsisWidth
  RenderSlot Int
_ (SlotWidth Int
w) NonEmpty Cell
_ -> Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2

breakLines :: RenderConfig -> [RenderSlot] -> [[RenderSlot]]
breakLines :: RenderConfig -> [RenderSlot] -> [[RenderSlot]]
breakLines RenderConfig{Int
lineWidth :: RenderConfig -> Int
lineWidth :: Int
lineWidth, [Char]
ellipsis :: RenderConfig -> [Char]
ellipsis :: [Char]
ellipsis} =
  (Int, [RenderSlot], [[RenderSlot]]) -> [[RenderSlot]]
forall {a} {a}. (a, [a], [[a]]) -> [[a]]
result ((Int, [RenderSlot], [[RenderSlot]]) -> [[RenderSlot]])
-> ([RenderSlot] -> (Int, [RenderSlot], [[RenderSlot]]))
-> [RenderSlot]
-> [[RenderSlot]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, [RenderSlot], [[RenderSlot]])
 -> RenderSlot -> (Int, [RenderSlot], [[RenderSlot]]))
-> (Int, [RenderSlot], [[RenderSlot]])
-> [RenderSlot]
-> (Int, [RenderSlot], [[RenderSlot]])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl' (Int, [RenderSlot], [[RenderSlot]])
-> RenderSlot -> (Int, [RenderSlot], [[RenderSlot]])
step (Int
0, [], [])
 where
  result :: (a, [a], [[a]]) -> [[a]]
result (a
_, [a]
cur, [[a]]
res) = [[a]] -> [[a]]
forall a. [a] -> [a]
reverse ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
cur [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]]
res)
  step :: (Int, [RenderSlot], [[RenderSlot]])
-> RenderSlot -> (Int, [RenderSlot], [[RenderSlot]])
step (Int
w, [RenderSlot]
cur, [[RenderSlot]]
res) RenderSlot
slot
    | Int
new Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
lineWidth = (Int
new, RenderSlot
slot RenderSlot -> [RenderSlot] -> [RenderSlot]
forall a. a -> [a] -> [a]
: [RenderSlot]
cur, [[RenderSlot]]
res)
    | Bool
otherwise = (Int
curW, [RenderSlot
slot], [RenderSlot] -> [RenderSlot]
forall a. [a] -> [a]
reverse [RenderSlot]
cur [RenderSlot] -> [[RenderSlot]] -> [[RenderSlot]]
forall a. a -> [a] -> [a]
: [[RenderSlot]]
res)
   where
    new :: Int
new = Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
curW
    curW :: Int
curW = Int -> RenderSlot -> Int
renderSlotWidth ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
ellipsis) RenderSlot
slot

renderCells :: [RenderSlot] -> [[RenderCell]]
renderCells :: [RenderSlot] -> [[RenderCell]]
renderCells =
  [[RenderCell]] -> [[RenderCell]]
forall a. [[a]] -> [[a]]
transpose ([[RenderCell]] -> [[RenderCell]])
-> ([RenderSlot] -> [[RenderCell]])
-> [RenderSlot]
-> [[RenderCell]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RenderSlot -> [RenderCell]) -> [RenderSlot] -> [[RenderCell]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RenderSlot -> [RenderCell]
toCells
 where
  toCells :: RenderSlot -> [RenderCell]
toCells = \case
    RenderSlot Int
_ SlotWidth
width NonEmpty Cell
cells -> SlotWidth -> Cell -> RenderCell
RenderCell SlotWidth
width (Cell -> RenderCell) -> [Cell] -> [RenderCell]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty Cell -> [Item (NonEmpty Cell)]
forall l. IsList l => l -> [Item l]
toList NonEmpty Cell
cells
    SlotEllipsis Int
n -> Int -> RenderCell -> [RenderCell]
forall a. Int -> a -> [a]
replicate Int
n RenderCell
CellEllipsis

renderSlotSequence :: RenderConfig -> [RenderSlot] -> [Col]
renderSlotSequence :: RenderConfig -> [RenderSlot] -> [Col]
renderSlotSequence RenderConfig
config =
  ([RenderCell] -> Col) -> [[RenderCell]] -> [Col]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RenderConfig -> [RenderCell] -> Col
renderBranch RenderConfig
config) ([[RenderCell]] -> [Col])
-> ([RenderSlot] -> [[RenderCell]]) -> [RenderSlot] -> [Col]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RenderSlot] -> [[RenderCell]]
renderCells

renderSlots :: RenderConfig -> [RenderSlot] -> [[Col]]
renderSlots :: RenderConfig -> [RenderSlot] -> [[Col]]
renderSlots RenderConfig
config [RenderSlot]
slots =
  RenderConfig -> [RenderSlot] -> [Col]
renderSlotSequence RenderConfig
config ([RenderSlot] -> [Col]) -> [[RenderSlot]] -> [[Col]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RenderConfig -> [RenderSlot] -> [[RenderSlot]]
breakLines RenderConfig
config [RenderSlot]
slots

renderColBlocks :: RenderConfig -> [[Col]] -> ([String], Colors)
renderColBlocks :: RenderConfig -> [[Col]] -> ([[Char]], Colors)
renderColBlocks RenderConfig{[Word64]
candidateColors :: RenderConfig -> [Word64]
candidateColors :: [Word64]
candidateColors, Maybe Word64
selectionColor :: RenderConfig -> Maybe Word64
selectionColor :: Maybe Word64
selectionColor, Word64
slotNumberColor :: RenderConfig -> Word64
slotNumberColor :: Word64
slotNumberColor, Map PeerId Word64
cachedPeers :: RenderConfig -> Map PeerId Word64
cachedPeers :: Map PeerId Word64
cachedPeers} [[Col]]
cols =
  ([[[Char]]] -> [[Char]])
-> ([[[Char]]], Colors) -> ([[Char]], Colors)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first
    (([[Char]] -> [Char]) -> [[[Char]]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Char]] -> [Char]
unlines)
    ( [Word64]
-> Maybe Word64
-> Word64
-> Map PeerId Word64
-> State Colors [[[Char]]]
-> ([[[Char]]], Colors)
forall a.
[Word64]
-> Maybe Word64
-> Word64
-> Map PeerId Word64
-> State Colors a
-> (a, Colors)
runCol
        [Word64]
candidateColors
        Maybe Word64
selectionColor
        Word64
slotNumberColor
        Map PeerId Word64
cachedPeers
        (([Col] -> StateT Colors Identity [[Char]])
-> [[Col]] -> State Colors [[[Char]]]
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) -> [a] -> f [b]
traverse ((Col -> State Colors [Char])
-> [Col] -> StateT Colors Identity [[Char]]
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) -> [a] -> f [b]
traverse Col -> State Colors [Char]
renderCol) [[Col]]
cols)
    )

------------------------------------------------------------------------------------------------------
---- API
------------------------------------------------------------------------------------------------------

-- | All inputs for the state diagram printer.
data PeerSimState blk
  = PeerSimState
  { forall blk. PeerSimState blk -> BlockTree blk
pssBlockTree :: BlockTree blk
  , forall blk. PeerSimState blk -> AnchoredFragment (Header blk)
pssSelection :: AF.AnchoredFragment (Header blk)
  , forall blk.
PeerSimState blk -> Map PeerId (AnchoredFragment (Header blk))
pssCandidates :: Map PeerId (AF.AnchoredFragment (Header blk))
  , forall blk. PeerSimState blk -> Map PeerId (NodeState blk)
pssPoints :: Map PeerId (NodeState blk)
  }

-- TODO add an aspect for the last block of each branch?

-- | Pretty-print the current peer simulator state in a block tree, highlighting
-- the candidate fragments, selection, and forks in different colors, omitting
-- uninteresting segments.
peerSimStateDiagramWith ::
  (Eq (Header blk), AF.HasHeader blk, GetHeader blk) =>
  RenderConfig ->
  PeerSimState blk ->
  (String, Map PeerId Word64)
peerSimStateDiagramWith :: forall blk.
(Eq (Header blk), HasHeader blk, GetHeader blk) =>
RenderConfig -> PeerSimState blk -> ([Char], Map PeerId Word64)
peerSimStateDiagramWith RenderConfig
config PeerSimState{BlockTree blk
pssBlockTree :: forall blk. PeerSimState blk -> BlockTree blk
pssBlockTree :: BlockTree blk
pssBlockTree, AnchoredFragment (Header blk)
pssSelection :: forall blk. PeerSimState blk -> AnchoredFragment (Header blk)
pssSelection :: AnchoredFragment (Header blk)
pssSelection, Map PeerId (AnchoredFragment (Header blk))
pssCandidates :: forall blk.
PeerSimState blk -> Map PeerId (AnchoredFragment (Header blk))
pssCandidates :: Map PeerId (AnchoredFragment (Header blk))
pssCandidates, Map PeerId (NodeState blk)
pssPoints :: forall blk. PeerSimState blk -> Map PeerId (NodeState blk)
pssPoints :: Map PeerId (NodeState blk)
pssPoints} =
  [Char]
-> ([Char], Map PeerId Word64) -> ([Char], Map PeerId Word64)
forall a. [Char] -> a -> a
debugRender ([[Char]] -> [Char]
unlines (BlockTree blk -> [[Char]]
forall blk. HasHeader blk => BlockTree blk -> [[Char]]
prettyBlockTree BlockTree blk
pssBlockTree)) (([Char], Map PeerId Word64) -> ([Char], Map PeerId Word64))
-> ([Char], Map PeerId Word64) -> ([Char], Map PeerId Word64)
forall a b. (a -> b) -> a -> b
$
    ([[Char]] -> [Char]
unlines [[Char]]
blocks, Map PeerId Word64
cache)
 where
  ([[Char]]
blocks, Colors{Map PeerId Word64
cache :: Colors -> Map PeerId Word64
cache :: Map PeerId Word64
cache}) = RenderConfig -> [[Col]] -> ([[Char]], Colors)
renderColBlocks RenderConfig
config (RenderConfig -> [RenderSlot] -> [[Col]]
renderSlots RenderConfig
config [RenderSlot]
frags)

  frags :: [RenderSlot]
frags =
    NonEmpty (NonEmpty Cell) -> [RenderSlot]
pruneCells (NonEmpty (NonEmpty Cell) -> [RenderSlot])
-> NonEmpty (NonEmpty Cell) -> [RenderSlot]
forall a b. (a -> b) -> a -> b
$
      TreeSlots blk -> NonEmpty (NonEmpty Cell)
forall blk. TreeSlots blk -> NonEmpty (NonEmpty Cell)
treeCells (TreeSlots blk -> NonEmpty (NonEmpty Cell))
-> TreeSlots blk -> NonEmpty (NonEmpty Cell)
forall a b. (a -> b) -> a -> b
$
        BlockTree blk
-> Map PeerId (NodeState blk) -> TreeSlots blk -> TreeSlots blk
forall blk.
HasHeader blk =>
BlockTree blk
-> Map PeerId (NodeState blk) -> TreeSlots blk -> TreeSlots blk
addPoints BlockTree blk
pssBlockTree Map PeerId (NodeState blk)
pssPoints (TreeSlots blk -> TreeSlots blk) -> TreeSlots blk -> TreeSlots blk
forall a b. (a -> b) -> a -> b
$
          TreeSlots blk -> TreeSlots blk
forall blk. TreeSlots blk -> TreeSlots blk
addForks (TreeSlots blk -> TreeSlots blk) -> TreeSlots blk -> TreeSlots blk
forall a b. (a -> b) -> a -> b
$
            (TreeSlots blk
 -> [(PeerId, AnchoredFragment (Header blk))] -> TreeSlots blk)
-> [(PeerId, AnchoredFragment (Header blk))]
-> TreeSlots blk
-> TreeSlots blk
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((TreeSlots blk
 -> (PeerId, AnchoredFragment (Header blk)) -> TreeSlots blk)
-> TreeSlots blk
-> [(PeerId, AnchoredFragment (Header blk))]
-> TreeSlots blk
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl' TreeSlots blk
-> (PeerId, AnchoredFragment (Header blk)) -> TreeSlots blk
forall blk.
(Eq (Header blk), HasHeader (Header blk)) =>
TreeSlots blk
-> (PeerId, AnchoredFragment (Header blk)) -> TreeSlots blk
addCandidateRange) (Map PeerId (AnchoredFragment (Header blk))
-> [(PeerId, AnchoredFragment (Header blk))]
forall k a. Map k a -> [(k, a)]
Map.toList Map PeerId (AnchoredFragment (Header blk))
pssCandidates) (TreeSlots blk -> TreeSlots blk) -> TreeSlots blk -> TreeSlots blk
forall a b. (a -> b) -> a -> b
$
              Aspect
-> AnchoredFragment (Header blk) -> TreeSlots blk -> TreeSlots blk
forall blk.
(Eq (Header blk), HasHeader (Header blk)) =>
Aspect
-> AnchoredFragment (Header blk) -> TreeSlots blk -> TreeSlots blk
addFragRange Aspect
Selection AnchoredFragment (Header blk)
pssSelection (TreeSlots blk -> TreeSlots blk) -> TreeSlots blk -> TreeSlots blk
forall a b. (a -> b) -> a -> b
$
                BlockTree blk -> TreeSlots blk
forall blk.
(HasHeader blk, GetHeader blk) =>
BlockTree blk -> TreeSlots blk
initTree BlockTree blk
pssBlockTree

defaultRenderConfig :: RenderConfig
defaultRenderConfig :: RenderConfig
defaultRenderConfig =
  RenderConfig
    { lineWidth :: Int
lineWidth = Int
80
    , ellipsis :: [Char]
ellipsis = [Char]
" .. "
    , slotDistance :: Int
slotDistance = Int
2
    , boringChar :: Char
boringChar = Char
'·'
    , candidateChar :: Char
candidateChar = Char
'-'
    , selectionChar :: Char
selectionChar = Char
'*'
    , forkChar :: Char
forkChar = Char
'`'
    , candidateColors :: [Word64]
candidateColors = [Word64
164, Word64
113, Word64
142, Word64
81, Word64
33]
    , cachedPeers :: Map PeerId Word64
cachedPeers = Map PeerId Word64
forall a. Monoid a => a
mempty
    , selectionColor :: Maybe Word64
selectionColor = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
123
    , slotNumberColor :: Word64
slotNumberColor = Word64
166
    }

peerSimStateDiagram ::
  (AF.HasHeader blk, Eq (Header blk), GetHeader blk) => PeerSimState blk -> String
peerSimStateDiagram :: forall blk.
(HasHeader blk, Eq (Header blk), GetHeader blk) =>
PeerSimState blk -> [Char]
peerSimStateDiagram =
  ([Char], Map PeerId Word64) -> [Char]
forall a b. (a, b) -> a
fst (([Char], Map PeerId Word64) -> [Char])
-> (PeerSimState blk -> ([Char], Map PeerId Word64))
-> PeerSimState blk
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RenderConfig -> PeerSimState blk -> ([Char], Map PeerId Word64)
forall blk.
(Eq (Header blk), HasHeader blk, GetHeader blk) =>
RenderConfig -> PeerSimState blk -> ([Char], Map PeerId Word64)
peerSimStateDiagramWith RenderConfig
defaultRenderConfig

-- | Construct a tracer that prints the current peer simulator state in
-- a block tree, highlighting the candidate fragments, selection, and forks in
-- different colors, omitting uninteresting segments.
peerSimStateDiagramTracer ::
  (AF.HasHeader blk, Eq (Header blk), GetHeader blk) =>
  Tracer m String ->
  Tracer m (PeerSimState blk)
peerSimStateDiagramTracer :: forall blk (m :: * -> *).
(HasHeader blk, Eq (Header blk), GetHeader blk) =>
Tracer m [Char] -> Tracer m (PeerSimState blk)
peerSimStateDiagramTracer Tracer m [Char]
tracer =
  (PeerSimState blk -> m ()) -> Tracer m (PeerSimState blk)
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer (Tracer m [Char] -> [Char] -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m [Char]
tracer ([Char] -> m ())
-> (PeerSimState blk -> [Char]) -> PeerSimState blk -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerSimState blk -> [Char]
forall blk.
(HasHeader blk, Eq (Header blk), GetHeader blk) =>
PeerSimState blk -> [Char]
peerSimStateDiagram)

-- | Construct a stateful tracer that prints the current peer simulator state in
-- a block tree, highlighting the candidate fragments, selection, and forks in
-- different colors, omitting uninteresting segments.
--
-- Since the tracer gets its input from concurrent state, it takes only a dummy
-- @()@ value as its argument.
peerSimStateDiagramSTMTracer ::
  IOLike m =>
  (AF.HasHeader blk, Eq (Header blk), GetHeader blk) =>
  Tracer m String ->
  BlockTree blk ->
  STM m (AF.AnchoredFragment (Header blk)) ->
  STM m (Map PeerId (AF.AnchoredFragment (Header blk))) ->
  STM m (Map PeerId (Maybe (NodeState blk))) ->
  m (Tracer m ())
peerSimStateDiagramSTMTracer :: forall (m :: * -> *) blk.
(IOLike m, HasHeader blk, Eq (Header blk), GetHeader blk) =>
Tracer m [Char]
-> BlockTree blk
-> STM m (AnchoredFragment (Header blk))
-> STM m (Map PeerId (AnchoredFragment (Header blk)))
-> STM m (Map PeerId (Maybe (NodeState blk)))
-> m (Tracer m ())
peerSimStateDiagramSTMTracer Tracer m [Char]
stringTracer BlockTree blk
pssBlockTree STM m (AnchoredFragment (Header blk))
selectionVar STM m (Map PeerId (AnchoredFragment (Header blk)))
candidatesVar STM m (Map PeerId (Maybe (NodeState blk)))
pointsVar = do
  peerCache <- Map PeerId Word64 -> m (StrictTVar m (Map PeerId Word64))
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
uncheckedNewTVarM Map PeerId Word64
forall a. Monoid a => a
mempty
  pure $ Tracer $ const $ do
    (s, cachedPeers) <- atomically $ do
      pssSelection <- selectionVar
      pssCandidates <- candidatesVar
      pssPoints <- fmap (fromMaybe genesisNodeState) <$> pointsVar
      cachedPeers <- readTVar peerCache
      pure (PeerSimState{pssBlockTree, pssSelection, pssCandidates, pssPoints}, cachedPeers)
    let (blocks, newPeers) = peerSimStateDiagramWith (defaultRenderConfig{cachedPeers}) s
    atomically (modifyTVar peerCache (newPeers <>))
    traceWith stringTracer blocks

-- | Construct a stateful tracer that prints the current peer simulator state in
-- a block tree, highlighting the candidate fragments, selection, and forks in
-- different colors, omitting uninteresting segments.
--
-- Since the tracer gets its input from concurrent state, it takes only a dummy
-- @()@ value as its argument.
--
-- This variant uses the global debug tracer.
peerSimStateDiagramSTMTracerDebug ::
  IOLike m =>
  (AF.HasHeader blk, Eq (Header blk), GetHeader blk) =>
  BlockTree blk ->
  STM m (AF.AnchoredFragment (Header blk)) ->
  STM m (Map PeerId (AF.AnchoredFragment (Header blk))) ->
  STM m (Map PeerId (Maybe (NodeState blk))) ->
  m (Tracer m ())
peerSimStateDiagramSTMTracerDebug :: forall (m :: * -> *) blk.
(IOLike m, HasHeader blk, Eq (Header blk), GetHeader blk) =>
BlockTree blk
-> STM m (AnchoredFragment (Header blk))
-> STM m (Map PeerId (AnchoredFragment (Header blk)))
-> STM m (Map PeerId (Maybe (NodeState blk)))
-> m (Tracer m ())
peerSimStateDiagramSTMTracerDebug =
  Tracer m [Char]
-> BlockTree blk
-> STM m (AnchoredFragment (Header blk))
-> STM m (Map PeerId (AnchoredFragment (Header blk)))
-> STM m (Map PeerId (Maybe (NodeState blk)))
-> m (Tracer m ())
forall (m :: * -> *) blk.
(IOLike m, HasHeader blk, Eq (Header blk), GetHeader blk) =>
Tracer m [Char]
-> BlockTree blk
-> STM m (AnchoredFragment (Header blk))
-> STM m (Map PeerId (AnchoredFragment (Header blk)))
-> STM m (Map PeerId (Maybe (NodeState blk)))
-> m (Tracer m ())
peerSimStateDiagramSTMTracer Tracer m [Char]
forall (m :: * -> *). Applicative m => Tracer m [Char]
debugTracer