{-# LANGUAGE DeriveAnyClass     #-}
{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase         #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE TemplateHaskell    #-}
-- | The log messages produced by the emulator.
module Wallet.Emulator.LogMessages(
  RequestHandlerLogMsg(..)
  , TxBalanceMsg(..)
  , _AdjustingUnbalancedTx
  , _BalancingUnbalancedTx
  , _ValidationFailed
  ) where

import Control.Lens.TH (makePrisms)
import Data.Aeson (FromJSON, ToJSON)
import Data.Text (Text)
import GHC.Generics (Generic)
import Ledger (Address, CardanoTx, TxId, getCardanoTxId)
import Ledger.Ada qualified as Ada
import Ledger.Constraints.OffChain (UnbalancedTx)
import Ledger.Index (ValidationError, ValidationPhase)
import Ledger.Slot (Slot)
import Ledger.Value (Value)
import Prettyprinter (Pretty (..), colon, hang, viaShow, vsep, (<+>))
import Wallet.Emulator.Error (WalletAPIError)

data RequestHandlerLogMsg =
    SlotNoticationTargetVsCurrent Slot Slot
    | StartWatchingContractAddresses
    | HandleTxFailed WalletAPIError
    | UtxoAtFailed Address
    | AdjustingUnbalancedTx [Ada.Ada]
    deriving stock (RequestHandlerLogMsg -> RequestHandlerLogMsg -> Bool
(RequestHandlerLogMsg -> RequestHandlerLogMsg -> Bool)
-> (RequestHandlerLogMsg -> RequestHandlerLogMsg -> Bool)
-> Eq RequestHandlerLogMsg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RequestHandlerLogMsg -> RequestHandlerLogMsg -> Bool
$c/= :: RequestHandlerLogMsg -> RequestHandlerLogMsg -> Bool
== :: RequestHandlerLogMsg -> RequestHandlerLogMsg -> Bool
$c== :: RequestHandlerLogMsg -> RequestHandlerLogMsg -> Bool
Eq, Int -> RequestHandlerLogMsg -> ShowS
[RequestHandlerLogMsg] -> ShowS
RequestHandlerLogMsg -> String
(Int -> RequestHandlerLogMsg -> ShowS)
-> (RequestHandlerLogMsg -> String)
-> ([RequestHandlerLogMsg] -> ShowS)
-> Show RequestHandlerLogMsg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RequestHandlerLogMsg] -> ShowS
$cshowList :: [RequestHandlerLogMsg] -> ShowS
show :: RequestHandlerLogMsg -> String
$cshow :: RequestHandlerLogMsg -> String
showsPrec :: Int -> RequestHandlerLogMsg -> ShowS
$cshowsPrec :: Int -> RequestHandlerLogMsg -> ShowS
Show, (forall x. RequestHandlerLogMsg -> Rep RequestHandlerLogMsg x)
-> (forall x. Rep RequestHandlerLogMsg x -> RequestHandlerLogMsg)
-> Generic RequestHandlerLogMsg
forall x. Rep RequestHandlerLogMsg x -> RequestHandlerLogMsg
forall x. RequestHandlerLogMsg -> Rep RequestHandlerLogMsg x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RequestHandlerLogMsg x -> RequestHandlerLogMsg
$cfrom :: forall x. RequestHandlerLogMsg -> Rep RequestHandlerLogMsg x
Generic)
    deriving anyclass ([RequestHandlerLogMsg] -> Encoding
[RequestHandlerLogMsg] -> Value
RequestHandlerLogMsg -> Encoding
RequestHandlerLogMsg -> Value
(RequestHandlerLogMsg -> Value)
-> (RequestHandlerLogMsg -> Encoding)
-> ([RequestHandlerLogMsg] -> Value)
-> ([RequestHandlerLogMsg] -> Encoding)
-> ToJSON RequestHandlerLogMsg
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [RequestHandlerLogMsg] -> Encoding
$ctoEncodingList :: [RequestHandlerLogMsg] -> Encoding
toJSONList :: [RequestHandlerLogMsg] -> Value
$ctoJSONList :: [RequestHandlerLogMsg] -> Value
toEncoding :: RequestHandlerLogMsg -> Encoding
$ctoEncoding :: RequestHandlerLogMsg -> Encoding
toJSON :: RequestHandlerLogMsg -> Value
$ctoJSON :: RequestHandlerLogMsg -> Value
ToJSON, Value -> Parser [RequestHandlerLogMsg]
Value -> Parser RequestHandlerLogMsg
(Value -> Parser RequestHandlerLogMsg)
-> (Value -> Parser [RequestHandlerLogMsg])
-> FromJSON RequestHandlerLogMsg
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [RequestHandlerLogMsg]
$cparseJSONList :: Value -> Parser [RequestHandlerLogMsg]
parseJSON :: Value -> Parser RequestHandlerLogMsg
$cparseJSON :: Value -> Parser RequestHandlerLogMsg
FromJSON)

makePrisms ''RequestHandlerLogMsg

instance Pretty RequestHandlerLogMsg where
    pretty :: RequestHandlerLogMsg -> Doc ann
pretty = \case
        SlotNoticationTargetVsCurrent Slot
target Slot
current ->
            Doc ann
"target slot:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Slot -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Slot
target Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"; current slot:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Slot -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Slot
current
        RequestHandlerLogMsg
StartWatchingContractAddresses -> Doc ann
"Start watching contract addresses"
        HandleTxFailed WalletAPIError
e -> Doc ann
"handleTx failed:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> WalletAPIError -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow WalletAPIError
e
        UtxoAtFailed Address
addr -> Doc ann
"UtxoAt failed:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Address -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Address
addr
        AdjustingUnbalancedTx [Ada]
vl -> Doc ann
"Adjusting an unbalanced transaction:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Ada] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Ada]
vl

data TxBalanceMsg =
    BalancingUnbalancedTx UnbalancedTx
    | FinishedBalancing CardanoTx
    | SigningTx CardanoTx
    | SubmittingTx CardanoTx
    | ValidationFailed
        ValidationPhase
        TxId
        CardanoTx
        ValidationError
        Value -- ^ The amount of collateral stored in the transaction.
        [Text]
    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 UnbalancedTx
utx    -> 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:", UnbalancedTx -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty UnbalancedTx
utx]
        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 TxId
i CardanoTx
_ ValidationError
e Value
_ [Text]
_ -> 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 TxId
i 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