{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}

module Ouroboros.Consensus.Util.Condense (
    Condense (..)
  , Condense1 (..)
  , CondenseList (..)
  , PaddingDirection (..)
  , condense1
  , condenseListWithPadding
  , padListWith
  ) where

import           Cardano.Crypto.DSIGN (Ed25519DSIGN, Ed448DSIGN, MockDSIGN,
                     SigDSIGN, SignedDSIGN (..), VerKeyDSIGN,
                     pattern SigEd25519DSIGN, pattern SigEd448DSIGN,
                     pattern SigMockDSIGN)
import           Cardano.Crypto.Hash (Hash)
import           Cardano.Crypto.KES (MockKES, NeverKES, SigKES, SignedKES (..),
                     SimpleKES, SingleKES, SumKES, VerKeyKES,
                     pattern SigMockKES, pattern SigSimpleKES,
                     pattern SigSingleKES, pattern SigSumKES,
                     pattern SignKeyMockKES, pattern VerKeyMockKES,
                     pattern VerKeySingleKES, pattern VerKeySumKES)
import           Cardano.Slotting.Slot (EpochNo (..), WithOrigin (..))
import           Control.Monad.Class.MonadTime.SI (Time (..))
import qualified Data.ByteString as BS.Strict
import qualified Data.ByteString.Lazy as BS.Lazy
import           Data.Int
import           Data.List (intercalate, maximumBy)
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Proxy
import           Data.Set (Set)
import qualified Data.Set as Set
import           Data.Text (Text, unpack)
import           Data.Void
import           Data.Word
import           Numeric.Natural
import           Ouroboros.Consensus.Util.HList (All, HList (..))
import qualified Ouroboros.Consensus.Util.HList as HList
import           Ouroboros.Network.AnchoredFragment (AnchoredFragment)
import qualified Ouroboros.Network.AnchoredFragment as AF
import           Ouroboros.Network.Block
import           Ouroboros.Network.Mock.Chain hiding (length)
import           Text.Printf (printf)

{-------------------------------------------------------------------------------
  Main class
-------------------------------------------------------------------------------}

-- | Condensed but human-readable output
class Condense a where
  condense :: a -> String

-- | Human-readable list of condensed strings.
-- All result strings have the same length, for alignment purposes.
class CondenseList a where
  condenseList :: [a] -> [String]

condenseListWithPadding :: Condense a => PaddingDirection -> [a] -> [String]
condenseListWithPadding :: forall a. Condense a => PaddingDirection -> [a] -> [String]
condenseListWithPadding PaddingDirection
padding [a]
as = PaddingDirection -> [String] -> [String]
padListWith PaddingDirection
padding ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Condense a => a -> String
condense (a -> String) -> [a] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
as

padListWith :: PaddingDirection -> [String] -> [String]
padListWith :: PaddingDirection -> [String] -> [String]
padListWith PaddingDirection
padding [String]
strings =
  let maxLength :: Int
maxLength = (Int -> Int -> Ordering) -> [Int] -> Int
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int) -> [String] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
strings
  in
    (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
      (\String
c ->
        let spaces :: String
spaces = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
maxLength Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
c) Char
' '
        in case PaddingDirection
padding of
          PaddingDirection
PadLeft  -> String
spaces String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c
          PaddingDirection
PadRight -> String
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
spaces
      )
      [String]
strings

data PaddingDirection = PadLeft | PadRight

{-------------------------------------------------------------------------------
  Rank-1 types
-------------------------------------------------------------------------------}

class Condense1 f where
  liftCondense :: (a -> String) -> f a -> String

-- | Lift the standard 'condense' function through the type constructor
condense1 :: (Condense1 f, Condense a) => f a -> String
condense1 :: forall (f :: * -> *) a. (Condense1 f, Condense a) => f a -> String
condense1 = (a -> String) -> f a -> String
forall a. (a -> String) -> f a -> String
forall (f :: * -> *) a.
Condense1 f =>
(a -> String) -> f a -> String
liftCondense a -> String
forall a. Condense a => a -> String
condense

