{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}

-- | 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 (find, 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.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), Header,
                     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), prettyBlockTree)
import           Test.Consensus.PointSchedule.NodeState (NodeState (..),
                     genesisNodeState)
import           Test.Consensus.PointSchedule.Peers (PeerId (..))
import           Test.Util.TestBlock (TestBlock, TestHash (TestHash))

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
    Maybe Word64
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
    Maybe [SGR] -> State Colors (Maybe [SGR])
forall a. a -> StateT Colors Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([SGR] -> Maybe [SGR]
forall a. a -> Maybe a
Just (SGR
Bold SGR -> [SGR] -> [SGR]
forall a. a -> [a] -> [a]
: [SGR] -> (Word64 -> [SGR]) -> Maybe Word64 -> [SGR]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (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
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
    Word64
c <- (Colors -> Word64) -> StateT Colors Identity Word64
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Colors -> Word64
slotNumber
    Maybe [SGR] -> State Colors (Maybe [SGR])
forall a. a -> StateT Colors Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([SGR] -> Maybe [SGR]
forall a. a -> Maybe a
Just [Word64 -> SGR
mkColor Word64
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
  ([SGR]
main, [Aspect]
rest) <- Bool -> [Aspect] -> StateT Colors Identity ([SGR], [Aspect])
findColor Bool
False (NonEmpty Aspect -> [Aspect]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Aspect
aspects)
  ([SGR]
bg, [Aspect]
_) <- Bool -> [Aspect] -> StateT Colors Identity ([SGR], [Aspect])
findColor Bool
True [Aspect]
rest
  [SGR] -> State Colors [SGR]
forall a. a -> StateT Colors Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([SGR]
main [SGR] -> [SGR] -> [SGR]
forall a. [a] -> [a] -> [a]
++ [SGR]
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]
sgr <- NonEmpty Aspect -> State Colors [SGR]
getColors NonEmpty Aspect
aspects
        [SGR] -> Col -> State Colors [Char]
withSgr [SGR]
sgr Col
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
      [SGR]
pre <- [SGR] -> State Colors [SGR]
forall {m :: * -> *}. MonadState Colors m => [SGR] -> m [SGR]
push [SGR]
sgr
      [Char]
s <- Col -> State Colors [Char]
spin Col
sub
      StateT Colors Identity ()
pop
      [Char] -> State Colors [Char]
forall a. a -> StateT Colors Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([SGR] -> [Char]
renderSgr [SGR]
sgr [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [SGR] -> [Char]
renderSgr [SGR]
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 =
  BranchSlots {
    BranchSlots -> AnchoredFragment (Header TestBlock)
frag   :: AF.AnchoredFragment (Header TestBlock),
    BranchSlots -> Vector Slot
slots  :: Vector Slot,
    BranchSlots -> [PeerId]
cands  :: [PeerId],
    BranchSlots -> Word64
forkNo :: Word64
  }
  deriving (Int -> BranchSlots -> [Char] -> [Char]
[BranchSlots] -> [Char] -> [Char]
BranchSlots -> [Char]
(Int -> BranchSlots -> [Char] -> [Char])
-> (BranchSlots -> [Char])
-> ([BranchSlots] -> [Char] -> [Char])
-> Show BranchSlots
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> BranchSlots -> [Char] -> [Char]
showsPrec :: Int -> BranchSlots -> [Char] -> [Char]
$cshow :: BranchSlots -> [Char]
show :: BranchSlots -> [Char]
$cshowList :: [BranchSlots] -> [Char] -> [Char]
showList :: [BranchSlots] -> [Char] -> [Char]
Show)

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 :: Int -> Range -> AF.AnchoredFragment TestBlock -> Vector Slot
initSlots :: Int -> Range -> AnchoredFragment TestBlock -> Vector Slot
initSlots Int
lastSlot (Range Int
l Int
u) AnchoredFragment TestBlock
blocks =
  [Slot] -> Vector Slot
forall a. [a] -> Vector a
Vector.fromList (([TestBlock], [Slot]) -> [Slot]
forall a b. (a, b) -> b
snd (([TestBlock] -> Int -> ([TestBlock], Slot))
-> [TestBlock] -> [Int] -> ([TestBlock], [Slot])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL [TestBlock] -> Int -> ([TestBlock], Slot)
step (AnchoredFragment TestBlock -> [TestBlock]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst AnchoredFragment TestBlock
blocks) [-Int
1 .. Int
lastSlot]))
  where
    step :: [TestBlock] -> Int -> ([TestBlock], Slot)
step [TestBlock]
bs Int
cur
      | Int
cur Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -Int
1
      = ([TestBlock]
bs, Slot {num :: WithOrigin Int
num = WithOrigin Int
forall t. WithOrigin t
Origin, capacity :: SlotCapacity
capacity = SlotCapacity
SlotOutside, aspects :: [SlotAspect]
aspects = []})

      | TestBlock
b : [TestBlock]
rest <- [TestBlock]
bs
      , Int
s <- SlotNo -> Int
slotInt (TestBlock -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot TestBlock
b)
      , Int
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
cur
      = ([TestBlock]
rest, Int -> SlotCapacity -> Slot
mkSlot Int
cur (Int -> SlotCapacity
SlotBlock (BlockNo -> Int
blockInt (TestBlock -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo TestBlock
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
      = ([TestBlock]
bs, Int -> SlotCapacity -> Slot
mkSlot Int
cur SlotCapacity
SlotEmpty)

      | Bool
otherwise
      = ([TestBlock]
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 = []}

hashForkNo :: HeaderHash TestBlock -> Word64
hashForkNo :: HeaderHash TestBlock -> Word64
hashForkNo (TestHash NonEmpty Word64
h) =
  Word64 -> Maybe Word64 -> Word64
forall a. a -> Maybe a -> a
fromMaybe Word64
0 ((Word64 -> Bool) -> NonEmpty Word64 -> Maybe Word64
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64
0) NonEmpty Word64
h)

blockForkNo :: ChainHash TestBlock -> Word64
blockForkNo :: ChainHash TestBlock -> Word64
blockForkNo = \case
  BlockHash HeaderHash TestBlock
h -> HeaderHash TestBlock -> Word64
hashForkNo HeaderHash TestBlock
h
  ChainHash TestBlock
_ -> Word64
0

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

data TreeSlots =
  TreeSlots {
    TreeSlots -> Int
lastSlot :: Int,
    TreeSlots -> [BranchSlots]
branches :: [BranchSlots]
  }
  deriving (Int -> TreeSlots -> [Char] -> [Char]
[TreeSlots] -> [Char] -> [Char]
TreeSlots -> [Char]
(Int -> TreeSlots -> [Char] -> [Char])
-> (TreeSlots -> [Char])
-> ([TreeSlots] -> [Char] -> [Char])
-> Show TreeSlots
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> TreeSlots -> [Char] -> [Char]
showsPrec :: Int -> TreeSlots -> [Char] -> [Char]
$cshow :: TreeSlots -> [Char]
show :: TreeSlots -> [Char]
$cshowList :: [TreeSlots] -> [Char] -> [Char]
showList :: [TreeSlots] -> [Char] -> [Char]
Show)

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

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

    initFR :: (Range, AnchoredFragment TestBlock) -> BranchSlots
initFR = (Range -> AnchoredFragment TestBlock -> BranchSlots)
-> (Range, AnchoredFragment TestBlock) -> BranchSlots
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Int -> Range -> AnchoredFragment TestBlock -> BranchSlots
initBranch Int
lastSlot)

    lastSlot :: Int
lastSlot = ((Range, AnchoredFragment TestBlock) -> Int -> Int)
-> Int -> [(Range, AnchoredFragment TestBlock)] -> 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 TestBlock) -> Int)
-> (Range, AnchoredFragment TestBlock)
-> Int
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Range -> Int
to (Range -> Int)
-> ((Range, AnchoredFragment TestBlock) -> Range)
-> (Range, AnchoredFragment TestBlock)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Range, AnchoredFragment TestBlock) -> Range
forall a b. (a, b) -> a
fst)) Int
0 ((Range, AnchoredFragment TestBlock)
trunkRange (Range, AnchoredFragment TestBlock)
-> [(Range, AnchoredFragment TestBlock)]
-> [(Range, AnchoredFragment TestBlock)]
forall a. a -> [a] -> [a]
: [(Range, AnchoredFragment TestBlock)]
branchRanges)

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

    branchRanges :: [(Range, AnchoredFragment TestBlock)]
branchRanges = AnchoredFragment TestBlock -> (Range, AnchoredFragment TestBlock)
forall {block}.
HasHeader block =>
AnchoredFragment block -> (Range, AnchoredFragment block)
withRange (AnchoredFragment TestBlock -> (Range, AnchoredFragment TestBlock))
-> (BlockTreeBranch TestBlock -> AnchoredFragment TestBlock)
-> BlockTreeBranch TestBlock
-> (Range, AnchoredFragment TestBlock)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockTreeBranch TestBlock -> AnchoredFragment TestBlock
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbSuffix (BlockTreeBranch TestBlock -> (Range, AnchoredFragment TestBlock))
-> [BlockTreeBranch TestBlock]
-> [(Range, AnchoredFragment TestBlock)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockTree TestBlock -> [BlockTreeBranch TestBlock]
forall blk. BlockTree blk -> [BlockTreeBranch blk]
btBranches BlockTree TestBlock
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 :: AF.AnchoredFragment (Header TestBlock) -> AF.AnchoredFragment (Header TestBlock) -> Maybe (Range, Bool)
commonRange :: AnchoredFragment (Header TestBlock)
-> AnchoredFragment (Header TestBlock) -> Maybe (Range, Bool)
commonRange AnchoredFragment (Header TestBlock)
branch AnchoredFragment (Header TestBlock)
segment = do
  (AnchoredFragment (Header TestBlock)
preB, AnchoredFragment (Header TestBlock)
preS, AnchoredFragment (Header TestBlock)
_, AnchoredFragment (Header TestBlock)
_) <- AnchoredFragment (Header TestBlock)
-> AnchoredFragment (Header TestBlock)
-> Maybe
     (AnchoredFragment (Header TestBlock),
      AnchoredFragment (Header TestBlock),
      AnchoredFragment (Header TestBlock),
      AnchoredFragment (Header TestBlock))
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 TestBlock)
branch AnchoredFragment (Header TestBlock)
segment
  Header TestBlock
lower <- [Header TestBlock]
-> [Header TestBlock] -> Maybe (Header TestBlock)
forall {a}. Eq a => [a] -> [a] -> Maybe a
findLower (AnchoredFragment (Header TestBlock) -> [Header TestBlock]
forall v a b. AnchoredSeq v a b -> [b]
AF.toNewestFirst AnchoredFragment (Header TestBlock)
preB) (AnchoredFragment (Header TestBlock) -> [Header TestBlock]
forall v a b. AnchoredSeq v a b -> [b]
AF.toNewestFirst AnchoredFragment (Header TestBlock)
preS)
  Header TestBlock
upper <- Either (Anchor (Header TestBlock)) (Header TestBlock)
-> Maybe (Header TestBlock)
forall a b. Either a b -> Maybe b
eitherToMaybe (AnchoredFragment (Header TestBlock)
-> Either (Anchor (Header TestBlock)) (Header TestBlock)
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Either a b
AF.head AnchoredFragment (Header TestBlock)
preB)
  let
    aB :: Anchor (Header TestBlock)
aB = AnchoredFragment (Header TestBlock) -> Anchor (Header TestBlock)
forall v a b. AnchoredSeq v a b -> a
anchor AnchoredFragment (Header TestBlock)
preB
    aS :: Anchor (Header TestBlock)
aS = AnchoredFragment (Header TestBlock) -> Anchor (Header TestBlock)
forall v a b. AnchoredSeq v a b -> a
anchor AnchoredFragment (Header TestBlock)
preS
    asB :: WithOrigin SlotNo
asB = Anchor (Header TestBlock) -> WithOrigin SlotNo
forall block. Anchor block -> WithOrigin SlotNo
anchorToSlotNo Anchor (Header TestBlock)
aB
    asS :: WithOrigin SlotNo
asS = Anchor (Header TestBlock) -> WithOrigin SlotNo
forall block. Anchor block -> WithOrigin SlotNo
anchorToSlotNo Anchor (Header TestBlock)
aS
    l :: SlotNo
l = Header TestBlock -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header TestBlock
lower
    u :: SlotNo
u = Header TestBlock -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header TestBlock
upper
    overFork :: Bool
overFork = WithOrigin SlotNo
asS WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< WithOrigin SlotNo
asB Bool -> Bool -> Bool
&& Anchor (Header TestBlock)
aB Anchor (Header TestBlock) -> Anchor (Header TestBlock) -> Bool
forall a. Eq a => a -> a -> Bool
== AnchoredFragment (Header TestBlock) -> Anchor (Header TestBlock)
forall v a b. AnchoredSeq v a b -> a
anchor AnchoredFragment (Header TestBlock)
branch
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (SlotNo
u SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= SlotNo
l)
  (Range, Bool) -> Maybe (Range, Bool)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Int -> Range
Range (SlotNo -> Int
slotInt SlotNo
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (if Bool
overFork then Int
0 else Int
1)) (SlotNo -> Int
slotInt SlotNo
u Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1), Bool
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 :: Aspect -> AF.AnchoredFragment (Header TestBlock) -> TreeSlots -> TreeSlots
addFragRange :: Aspect
-> AnchoredFragment (Header TestBlock) -> TreeSlots -> TreeSlots
addFragRange Aspect
aspect AnchoredFragment (Header TestBlock)
selection TreeSlots {Int
lastSlot :: TreeSlots -> Int
lastSlot :: Int
lastSlot, [BranchSlots]
branches :: TreeSlots -> [BranchSlots]
branches :: [BranchSlots]
branches} =
  TreeSlots {Int
lastSlot :: Int
lastSlot :: Int
lastSlot, branches :: [BranchSlots]
branches = BranchSlots -> BranchSlots
forBranch (BranchSlots -> BranchSlots) -> [BranchSlots] -> [BranchSlots]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BranchSlots]
branches}
  where
    forBranch :: BranchSlots -> BranchSlots
forBranch branch :: BranchSlots
branch@BranchSlots {AnchoredFragment (Header TestBlock)
frag :: BranchSlots -> AnchoredFragment (Header TestBlock)
frag :: AnchoredFragment (Header TestBlock)
frag, Vector Slot
slots :: BranchSlots -> Vector Slot
slots :: Vector Slot
slots, [PeerId]
cands :: BranchSlots -> [PeerId]
cands :: [PeerId]
cands} =
      case AnchoredFragment (Header TestBlock)
-> AnchoredFragment (Header TestBlock) -> Maybe (Range, Bool)
commonRange AnchoredFragment (Header TestBlock)
frag AnchoredFragment (Header TestBlock)
selection of
        Just (Range
range, Bool
overFork) -> BranchSlots
branch {slots = addAspect aspect range overFork slots, cands = addCandidate cands}
        Maybe (Range, Bool)
_          -> BranchSlots
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 :: TreeSlots -> (PeerId, AF.AnchoredFragment (Header TestBlock)) -> TreeSlots
addCandidateRange :: TreeSlots
-> (PeerId, AnchoredFragment (Header TestBlock)) -> TreeSlots
addCandidateRange TreeSlots
treeSlots (PeerId
pid, AnchoredFragment (Header TestBlock)
candidate) =
  Aspect
-> AnchoredFragment (Header TestBlock) -> TreeSlots -> TreeSlots
addFragRange (PeerId -> Aspect
Candidate PeerId
pid) AnchoredFragment (Header TestBlock)
candidate TreeSlots
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 -> TreeSlots
addForks :: TreeSlots -> TreeSlots
addForks treeSlots :: TreeSlots
treeSlots@TreeSlots {[BranchSlots]
branches :: TreeSlots -> [BranchSlots]
branches :: [BranchSlots]
branches} =
  TreeSlots
treeSlots {branches = addFork <$> branches}
  where
    addFork :: BranchSlots -> BranchSlots
addFork fr :: BranchSlots
fr@BranchSlots {AnchoredFragment (Header TestBlock)
frag :: BranchSlots -> AnchoredFragment (Header TestBlock)
frag :: AnchoredFragment (Header TestBlock)
frag, Vector Slot
slots :: BranchSlots -> Vector Slot
slots :: Vector Slot
slots, Word64
forkNo :: BranchSlots -> Word64
forkNo :: Word64
forkNo}
      | Word64
forkNo Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0
      = BranchSlots
fr
      | Bool
otherwise
      = BranchSlots
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 TestBlock) -> WithOrigin SlotNo
forall block. Anchor block -> WithOrigin SlotNo
anchorToSlotNo (AnchoredFragment (Header TestBlock) -> Anchor (Header TestBlock)
forall v a b. AnchoredSeq v a b -> a
anchor AnchoredFragment (Header TestBlock)
frag)))

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

    tipForkNo :: Word64
