{-# 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 Cardano.Api qualified as C
import Cardano.Node.Emulator.LogMessages (TxBalanceMsg (..), _BalancingUnbalancedTx, _ValidationFailed)
import Control.Lens.TH (makePrisms)
import Data.Aeson (FromJSON, ToJSON)
import GHC.Generics (Generic)
import Ledger (Address)
import Ledger.Slot (Slot)
import Prettyprinter (Pretty (..), viaShow, (<+>))
import Wallet.Emulator.Error (WalletAPIError)

data RequestHandlerLogMsg =
    SlotNoticationTargetVsCurrent Slot Slot
    | StartWatchingContractAddresses
    | HandleTxFailed WalletAPIError
    | UtxoAtFailed Address
    | AdjustingUnbalancedTx [C.Lovelace]
    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 [Lovelace]
vl -> Doc ann
"Adjusting an unbalanced transaction:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Lovelace] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Lovelace]
vl