{-------------------------------------------------------------------------------
  Instances for standard types
-------------------------------------------------------------------------------}

instance Condense Void where
  condense :: Void -> String
condense = Void -> String
forall a. Void -> a
absurd

instance Condense Text where
  condense :: Text -> String
condense = Text -> String
unpack

instance Condense Bool where
  condense :: Bool -> String
condense = Bool -> String
forall a. Show a => a -> String
show

instance Condense Int where
  condense :: Int -> String
condense = Int -> String
forall a. Show a => a -> String
show

instance Condense Int64 where
  condense :: Int64 -> String
condense = Int64 -> String
forall a. Show a => a -> String
show

instance Condense Word where
  condense :: Word -> String
condense = Word -> String
forall a. Show a => a -> String
show

instance Condense Word32 where
  condense :: Word32 -> String
condense = Word32 -> String
forall a. Show a => a -> String
show

instance Condense Word64 where
  condense :: Word64 -> String
condense = Word64 -> String
forall a. Show a => a -> String
show

instance Condense Natural where
  condense :: Natural -> String
condense = Natural -> String
forall a. Show a => a -> String
show

instance Condense Rational where
  condense :: Rational -> String
condense = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.8f" (Double -> String) -> (Rational -> Double) -> Rational -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational :: Rational -> Double)

instance Condense1 [] where
  liftCondense :: forall a. (a -> String) -> [a] -> String