tipForkNo = HeaderHash TestBlock -> Word64
hashForkNo (TestBlock -> HeaderHash TestBlock
forall b. HasHeader b => b -> HeaderHash b
blockHash TestBlock
b)

addTipPoint PeerId
_ WithOrigin TestBlock
_ TreeSlots
treeSlots = TreeSlots
treeSlots

addPoints :: Map PeerId (NodeState TestBlock) -> TreeSlots -> TreeSlots
addPoints :: Map PeerId (NodeState TestBlock) -> TreeSlots -> TreeSlots
addPoints Map PeerId (NodeState TestBlock)
peerPoints TreeSlots
treeSlots =
  (TreeSlots -> (PeerId, NodeState TestBlock) -> TreeSlots)
-> TreeSlots -> [(PeerId, NodeState TestBlock)] -> TreeSlots
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 -> (PeerId, NodeState TestBlock) -> TreeSlots
step TreeSlots
treeSlots (Map PeerId (NodeState TestBlock) -> [(PeerId, NodeState TestBlock)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PeerId (NodeState TestBlock)
peerPoints)
  where
    step :: TreeSlots -> (PeerId, NodeState TestBlock) -> TreeSlots
step TreeSlots
z (PeerId
pid, NodeState TestBlock
ap) = PeerId -> WithOrigin TestBlock -> TreeSlots -> TreeSlots
addTipPoint PeerId
pid (NodeState TestBlock -> WithOrigin TestBlock
forall blk. NodeState blk -> WithOrigin blk
nsTip NodeState TestBlock
ap) TreeSlots
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 -> NonEmpty Cell
branchCells :: BranchSlots -> NonEmpty Cell
branchCells BranchSlots {[PeerId]
cands :: BranchSlots -> [PeerId]
cands :: [PeerId]
cands, Vector Slot
slots :: BranchSlots -> 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 -> NonEmpty (NonEmpty Cell)
treeCells :: TreeSlots -> NonEmpty (NonEmpty Cell)
treeCells TreeSlots {Int
lastSlot :: TreeSlots -> Int
lastSlot :: Int
lastSlot, [BranchSlots]
branches :: TreeSlots -> [BranchSlots]
branches :: [BranchSlots]
branches} =
  Int -> NonEmpty Cell
slotNoCells Int
lastSlot NonEmpty Cell -> [NonEmpty Cell] -> NonEmpty (NonEmpty Cell)
forall a. a -> [a] -> NonEmpty a
:| (BranchSlots -> NonEmpty Cell
branchCells (BranchSlots -> NonEmpty Cell) -> [BranchSlots] -> [NonEmpty Cell]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BranchSlots]
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 =
  PeerSimState {
    PeerSimState -> BlockTree TestBlock
pssBlockTree  :: BlockTree TestBlock,
    PeerSimState -> AnchoredFragment (Header TestBlock)
pssSelection  :: AF.AnchoredFragment (Header TestBlock),
    PeerSimState -> Map PeerId (AnchoredFragment (Header TestBlock))
pssCandidates :: Map PeerId (AF.AnchoredFragment (Header TestBlock)),
    PeerSimState -> Map PeerId (NodeState TestBlock)
pssPoints     :: Map PeerId (NodeState TestBlock)
  }

-- 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 :: RenderConfig -> PeerSimState -> (String, Map PeerId Word64)
peerSimStateDiagramWith :: RenderConfig -> PeerSimState -> ([Char], Map PeerId Word64)
peerSimStateDiagramWith RenderConfig
config PeerSimState {BlockTree TestBlock
pssBlockTree :: PeerSimState -> BlockTree TestBlock
pssBlockTree :: BlockTree TestBlock
pssBlockTree, AnchoredFragment (Header TestBlock)
pssSelection :: PeerSimState -> AnchoredFragment (Header TestBlock)
pssSelection :: AnchoredFragment (Header TestBlock)
pssSelection, Map PeerId (AnchoredFragment (Header TestBlock))
pssCandidates :: PeerSimState -> Map PeerId (AnchoredFragment (Header TestBlock))
pssCandidates :: Map PeerId (AnchoredFragment (Header TestBlock))
pssCandidates, Map PeerId (NodeState TestBlock)
pssPoints :: PeerSimState -> Map PeerId (NodeState TestBlock)
pssPoints :: Map PeerId (NodeState TestBlock)
pssPoints} =
  [Char]
-> ([Char], Map PeerId Word64) -> ([Char], Map PeerId Word64)
forall a. [Char] -> a -> a
debugRender ([[Char]] -> [Char]
unlines (BlockTree TestBlock -> [[Char]]
forall blk. HasHeader blk => BlockTree blk -> [[Char]]
prettyBlockTree BlockTree TestBlock
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 -> NonEmpty (NonEmpty Cell)
treeCells (TreeSlots -> NonEmpty (NonEmpty Cell))
-> TreeSlots -> NonEmpty (NonEmpty Cell)
forall a b. (a -> b) -> a -> b
$
      Map PeerId (NodeState TestBlock) -> TreeSlots -> TreeSlots
addPoints Map PeerId (NodeState TestBlock)
pssPoints (TreeSlots -> TreeSlots) -> TreeSlots -> TreeSlots
forall a b. (a -> b) -> a -> b
$
      TreeSlots -> TreeSlots
addForks (TreeSlots -> TreeSlots) -> TreeSlots -> TreeSlots
forall a b. (a -> b) -> a -> b
$
      (TreeSlots
 -> [(PeerId, AnchoredFragment (Header TestBlock))] -> TreeSlots)
-> [(PeerId, AnchoredFragment (Header TestBlock))]
-> TreeSlots
-> TreeSlots
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((TreeSlots
 -> (PeerId, AnchoredFragment (Header TestBlock)) -> TreeSlots)
-> TreeSlots
-> [(PeerId, AnchoredFragment (Header TestBlock))]
-> TreeSlots
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
-> (PeerId, AnchoredFragment (Header TestBlock)) -> TreeSlots
addCandidateRange) (Map PeerId (AnchoredFragment (Header TestBlock))
-> [(PeerId, AnchoredFragment (Header TestBlock))]
forall k a. Map k a -> [(k, a)]
Map.toList Map PeerId (AnchoredFragment (Header TestBlock))
pssCandidates) (TreeSlots -> TreeSlots) -> TreeSlots -> TreeSlots
forall a b. (a -> b) -> a -> b
$
      Aspect
-> AnchoredFragment (Header TestBlock) -> TreeSlots -> TreeSlots
addFragRange Aspect
Selection AnchoredFragment (Header TestBlock)
pssSelection (TreeSlots -> TreeSlots) -> TreeSlots -> TreeSlots
forall a b. (a -> b) -> a -> b
$
      BlockTree TestBlock -> TreeSlots
initTree BlockTree TestBlock
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 :: PeerSimState -> String
peerSimStateDiagram :: PeerSimState -> [Char]
peerSimStateDiagram =
  ([Char], Map PeerId Word64) -> [Char]
forall a b. (a, b) -> a
fst (([Char], Map PeerId Word64) -> [Char])
-> (PeerSimState -> ([Char], Map PeerId Word64))
-> PeerSimState
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RenderConfig -> PeerSimState -> ([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 ::
  Tracer m String ->
  Tracer m PeerSimState
peerSimStateDiagramTracer :: forall (m :: * -> *). Tracer m [Char] -> Tracer m PeerSimState
peerSimStateDiagramTracer Tracer m [Char]
tracer =
  (PeerSimState -> m ()) -> Tracer m PeerSimState
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 -> [Char]) -> PeerSimState -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerSimState -> [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 =>
  Tracer m String ->
  BlockTree TestBlock ->
  STM m (AF.AnchoredFragment (Header TestBlock)) ->
  STM m (Map PeerId (AF.AnchoredFragment (Header TestBlock))) ->
  STM m (Map PeerId (Maybe (NodeState TestBlock))) ->
  m (Tracer m ())
peerSimStateDiagramSTMTracer :: forall (m :: * -> *).
IOLike m =>
Tracer m [Char]
-> BlockTree TestBlock
-> STM m (AnchoredFragment (Header TestBlock))
-> STM m (Map PeerId (AnchoredFragment (Header TestBlock)))
-> STM m (Map PeerId (Maybe (NodeState TestBlock)))
-> m (Tracer m ())
peerSimStateDiagramSTMTracer Tracer m [Char]
stringTracer BlockTree TestBlock
pssBlockTree STM m (AnchoredFragment (Header TestBlock))
selectionVar STM m (Map PeerId (AnchoredFragment (Header TestBlock)))
candidatesVar STM m (Map PeerId (Maybe (NodeState TestBlock)))
pointsVar = do
  StrictTVar m (Map PeerId Word64)
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
  Tracer m () -> m (Tracer m ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tracer m () -> m (Tracer m ())) -> Tracer m () -> m (Tracer m ())
forall a b. (a -> b) -> a -> b
$ (() -> m ()) -> Tracer m ()
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((() -> m ()) -> Tracer m ()) -> (() -> m ()) -> Tracer m ()
forall a b. (a -> b) -> a -> b
$ m () -> () -> m ()
forall a b. a -> b -> a
const (m () -> () -> m ()) -> m () -> () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    (PeerSimState
s, Map PeerId Word64
cachedPeers) <- STM m (PeerSimState, Map PeerId Word64)
-> m (PeerSimState, Map PeerId Word64)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (PeerSimState, Map PeerId Word64)
 -> m (PeerSimState, Map PeerId Word64))
-> STM m (PeerSimState, Map PeerId Word64)
-> m (PeerSimState, Map PeerId Word64)
forall a b. (a -> b) -> a -> b
$ do
      AnchoredFragment (Header TestBlock)
pssSelection <- STM m (AnchoredFragment (Header TestBlock))
selectionVar
      Map PeerId (AnchoredFragment (Header TestBlock))
pssCandidates <- STM m (Map PeerId (AnchoredFragment (Header TestBlock)))
candidatesVar
      Map PeerId (NodeState TestBlock)
pssPoints <- (Maybe (NodeState TestBlock) -> NodeState TestBlock)
-> Map PeerId (Maybe (NodeState TestBlock))
-> Map PeerId (NodeState TestBlock)
forall a b. (a -> b) -> Map PeerId a -> Map PeerId b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (NodeState TestBlock
-> Maybe (NodeState TestBlock) -> NodeState TestBlock
forall a. a -> Maybe a -> a
fromMaybe NodeState TestBlock
forall blk. NodeState blk
genesisNodeState) (Map PeerId (Maybe (NodeState TestBlock))
 -> Map PeerId (NodeState TestBlock))
-> STM m (Map PeerId (Maybe (NodeState TestBlock)))
-> STM m (Map PeerId (NodeState TestBlock))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (Map PeerId (Maybe (NodeState TestBlock)))
pointsVar
      Map PeerId Word64
cachedPeers <- StrictTVar m (Map PeerId Word64) -> STM m (Map PeerId Word64)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Map PeerId Word64)
peerCache
      (PeerSimState, Map PeerId Word64)
-> STM m (PeerSimState, Map PeerId Word64)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PeerSimState {BlockTree TestBlock
pssBlockTree :: BlockTree TestBlock
pssBlockTree :: BlockTree TestBlock
pssBlockTree, AnchoredFragment (Header TestBlock)
pssSelection :: AnchoredFragment (Header TestBlock)
pssSelection :: AnchoredFragment (Header TestBlock)
pssSelection, Map PeerId (AnchoredFragment (Header TestBlock))
pssCandidates :: Map PeerId (AnchoredFragment (Header TestBlock))
pssCandidates :: Map PeerId (AnchoredFragment (Header TestBlock))
pssCandidates, Map PeerId (NodeState TestBlock)
pssPoints :: Map PeerId (NodeState TestBlock)
pssPoints :: Map PeerId (NodeState TestBlock)
pssPoints}, Map PeerId Word64
cachedPeers)
    let ([Char]
blocks, Map PeerId Word64
newPeers) = RenderConfig -> PeerSimState -> ([Char], Map PeerId Word64)
peerSimStateDiagramWith (RenderConfig
defaultRenderConfig {cachedPeers}) PeerSimState
s
    STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar m (Map PeerId Word64)
-> (Map PeerId Word64 -> Map PeerId Word64) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m (Map PeerId Word64)
peerCache (Map PeerId Word64
newPeers Map PeerId Word64 -> Map PeerId Word64 -> Map PeerId Word64
forall a. Semigroup a => a -> a -> a
<>))
    Tracer m [Char] -> [Char] -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m [Char]
stringTracer [Char]
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 =>
  BlockTree TestBlock ->
  STM m (AF.AnchoredFragment (Header TestBlock)) ->
  STM m (Map PeerId (AF.AnchoredFragment (Header TestBlock))) ->
  STM m (Map PeerId (Maybe (NodeState TestBlock))) ->
  m (Tracer m ())
peerSimStateDiagramSTMTracerDebug :: forall (m :: * -> *).
IOLike m =>
BlockTree TestBlock
-> STM m (AnchoredFragment (Header TestBlock))
-> STM m (Map PeerId (AnchoredFragment (Header TestBlock)))
-> STM m (Map PeerId (Maybe (NodeState TestBlock)))
-> m (Tracer m ())
peerSimStateDiagramSTMTracerDebug =
  Tracer m [Char]
-> BlockTree TestBlock
-> STM m (AnchoredFragment (Header TestBlock))
-> STM m (Map PeerId (AnchoredFragment (Header TestBlock)))
-> STM m (Map PeerId (Maybe (NodeState TestBlock)))
-> m (Tracer m ())
forall (m :: * -> *).
IOLike m =>
Tracer m [Char]
-> BlockTree TestBlock
-> STM m (AnchoredFragment (Header TestBlock))
-> STM m (Map PeerId (AnchoredFragment (Header TestBlock)))
-> STM m (Map PeerId (Maybe (NodeState TestBlock)))
-> m (Tracer m ())
peerSimStateDiagramSTMTracer Tracer m [Char]
forall (m :: * -> *). Applicative m => Tracer m [Char]
debugTracer