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

module Ouroboros.Consensus.Util.Condense (
    Condense (..)
  , Condense1 (..)
  , condense1
  ) where

import qualified Data.ByteString as BS.Strict
import qualified Data.ByteString.Lazy as BS.Lazy
import           Data.Int
import           Data.List (intercalate)
import           Data.Map (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           Text.Printf (printf)

import           Control.Monad.Class.MonadTime (Time (..))

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           Ouroboros.Consensus.Util.HList (All, HList (..))
import qualified Ouroboros.Consensus.Util.HList as HList

-- Imports from lower-level libs to avoid circular dependencies
import           Cardano.Slotting.Block (BlockNo (..))
import           Cardano.Slotting.Slot (EpochNo (..), SlotNo (..),
                     WithOrigin (..))
import           Ouroboros.Network.Block (ChainHash (..), HeaderHash, Tip (..))

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

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

{-------------------------------------------------------------------------------
  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 :: f a -> String
condense1 = (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 :: (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 :: (a -> String) -> Set a -> String
liftCondense a -> String
f = (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 a (as :: [*]). a -> HList as -> HList (a : as)
:* b
b b -> HList '[] -> HList '[b]
forall a (as :: [*]). a -> HList as -> HList (a : 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 a (as :: [*]). a -> HList as -> HList (a : as)
:* b
b b -> HList '[c] -> HList '[b, c]
forall a (as :: [*]). a -> HList as -> HList (a : as)
:* c
c c -> HList '[] -> HList '[c]
forall a (as :: [*]). a -> HList as -> HList (a : 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 a (as :: [*]). a -> HList as -> HList (a : as)
:* b
b b -> HList '[c, d] -> HList '[b, c, d]
forall a (as :: [*]). a -> HList as -> HList (a : as)
:* c
c c -> HList '[d] -> HList '[c, d]
forall a (as :: [*]). a -> HList as -> HList (a : as)
:* d
d d -> HList '[] -> HList '[d]
forall a (as :: [*]). a -> HList as -> HList (a : 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 a (as :: [*]). a -> HList as -> HList (a : as)
:* b
b b -> HList '[c, d, e] -> HList '[b, c, d, e]
forall a (as :: [*]). a -> HList as -> HList (a : as)
:* c
c c -> HList '[d, e] -> HList '[c, d, e]
forall a (as :: [*]). a -> HList as -> HList (a : as)
:* d
d d -> HList '[e] -> HList '[d, e]
forall a (as :: [*]). a -> HList as -> HList (a : as)
:* e
e e -> HList '[] -> HList '[e]
forall a (as :: [*]). a -> HList as -> HList (a : 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 (Proxy Condense
forall k (t :: k). Proxy t
Proxy @Condense) forall a. Condense a => a -> String
condense HList as
as) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

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

{-------------------------------------------------------------------------------
  Orphans 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 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 s) = Signature -> String
forall a. Show a => a -> String
show Signature
s

instance Condense (SigDSIGN MockDSIGN) where
  condense :: SigDSIGN MockDSIGN -> String
condense (SigMockDSIGN _ 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 n (SignKeyMockKES (VerKeyMockKES v) 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 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 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 sk vk1 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 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 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