liftCondense a -> String
f [a]
as = String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ((a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map a -> String
f [a]
as) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"

instance Condense1 Set where
  liftCondense :: forall a. (a -> String) -> Set a -> String
liftCondense a -> String
f = (a -> String) -> [a] -> String
forall a. (a -> String) -> [a] -> String
forall (f :: * -> *) a.
Condense1 f =>
(a -> String) -> f a -> String
liftCondense a -> String
f ([a] -> String) -> (Set a -> [a]) -> Set a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set a -> [a]
forall a. Set a -> [a]
Set.toList

instance Condense a => Condense [a] where
  condense :: [a] -> String
condense = [a] -> String
forall (f :: * -> *) a. (Condense1 f, Condense a) => f a -> String
condense1

instance Condense a => Condense (Maybe a) where
  condense :: Maybe a -> String
condense (Just a
a) = String
"Just " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Condense a => a -> String
condense a
a
  condense Maybe a
Nothing  = String
"Nothing"

instance Condense a => Condense (Set a) where
  condense :: Set a -> String
condense = Set a -> String
forall (f :: * -> *) a. (Condense1 f, Condense a) => f a -> String
condense1

instance (Condense a, Condense b) => Condense (a, b) where
  condense :: (a, b) -> String
condense (a
a, b
b) = HList '[a, b] -> String
forall a. Condense a => a -> String
condense (a
a a -> HList '[b] -> HList '[a, b]
forall a1 (as :: [*]). a1 -> HList as -> HList (a1 : as)
:* b
b b -> HList '[] -> HList '[b]
forall a1 (as :: [*]). a1 -> HList as -> HList (a1 : as)
:* HList '[]
Nil)

instance (Condense a, Condense b, Condense c) => Condense (a, b, c) where
  condense :: (a, b, c) -> String
condense (a
a, b
b, c
c) = HList '[a, b, c] -> String
forall a. Condense a => a -> String
condense (a
a a -> HList '[b, c] -> HList '[a, b, c]
forall a1 (as :: [*]). a1 -> HList as -> HList (a1 : as)
:* b
b b -> HList '[c] -> HList '[b, c]
forall a1 (as :: [*]). a1 -> HList as -> HList (a1 : as)
:* c
c c -> HList '[] -> HList '[c]
forall a1 (as :: [*]). a1 -> HList as -> HList (a1 : as)
:* HList '[]
Nil)

instance (Condense a, Condense b, Condense c, Condense d) => Condense (a, b, c, d) where
  condense :: (a, b, c, d) -> String
condense (a
a, b
b, c
c, d
d) = HList '[a, b, c, d] -> String
forall a. Condense a => a -> String
condense (a
a a -> HList '[b, c, d] -> HList '[a, b, c, d]
forall a1 (as :: [*]). a1 -> HList as -> HList (a1 : as)
:* b
b b -> HList '[c, d] -> HList '[b, c, d]
forall a1 (as :: [*]). a1 -> HList as -> HList (a1 : as)
:* c
c c -> HList '[d] -> HList '[c, d]
forall a1 (as :: [*]). a1 -> HList as -> HList (a1 : as)
:* d
d d -> HList '[] -> HList '[d]
forall a1 (as :: [*]). a1 -> HList as -> HList (a1 : as)
:* HList '[]
Nil)

instance (Condense a, Condense b, Condense c, Condense d, Condense e) => Condense (a, b, c, d, e) where
  condense :: (a, b, c, d, e) -> String
condense (a
a, b
b, c
c, d
d, e
e) = HList '[a, b, c, d, e] -> String
forall a. Condense a => a -> String
condense (a
a a -> HList '[b, c, d, e] -> HList '[a, b, c, d, e]
forall a1 (as :: [*]). a1 -> HList as -> HList (a1 : as)
:* b
b b -> HList '[c, d, e] -> HList '[b, c, d, e]
forall a1 (as :: [*]). a1 -> HList as -> HList (a1 : as)
:* c
c c -> HList '[d, e] -> HList '[c, d, e]
forall a1 (as :: [*]). a1 -> HList as -> HList (a1 : as)
:* d
d d -> HList '[e] -> HList '[d, e]
forall a1 (as :: [*]). a1 -> HList as -> HList (a1 : as)
:* e
e e -> HList '[] -> HList '[e]
forall a1 (as :: [*]). a1 -> HList as -> HList (a1 : as)
:* HList '[]
Nil)

instance (Condense k, Condense a) => Condense (Map k a) where
  condense :: Map k a -> String
condense = [(k, a)] -> String
forall a. Condense a => a -> String
condense ([(k, a)] -> String) -> (Map k a -> [(k, a)]) -> Map k a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map k a -> [(k, a)]
forall k a. Map k a -> [(k, a)]
Map.toList

instance Condense BS.Strict.ByteString where
  condense :: ByteString -> String
condense ByteString
bs = ByteString -> String
forall a. Show a => a -> String
show ByteString
bs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"<" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (ByteString -> Int
BS.Strict.length ByteString
bs) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"b>"

instance Condense BS.Lazy.ByteString where
  condense :: ByteString -> String
condense ByteString
bs = ByteString -> String
forall a. Show a => a -> String
show ByteString
bs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"<" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int64 -> String
forall a. Show a => a -> String
show (ByteString -> Int64
BS.Lazy.length ByteString
bs) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"b>"

{-------------------------------------------------------------------------------
  Consensus specific general purpose types
-------------------------------------------------------------------------------}

instance All Condense as => Condense (HList as) where
  condense :: HList as -> String
condense HList as
as = String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," (Proxy Condense
-> (forall a. Condense a => a -> String) -> HList as -> [String]
forall (c :: * -> Constraint) (as :: [*]) b
       (proxy :: (* -> Constraint) -> *).
All c as =>
proxy c -> (forall a. c a => a -> b) -> HList as -> [b]
HList.collapse (forall {k} (t :: k). Proxy t
forall (t :: * -> Constraint). Proxy t
Proxy @Condense) a -> String
forall a. Condense a => a -> String
condense HList as
as) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

{-------------------------------------------------------------------------------
  Instances for ouroboros-network
-------------------------------------------------------------------------------}

