{-# LANGUAGE TypeFamilies #-}
module Test.Util.TersePrinting
( terseAnchor
, terseBlock
, terseFragment
, terseHFragment
, terseHWTFragment
, terseHeader
, terseMaybe
, tersePoint
, terseRealPoint
, terseTip
, terseWithOrigin
) where
import Cardano.Slotting.Block (BlockNo (BlockNo))
import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty ((:|)), toList)
import qualified Data.List.NonEmpty as NE
import Ouroboros.Consensus.Block
( Header
, Point (BlockPoint, GenesisPoint)
, RealPoint
, SlotNo (SlotNo)
, blockHash
, blockNo
, blockSlot
, realPointToPoint
)
import Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..))
import Ouroboros.Network.AnchoredFragment
( Anchor
, AnchoredFragment
, anchor
, anchorToPoint
, mapAnchoredFragment
, toOldestFirst
)
import Ouroboros.Network.Block (Tip (..))
import Ouroboros.Network.Point (WithOrigin (..))
import Test.Util.TestBlock
( Header (TestHeader)
, TestBlock
, TestHash (TestHash)
, unTestHash
)
runLengthEncoding :: Eq a => [a] -> [(Int, a)]
runLengthEncoding :: forall a. Eq a => [a] -> [(Int, a)]
runLengthEncoding [a]
xs = [(NonEmpty a -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty a
ys, NonEmpty a -> a
forall a. NonEmpty a -> a
NE.head NonEmpty a
ys) | NonEmpty a
ys <- [a] -> [NonEmpty a]
forall (f :: * -> *) a. (Foldable f, Eq a) => f a -> [NonEmpty a]
NE.group [a]
xs]
terseBlockSlotHash :: BlockNo -> SlotNo -> TestHash -> String
terseBlockSlotHash :: BlockNo -> SlotNo -> TestHash -> String
terseBlockSlotHash (BlockNo Word64
bno) (SlotNo Word64
sno) (TestHash NonEmpty Word64
hash) =
Word64 -> String
forall a. Show a => a -> String
show Word64
bno String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show Word64
sno String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
renderHash
where
renderHash :: String
renderHash = case [Word64] -> [(Int, Word64)]
forall a. Eq a => [a] -> [(Int, a)]
runLengthEncoding ([Word64] -> [Word64]
forall a. [a] -> [a]
reverse (NonEmpty Word64 -> [Word64]
forall a. NonEmpty a -> [a]
toList NonEmpty Word64
hash)) of
[(Int
_, Word64
0)] -> String
""
[(Int, Word64)]
hashGrouped -> String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," (((Int, Word64) -> String) -> [(Int, Word64)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Word64) -> String
forall {a} {a}. (Eq a, Num a, Show a, Show a) => (a, a) -> String
renderGroup [(Int, Word64)]
hashGrouped) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
renderGroup :: (a, a) -> String
renderGroup (a
1, a
e) = a -> String
forall a. Show a => a -> String
show a
e
renderGroup (a
n, a
e) = a -> String
forall a. Show a => a -> String
show a
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
e
terseBlockSlotHash' :: BlockNo -> SlotNo -> TestHash -> String
terseBlockSlotHash' :: BlockNo -> SlotNo -> TestHash -> String
terseBlockSlotHash' (BlockNo Word64
bno) (SlotNo Word64
sno) (TestHash NonEmpty Word64
hash) =
Word64 -> String
forall a. Show a => a -> String
show Word64
bno String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show Word64
sno String -> String -> String
forall a. [a] -> [a] -> [a]
++ NonEmpty Word64 -> String
forall {a}. (Eq a, Num a, Show a) => NonEmpty a -> String
renderHashSuffix NonEmpty Word64
hash
where
renderHashSuffix :: NonEmpty a -> String
renderHashSuffix (a
forkNo :| [a]
_)
| a
forkNo a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 = String
""
| Bool
otherwise = String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
forkNo String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
terseBlock :: TestBlock -> String
terseBlock :: TestBlock -> String
terseBlock TestBlock
block = BlockNo -> SlotNo -> TestHash -> String
terseBlockSlotHash (TestBlock -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo TestBlock
block) (TestBlock -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot TestBlock
block) (TestBlock -> HeaderHash TestBlock
forall b. HasHeader b => b -> HeaderHash b
blockHash TestBlock
block)
terseBlock' :: TestBlock -> String
terseBlock' :: TestBlock -> String
terseBlock' TestBlock
block = BlockNo -> SlotNo -> TestHash -> String
terseBlockSlotHash' (TestBlock -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo TestBlock
block) (TestBlock -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot TestBlock
block) (TestBlock -> HeaderHash TestBlock
forall b. HasHeader b => b -> HeaderHash b
blockHash TestBlock
block)
terseHeader :: Header TestBlock -> String
(TestHeader TestBlock
block) = TestBlock -> String
terseBlock TestBlock
block
tersePoint :: Point TestBlock -> String
tersePoint :: Point TestBlock -> String
tersePoint Point TestBlock
GenesisPoint = String
"G"
tersePoint (BlockPoint SlotNo
slot HeaderHash TestBlock
hash) =
BlockNo -> SlotNo -> TestHash -> String
terseBlockSlotHash (Word64 -> BlockNo
BlockNo (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (NonEmpty Word64 -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (TestHash -> NonEmpty Word64
unTestHash HeaderHash TestBlock
TestHash
hash)))) SlotNo
slot HeaderHash TestBlock
TestHash
hash
terseRealPoint :: RealPoint TestBlock -> String
terseRealPoint :: RealPoint TestBlock -> String
terseRealPoint = Point TestBlock -> String
tersePoint (Point TestBlock -> String)
-> (RealPoint TestBlock -> Point TestBlock)
-> RealPoint TestBlock
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealPoint TestBlock -> Point TestBlock
forall blk. RealPoint blk -> Point blk
realPointToPoint
terseAnchor :: Anchor TestBlock -> String
terseAnchor :: Anchor TestBlock -> String
terseAnchor = Point TestBlock -> String
tersePoint (Point TestBlock -> String)
-> (Anchor TestBlock -> Point TestBlock)
-> Anchor TestBlock
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Anchor TestBlock -> Point TestBlock
forall block. Anchor block -> Point block
anchorToPoint
terseTip :: Tip TestBlock -> String
terseTip :: Tip TestBlock -> String
terseTip Tip TestBlock
TipGenesis = String
"G"
terseTip (Tip SlotNo
sno HeaderHash TestBlock
hash BlockNo
bno) = BlockNo -> SlotNo -> TestHash -> String
terseBlockSlotHash BlockNo
bno SlotNo
sno HeaderHash TestBlock
TestHash
hash
terseWithOrigin :: (a -> String) -> WithOrigin a -> String
terseWithOrigin :: forall a. (a -> String) -> WithOrigin a -> String
terseWithOrigin a -> String
_ WithOrigin a
Origin = String
"G"
terseWithOrigin a -> String
terseA (At a
a) = a -> String
terseA a
a
terseFragment :: AnchoredFragment TestBlock -> String
terseFragment :: AnchoredFragment TestBlock -> String
terseFragment AnchoredFragment TestBlock
fragment =
Anchor TestBlock -> String
terseAnchor (AnchoredFragment TestBlock -> Anchor TestBlock
forall v a b. AnchoredSeq v a b -> a
anchor AnchoredFragment TestBlock
fragment) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
renderBlocks
where
renderBlocks :: String
renderBlocks = case AnchoredFragment TestBlock -> [TestBlock]
forall v a b. AnchoredSeq v a b -> [b]
toOldestFirst AnchoredFragment TestBlock
fragment of
[] -> String
""
[TestBlock]
blocks -> String
" | " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords ((TestBlock -> String) -> [TestBlock] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map TestBlock -> String
terseBlock' [TestBlock]
blocks)
terseHFragment :: AnchoredFragment (Header TestBlock) -> String
terseHFragment :: AnchoredFragment (Header TestBlock) -> String
terseHFragment = AnchoredFragment TestBlock -> String
terseFragment (AnchoredFragment TestBlock -> String)
-> (AnchoredFragment (Header TestBlock)
-> AnchoredFragment TestBlock)
-> AnchoredFragment (Header TestBlock)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Header TestBlock -> TestBlock)
-> AnchoredFragment (Header TestBlock)
-> AnchoredFragment TestBlock
forall block2 block1.
(HasHeader block2, HeaderHash block1 ~ HeaderHash block2) =>
(block1 -> block2)
-> AnchoredFragment block1 -> AnchoredFragment block2
mapAnchoredFragment (\(TestHeader TestBlock
block) -> TestBlock
block)
terseHWTFragment :: AnchoredFragment (HeaderWithTime TestBlock) -> String
terseHWTFragment :: AnchoredFragment (HeaderWithTime TestBlock) -> String
terseHWTFragment = AnchoredFragment (Header TestBlock) -> String
terseHFragment (AnchoredFragment (Header TestBlock) -> String)
-> (AnchoredFragment (HeaderWithTime TestBlock)
-> AnchoredFragment (Header TestBlock))
-> AnchoredFragment (HeaderWithTime TestBlock)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderWithTime TestBlock -> Header TestBlock)
-> AnchoredFragment (HeaderWithTime TestBlock)
-> AnchoredFragment (Header TestBlock)
forall block2 block1.
(HasHeader block2, HeaderHash block1 ~ HeaderHash block2) =>
(block1 -> block2)
-> AnchoredFragment block1 -> AnchoredFragment block2
mapAnchoredFragment HeaderWithTime TestBlock -> Header TestBlock
forall blk. HeaderWithTime blk -> Header blk
hwtHeader
terseMaybe :: (a -> String) -> Maybe a -> String
terseMaybe :: forall a. (a -> String) -> Maybe a -> String
terseMaybe a -> String
_ Maybe a
Nothing = String
"X"
terseMaybe a -> String
terseA (Just a
a) = a -> String
terseA a
a