{-# LANGUAGE DeriveAnyClass     #-}
{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase         #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE TemplateHaskell    #-}
module Cardano.Node.Emulator.LogMessages where

import Cardano.Api qualified as C
import Cardano.Node.Emulator.Internal.Node.Chain (ChainEvent)
import Control.Lens.TH (makePrisms)
import Data.Aeson (FromJSON, ToJSON, Value)
import Data.Map qualified as Map
import GHC.Generics (Generic)
import Ledger (CardanoTx, getCardanoTxId)
import Ledger.Index (UtxoIndex, ValidationError, ValidationPhase)
import Ledger.Tx.CardanoAPI (CardanoBuildTx)
import Prettyprinter (Pretty (pretty), colon, hang, viaShow, vsep, (<+>))

data EmulatorMsg
    = GenericMsg Value
    | TxBalanceMsg TxBalanceMsg
    | ChainEvent ChainEvent
    deriving stock (EmulatorMsg -> EmulatorMsg -> Bool
(EmulatorMsg -> EmulatorMsg -> Bool)
-> (EmulatorMsg -> EmulatorMsg -> Bool) -> Eq EmulatorMsg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EmulatorMsg -> EmulatorMsg -> Bool
$c/= :: EmulatorMsg -> EmulatorMsg -> Bool
== :: EmulatorMsg -> EmulatorMsg -> Bool
$c== :: EmulatorMsg -> EmulatorMsg -> Bool
Eq, Int -> EmulatorMsg -> ShowS
[EmulatorMsg] -> ShowS
EmulatorMsg -> String
(Int -> EmulatorMsg -> ShowS)
-> (EmulatorMsg -> String)
-> ([EmulatorMsg] -> ShowS)
-> Show EmulatorMsg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EmulatorMsg] -> ShowS
$cshowList :: [EmulatorMsg] -> ShowS
show :: EmulatorMsg -> String
$cshow :: EmulatorMsg -> String
showsPrec :: Int -> EmulatorMsg -> ShowS
$cshowsPrec :: Int -> EmulatorMsg -> ShowS
Show, (forall x. EmulatorMsg -> Rep EmulatorMsg x)
-> (forall x. Rep EmulatorMsg x -> EmulatorMsg)
-> Generic EmulatorMsg
forall x. Rep EmulatorMsg x -> EmulatorMsg
forall x. EmulatorMsg -> Rep EmulatorMsg x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep EmulatorMsg x -> EmulatorMsg
$cfrom :: forall x. EmulatorMsg -> Rep EmulatorMsg x
Generic)
    deriving anyclass ([EmulatorMsg] -> Encoding
[EmulatorMsg] -> Value
EmulatorMsg -> Encoding
EmulatorMsg -> Value
(EmulatorMsg -> Value)
-> (EmulatorMsg -> Encoding)
-> ([EmulatorMsg] -> Value)
-> ([EmulatorMsg] -> Encoding)
-> ToJSON EmulatorMsg
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [EmulatorMsg] -> Encoding
$ctoEncodingList :: [EmulatorMsg] -> Encoding
toJSONList :: [EmulatorMsg] -> Value
$ctoJSONList :: [EmulatorMsg] -> Value
toEncoding :: EmulatorMsg -> Encoding
$ctoEncoding :: EmulatorMsg -> Encoding
toJSON :: EmulatorMsg -> Value
$ctoJSON :: EmulatorMsg -> Value
ToJSON, Value -> Parser [EmulatorMsg]
Value -> Parser EmulatorMsg
(Value -> Parser EmulatorMsg)
-> (Value -> Parser [EmulatorMsg]) -> FromJSON EmulatorMsg
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [EmulatorMsg]
$cparseJSONList :: Value -> Parser [EmulatorMsg]
parseJSON :: Value -> Parser EmulatorMsg
$cparseJSON :: Value -> Parser EmulatorMsg
FromJSON)

instance Pretty EmulatorMsg where
    pretty :: EmulatorMsg -> Doc ann
pretty = \case
        GenericMsg Value
json  -> Value -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow Value
json
        TxBalanceMsg TxBalanceMsg
msg -> TxBalanceMsg -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty TxBalanceMsg
msg
        ChainEvent ChainEvent
msg   -> ChainEvent -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ChainEvent
msg

data TxBalanceMsg =
    BalancingUnbalancedTx CardanoBuildTx UtxoIndex
    | FinishedBalancing CardanoTx
    | SigningTx CardanoTx
    | SubmittingTx CardanoTx
    | ValidationFailed
        ValidationPhase
        CardanoTx
        ValidationError
        C.Value -- ^ The amount of collateral stored in the transaction.
    deriving stock (TxBalanceMsg -> TxBalanceMsg -> Bool
(TxBalanceMsg -> TxBalanceMsg -> Bool)
-> (TxBalanceMsg -> TxBalanceMsg -> Bool) -> Eq TxBalanceMsg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TxBalanceMsg -> TxBalanceMsg -> Bool
$c/= :: TxBalanceMsg -> TxBalanceMsg -> Bool
== :: TxBalanceMsg -> TxBalanceMsg -> Bool
$c== :: TxBalanceMsg -> TxBalanceMsg -> Bool
Eq, Int -> TxBalanceMsg -> ShowS
[TxBalanceMsg] -> ShowS
TxBalanceMsg -> String
(Int -> TxBalanceMsg -> ShowS)
-> (TxBalanceMsg -> String)
-> ([TxBalanceMsg] -> ShowS)
-> Show TxBalanceMsg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TxBalanceMsg] -> ShowS
$cshowList :: [TxBalanceMsg] -> ShowS
show :: TxBalanceMsg -> String
$cshow :: TxBalanceMsg -> String
showsPrec :: Int -> TxBalanceMsg -> ShowS
$cshowsPrec :: Int -> TxBalanceMsg -> ShowS
Show, (forall x. TxBalanceMsg -> Rep TxBalanceMsg x)
-> (forall x. Rep TxBalanceMsg x -> TxBalanceMsg)
-> Generic TxBalanceMsg
forall x. Rep TxBalanceMsg x -> TxBalanceMsg
forall x. TxBalanceMsg -> Rep TxBalanceMsg x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TxBalanceMsg x -> TxBalanceMsg
$cfrom :: forall x. TxBalanceMsg -> Rep TxBalanceMsg x
Generic)
    deriving anyclass ([TxBalanceMsg] -> Encoding
[TxBalanceMsg] -> Value
TxBalanceMsg -> Encoding
TxBalanceMsg -> Value
(TxBalanceMsg -> Value)
-> (TxBalanceMsg -> Encoding)
-> ([TxBalanceMsg] -> Value)
-> ([TxBalanceMsg] -> Encoding)
-> ToJSON TxBalanceMsg
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [TxBalanceMsg] -> Encoding
$ctoEncodingList :: [TxBalanceMsg] -> Encoding
toJSONList :: [TxBalanceMsg] -> Value
$ctoJSONList :: [TxBalanceMsg] -> Value
toEncoding :: TxBalanceMsg -> Encoding
$ctoEncoding :: TxBalanceMsg -> Encoding
toJSON :: TxBalanceMsg -> Value
$ctoJSON :: TxBalanceMsg -> Value
ToJSON, Value -> Parser [TxBalanceMsg]
Value -> Parser TxBalanceMsg
(Value -> Parser TxBalanceMsg)
-> (Value -> Parser [TxBalanceMsg]) -> FromJSON TxBalanceMsg
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [TxBalanceMsg]
$cparseJSONList :: Value -> Parser [TxBalanceMsg]
parseJSON :: Value -> Parser TxBalanceMsg
$cparseJSON :: Value -> Parser TxBalanceMsg
FromJSON)