instance Condense BlockNo where
  condense :: BlockNo -> String
condense (BlockNo Word64
n) = Word64 -> String
forall a. Show a => a -> String
show Word64
n

instance Condense SlotNo where
  condense :: SlotNo -> String
condense (SlotNo Word64
n) = Word64 -> String
forall a. Show a => a -> String
show Word64
n

instance Condense EpochNo where
  condense :: EpochNo -> String
condense (EpochNo Word64
n) = Word64 -> String
forall a. Show a => a -> String
show Word64
n

instance Condense (HeaderHash b) => Condense (ChainHash b) where
  condense :: ChainHash b -> String
condense ChainHash b
GenesisHash   = String
"genesis"
  condense (BlockHash HeaderHash b
h) = HeaderHash b -> String
forall a. Condense a => a -> String
condense HeaderHash b
h

instance Condense (HeaderHash b) => Condense (Tip b) where
  condense :: Tip b -> String
condense Tip b
TipGenesis       = String
"genesis"
  condense (Tip SlotNo
slot HeaderHash b
h BlockNo
bno) =
      String
"b" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> BlockNo -> String
forall a. Condense a => a -> String
condense BlockNo
bno String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"-s" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SlotNo -> String
forall a. Condense a => a -> String
condense SlotNo
slot String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"-h" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HeaderHash b -> String
forall a. Condense a => a -> String
condense HeaderHash b
h

instance Condense a => Condense (WithOrigin a) where
  condense :: WithOrigin a -> String
condense WithOrigin a
Origin = String
"origin"
  condense (At a
a) = a -> String
forall a. Condense a => a -> String
condense a
a

instance Condense (HeaderHash block) => Condense (Point block) where
    condense :: Point block -> String
condense Point block
GenesisPoint     = String
"Origin"
    condense (BlockPoint SlotNo
s HeaderHash block
h) = String
"(Point " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SlotNo -> String
forall a. Condense a => a -> String
condense SlotNo
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HeaderHash block -> String
forall a. Condense a => a -> String
condense HeaderHash block
h String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"

instance Condense block => Condense (Chain block) where
    condense :: Chain block -> String
condense Chain block
Genesis   = String
"Genesis"
    condense (Chain block
cs :> block
b) = Chain block -> String
forall a. Condense a => a -> String
condense Chain block
cs String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" :> " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> block -> String
forall a. Condense a => a -> String
condense block
b

instance (Condense block, HasHeader block, Condense (HeaderHash block))
    => Condense (AnchoredFragment block) where
    condense :: AnchoredFragment block -> String
condense (AF.Empty Anchor block
pt) = String
"EmptyAnchor " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Point block -> String
forall a. Condense a => a -> String
condense (Anchor block -> Point block
forall block. Anchor block -> Point block
AF.anchorToPoint Anchor block
pt)
    condense (AnchoredFragment block
cs AF.:> block
b)  = AnchoredFragment block -> String
forall a. Condense a => a -> String
condense AnchoredFragment block
cs String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" :> " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> block -> String
forall a. Condense a => a -> String
condense block
b

{-------------------------------------------------------------------------------
  Instances for cardano-crypto-classes
-------------------------------------------------------------------------------}

instance Condense (SigDSIGN v) => Condense (SignedDSIGN v a) where
  condense :: SignedDSIGN v a -> String
condense (SignedDSIGN SigDSIGN v
sig) = SigDSIGN v -> String
forall a. Condense a => a -> String
condense SigDSIGN v
sig

instance Condense (SigDSIGN Ed25519DSIGN) where
  condense :: SigDSIGN Ed25519DSIGN -> String
condense (SigEd25519DSIGN PinnedSizedBytes (SizeSigDSIGN Ed25519DSIGN)
s) = PinnedSizedBytes CRYPTO_SIGN_ED25519_BYTES -> String
forall a. Show a => a -> String
show PinnedSizedBytes CRYPTO_SIGN_ED25519_BYTES
PinnedSizedBytes (SizeSigDSIGN Ed25519DSIGN)
s

