{-# LANGUAGE TypeFamilies #-}

-- | Helpers for printing various objects in a terse way. Terse printing is
-- similar to that provided by the 'Condense' typeclass except it can be
-- sometimes even more compact and it is very specific to tests.
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
  )

-- | Run-length encoding of a list. This groups consecutive duplicate elements,
-- counting them. Only the first element of the equality is kept. For instance:
--
-- > runLengthEncoding [0, 0, 1, 0, 2, 2, 2] = [(2, 0), (1, 1), (1, 0), (3, 2)]
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]

-- | Print the given 'BlockNo', 'SlotNo' and 'TestHash' in a terse way:
-- @block-slot[hash]@. @hash@ only shows if there is a non-zero element in it.
-- When it shows, it shows in a compact form. For instance, the hash
-- @[0,0,1,0,0,0]@ shows as @[2x0,1,3x0]@. This function is meant as a helper
-- for other functions.
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

-- | Same as 'terseBlockSlotHash' except only the last element of the hash
-- shows, if it is non-zero. This makes sense when showing a fragment.
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
"]"

-- | Print a 'TestBlock' as @block-slot[hash]@. @hash@ only shows if there is a
-- non-zero element in it. When it shows, it shows in a compact form. For
-- instance, the hash @[0,0,1,0,0,0]@ shows as @[2x0,1,3x0]@.
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)

-- | Same as 'terseBlock' except only the last element of the hash shows, if it
-- is non-zero. This makes sense when showing a fragment.
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)

-- | Same as 'terseBlock' for headers.
terseHeader :: Header TestBlock -> String
terseHeader :: Header TestBlock -> String
terseHeader (TestHeader TestBlock
block) = TestBlock -> String
terseBlock TestBlock
block

-- | Same as 'terseBlock' for points. Genesis shows as @G@.
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

-- | Same as 'tersePoint' for anchors.
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

-- | Same as 'tersePoint' for tips.
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

-- | Given a printer for elements of type @a@, prints a @WithOrigin a@ in a
-- terse way. Origin shows as @G@.
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

-- | Print a fragment of 'TestBlock' in a terse way. This shows as @anchor |
-- block ...@ where @anchor@ is printed with 'terseAnchor' and @block@s are
-- printed with @terseBlock'@; in particular, only the last element of the hash
-- shows and only when it is non-zero.
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)

-- | Same as 'terseFragment' for fragments of headers.
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)

-- | Same as 'terseFragment' for fragments of headers with time.
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

-- | Same as 'terseWithOrigin' for 'Maybe'.
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