{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# 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
  ( Terse (..)
  , terseAnchor
  , terseMaybe
  , terseRealPoint
  , 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
  )

terseRealPoint :: Terse blk => RealPoint blk -> String
terseRealPoint :: forall blk. Terse blk => RealPoint blk -> String
terseRealPoint = Point blk -> String
forall blk. Terse blk => Point blk -> String
tersePoint (Point blk -> String)
-> (RealPoint blk -> Point blk) -> RealPoint blk -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealPoint blk -> Point blk
forall blk. RealPoint blk -> Point blk
realPointToPoint

-- | Same as 'tersePoint' for anchors.
terseAnchor :: Terse blk => Anchor blk -> String
terseAnchor :: forall blk. Terse blk => Anchor blk -> String
terseAnchor = Point blk -> String
forall blk. Terse blk => Point blk -> String
tersePoint (Point blk -> String)
-> (Anchor blk -> Point blk) -> Anchor blk -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Anchor blk -> Point blk
forall block. Anchor block -> Point block
anchorToPoint

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

-- | 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.
class Terse blk where
  -- | Same as 'terseBlock' for points.
  tersePoint :: Point blk -> String

  -- | Print a fragment of 'TestBlock' in a terse way.
  terseFragment :: AnchoredFragment blk -> String

  -- | Same as 'terseFragment' for fragments of headers.
  terseHFragment :: AnchoredFragment (Header blk) -> String

  -- | Same as 'terseFragment' for fragments of headers with time.
  terseHWTFragment :: AnchoredFragment (HeaderWithTime blk) -> String

  terseBlock :: blk -> String

  -- | Same as 'tersePoint' for tips.
  terseTip :: Tip blk -> String

  -- | Same as 'terseBlock' for headers.
  terseHeader :: Header blk -> String

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

instance Terse TestBlock where
  terseHWTFragment :: AnchoredFragment (HeaderWithTime TestBlock) -> String
terseHWTFragment = AnchoredFragment (Header TestBlock) -> String
forall blk. Terse blk => AnchoredFragment (Header blk) -> 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
  terseHFragment :: AnchoredFragment (Header TestBlock) -> String
terseHFragment = AnchoredFragment TestBlock -> String
forall blk. Terse blk => AnchoredFragment blk -> 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)

  -- 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
fragment =
    Anchor TestBlock -> String
forall blk. Terse blk => Anchor blk -> 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
forall {b}. (HeaderHash b ~ TestHash, HasHeader b) => b -> String
terseBlock' [TestBlock]
blocks)
    terseBlock' :: b -> String
terseBlock' b
block = BlockNo -> SlotNo -> TestHash -> String
terseBlockSlotHash' (b -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo b
block) (b -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot b
block) (b -> HeaderHash b
forall b. HasHeader b => b -> HeaderHash b
blockHash b
block)
  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
  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
  terseHeader :: Header TestBlock -> String
terseHeader (TestHeader TestBlock
block) = TestBlock -> String
forall blk. Terse blk => blk -> String
terseBlock TestBlock
block

  -- 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
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)

-- | 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
"]"