instance Condense (SigDSIGN Ed448DSIGN) where
  condense :: SigDSIGN Ed448DSIGN -> String
condense (SigEd448DSIGN Signature
s) = Signature -> String
forall a. Show a => a -> String
show Signature
s

instance Condense (SigDSIGN MockDSIGN) where
  condense :: SigDSIGN MockDSIGN -> String
condense (SigMockDSIGN Hash ShortHash ()
_ Word64
i) = Word64 -> String
forall a. Show a => a -> String
show Word64
i

instance Condense (SigKES v) => Condense (SignedKES v a) where
  condense :: SignedKES v a -> String
condense (SignedKES SigKES v
sig) = SigKES v -> String
forall a. Condense a => a -> String
condense SigKES v
sig

instance Condense (SigKES (MockKES t)) where
    condense :: SigKES (MockKES t) -> String
condense (SigMockKES Hash ShortHash ()
n (SignKeyMockKES (VerKeyMockKES Word64
v) Word
j)) =
           Hash ShortHash () -> String
forall a. Show a => a -> String
show Hash ShortHash ()
n
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":"
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Word64 -> String
forall a. Show a => a -> String
show Word64
v
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":"
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Word -> String
forall a. Show a => a -> String
show Word
j

instance Condense (SigKES NeverKES) where
  condense :: SigKES NeverKES -> String
condense = SigKES NeverKES -> String
forall a. Show a => a -> String
show

instance Condense (SigDSIGN d) => Condense (SigKES (SimpleKES d t)) where
    condense :: SigKES (SimpleKES d t) -> String
condense (SigSimpleKES SigDSIGN d
sig) = SigDSIGN d -> String
forall a. Condense a => a -> String
condense SigDSIGN d
sig

instance Condense (SigDSIGN d) => Condense (SigKES (SingleKES d)) where
    condense :: SigKES (SingleKES d) -> String
condense (SigSingleKES SigDSIGN d
sig) = SigDSIGN d -> String
forall a. Condense a => a -> String
condense SigDSIGN d
sig

instance Show (VerKeyDSIGN d) => Condense (VerKeyDSIGN d) where
  condense :: VerKeyDSIGN d -> String
condense = VerKeyDSIGN d -> String
forall a. Show a => a -> String
show

instance (Condense (SigKES d), Condense (VerKeyKES d))
  => Condense (SigKES (SumKES h d)) where
    condense :: SigKES (SumKES h d) -> String
condense (SigSumKES SigKES d
sk VerKeyKES d
vk1 VerKeyKES d
vk2) = (SigKES d, VerKeyKES d, VerKeyKES d) -> String
forall a. Condense a => a -> String
condense (SigKES d
sk, VerKeyKES d
vk1, VerKeyKES d
vk2)

instance Condense (VerKeyDSIGN d) => Condense (VerKeyKES (SingleKES d)) where
    condense :: VerKeyKES (SingleKES d) -> String
condense (VerKeySingleKES VerKeyDSIGN d
h) = VerKeyDSIGN d -> String
forall a. Condense a => a -> String
condense VerKeyDSIGN d
h

instance Condense (VerKeyKES (SumKES h d)) where
    condense :: VerKeyKES (SumKES h d) -> String
condense (VerKeySumKES Hash h (VerKeyKES d, VerKeyKES d)
h) = Hash h (VerKeyKES d, VerKeyKES d) -> String
forall a. Condense a => a -> String
condense Hash h (VerKeyKES d, VerKeyKES d)
h

instance Condense (Hash h a) where
    condense :: Hash h a -> String
condense = Hash h a -> String
forall a. Show a => a -> String
show

instance Condense Time where
    condense :: Time -> String
condense (Time DiffTime
dt) = DiffTime -> String
forall a. Show a => a -> String
show DiffTime
dt