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