instance Pretty TxBalanceMsg where
    pretty :: TxBalanceMsg -> Doc ann
pretty = \case
        BalancingUnbalancedTx CardanoBuildTx
tx (C.UTxO Map TxIn (TxOut CtxUTxO BabbageEra)
utxo) -> Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
hang Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
            [ Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
hang Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep [Doc ann
"Balancing an unbalanced transaction:", CardanoBuildTx -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty CardanoBuildTx
tx]
            , Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
hang Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann
"Utxo index:" Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: ((TxIn, TxOut CtxUTxO BabbageEra) -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ((TxIn, TxOut CtxUTxO BabbageEra) -> Doc ann)
-> [(TxIn, TxOut CtxUTxO BabbageEra)] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map TxIn (TxOut CtxUTxO BabbageEra)
-> [(TxIn, TxOut CtxUTxO BabbageEra)]
forall k a. Map k a -> [(k, a)]
Map.toList Map TxIn (TxOut CtxUTxO BabbageEra)
utxo)
            ]
        FinishedBalancing CardanoTx
tx      -> Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
hang Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep [Doc ann
"Finished balancing:", CardanoTx -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty CardanoTx
tx]
        SigningTx CardanoTx
tx              -> Doc ann
"Signing tx:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TxId -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (CardanoTx -> TxId
getCardanoTxId CardanoTx
tx)
        SubmittingTx CardanoTx
tx           -> Doc ann
"Submitting tx:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TxId -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (CardanoTx -> TxId
getCardanoTxId CardanoTx
tx)
        ValidationFailed ValidationPhase
p CardanoTx
tx ValidationError
e Value
_ -> Doc ann
"Validation error:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ValidationPhase -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ValidationPhase
p Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TxId -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (CardanoTx -> TxId
getCardanoTxId CardanoTx
tx) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
colon Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ValidationError -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ValidationError
e

makePrisms ''TxBalanceMsg