{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE DerivingVia       #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell   #-}

module Plutus.Contract.Error
    ( ContractError(..)
    , AsContractError(..)
    , MatchingError(..)
    , AsMatchingError(..)
    , AssertionError(..)
    , AsAssertionError(..)
    ) where

import Control.Lens (prism')
import Control.Lens.TH (makeClassyPrisms)
import Data.Aeson (FromJSON, ToJSON)
import Data.Aeson qualified as Aeson
import Data.String (IsString (fromString))
import Data.Text (Text)
import Data.Text qualified as T
import GHC.Generics (Generic)
import Prettyprinter (Pretty (pretty), viaShow, (<+>))

import Data.Aeson qualified as JSON
import Ledger.Tx.Constraints.OffChain (MkTxError)
import Plutus.Contract.CardanoAPI (ToCardanoError)
import Plutus.Contract.Checkpoint (AsCheckpointError (_CheckpointError), CheckpointError)
import Plutus.Contract.Effects (ChainIndexResponse)
import Wallet.Error (WalletAPIError)
import Wallet.Types (EndpointDescription (EndpointDescription), EndpointValue (EndpointValue))

-- | An error
newtype MatchingError = WrongVariantError { MatchingError -> Text
unWrongVariantError :: Text }
    deriving stock (MatchingError -> MatchingError -> Bool
(MatchingError -> MatchingError -> Bool)
-> (MatchingError -> MatchingError -> Bool) -> Eq MatchingError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MatchingError -> MatchingError -> Bool
$c/= :: MatchingError -> MatchingError -> Bool
== :: MatchingError -> MatchingError -> Bool
$c== :: MatchingError -> MatchingError -> Bool
Eq, Eq MatchingError
Eq MatchingError
-> (MatchingError -> MatchingError -> Ordering)
-> (MatchingError -> MatchingError -> Bool)
-> (MatchingError -> MatchingError -> Bool)
-> (MatchingError -> MatchingError -> Bool)
-> (MatchingError -> MatchingError -> Bool)
-> (MatchingError -> MatchingError -> MatchingError)
-> (MatchingError -> MatchingError -> MatchingError)
-> Ord MatchingError
MatchingError -> MatchingError -> Bool
MatchingError -> MatchingError -> Ordering
MatchingError -> MatchingError -> MatchingError
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: MatchingError -> MatchingError -> MatchingError
$cmin :: MatchingError -> MatchingError -> MatchingError
max :: MatchingError -> MatchingError -> MatchingError
$cmax :: MatchingError -> MatchingError -> MatchingError
>= :: MatchingError -> MatchingError -> Bool
$c>= :: MatchingError -> MatchingError -> Bool
> :: MatchingError -> MatchingError -> Bool
$c> :: MatchingError -> MatchingError -> Bool
<= :: MatchingError -> MatchingError -> Bool
$c<= :: MatchingError -> MatchingError -> Bool
< :: MatchingError -> MatchingError -> Bool
$c< :: MatchingError -> MatchingError -> Bool
compare :: MatchingError -> MatchingError -> Ordering
$ccompare :: MatchingError -> MatchingError -> Ordering
$cp1Ord :: Eq MatchingError
Ord, Int -> MatchingError -> ShowS
[MatchingError] -> ShowS
MatchingError -> String
(Int -> MatchingError -> ShowS)
-> (MatchingError -> String)
-> ([MatchingError] -> ShowS)
-> Show MatchingError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MatchingError] -> ShowS
$cshowList :: [MatchingError] -> ShowS
show :: MatchingError -> String
$cshow :: MatchingError -> String
showsPrec :: Int -> MatchingError -> ShowS
$cshowsPrec :: Int -> MatchingError -> ShowS
Show, (forall x. MatchingError -> Rep MatchingError x)
-> (forall x. Rep MatchingError x -> MatchingError)
-> Generic MatchingError
forall x. Rep MatchingError x -> MatchingError
forall x. MatchingError -> Rep MatchingError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MatchingError x -> MatchingError
$cfrom :: forall x. MatchingError -> Rep MatchingError x
Generic)
    deriving anyclass ([MatchingError] -> Encoding
[MatchingError] -> Value
MatchingError -> Encoding
MatchingError -> Value
(MatchingError -> Value)
-> (MatchingError -> Encoding)
-> ([MatchingError] -> Value)
-> ([MatchingError] -> Encoding)
-> ToJSON MatchingError
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [MatchingError] -> Encoding
$ctoEncodingList :: [MatchingError] -> Encoding
toJSONList :: [MatchingError] -> Value
$ctoJSONList :: [MatchingError] -> Value
toEncoding :: MatchingError -> Encoding
$ctoEncoding :: MatchingError -> Encoding
toJSON :: MatchingError -> Value
$ctoJSON :: MatchingError -> Value
Aeson.ToJSON, Value -> Parser [MatchingError]
Value -> Parser MatchingError
(Value -> Parser MatchingError)
-> (Value -> Parser [MatchingError]) -> FromJSON MatchingError
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [MatchingError]
$cparseJSONList :: Value -> Parser [MatchingError]
parseJSON :: Value -> Parser MatchingError
$cparseJSON :: Value -> Parser MatchingError
Aeson.FromJSON)
makeClassyPrisms ''MatchingError

instance Pretty MatchingError where
  pretty :: MatchingError -> Doc ann
pretty = \case
    WrongVariantError Text
t -> Doc ann
"Wrong variant:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
t

-- | An error emitted when an 'Assertion' fails.
newtype AssertionError = GenericAssertion { AssertionError -> Text
unAssertionError :: T.Text }
    deriving stock (Int -> AssertionError -> ShowS
[AssertionError] -> ShowS
AssertionError -> String
(Int -> AssertionError -> ShowS)
-> (AssertionError -> String)
-> ([AssertionError] -> ShowS)
-> Show AssertionError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AssertionError] -> ShowS
$cshowList :: [AssertionError] -> ShowS
show :: AssertionError -> String
$cshow :: AssertionError -> String
showsPrec :: Int -> AssertionError -> ShowS
$cshowsPrec :: Int -> AssertionError -> ShowS
Show, AssertionError -> AssertionError -> Bool
(AssertionError -> AssertionError -> Bool)
-> (AssertionError -> AssertionError -> Bool) -> Eq AssertionError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AssertionError -> AssertionError -> Bool
$c/= :: AssertionError -> AssertionError -> Bool
== :: AssertionError -> AssertionError -> Bool
$c== :: AssertionError -> AssertionError -> Bool
Eq, (forall x. AssertionError -> Rep AssertionError x)
-> (forall x. Rep AssertionError x -> AssertionError)
-> Generic AssertionError
forall x. Rep AssertionError x -> AssertionError
forall x. AssertionError -> Rep AssertionError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AssertionError x -> AssertionError
$cfrom :: forall x. AssertionError -> Rep AssertionError x
Generic)
    deriving anyclass ([AssertionError] -> Encoding
[AssertionError] -> Value
AssertionError -> Encoding
AssertionError -> Value
(AssertionError -> Value)
-> (AssertionError -> Encoding)
-> ([AssertionError] -> Value)
-> ([AssertionError] -> Encoding)
-> ToJSON AssertionError
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [AssertionError] -> Encoding
$ctoEncodingList :: [AssertionError] -> Encoding
toJSONList :: [AssertionError] -> Value
$ctoJSONList :: [AssertionError] -> Value
toEncoding :: AssertionError -> Encoding
$ctoEncoding :: AssertionError -> Encoding
toJSON :: AssertionError -> Value
$ctoJSON :: AssertionError -> Value
ToJSON, Value -> Parser [AssertionError]
Value -> Parser AssertionError
(Value -> Parser AssertionError)
-> (Value -> Parser [AssertionError]) -> FromJSON AssertionError
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [AssertionError]
$cparseJSONList :: Value -> Parser [AssertionError]
parseJSON :: Value -> Parser AssertionError
$cparseJSON :: Value -> Parser AssertionError
FromJSON)
makeClassyPrisms ''AssertionError

instance Pretty AssertionError where
    pretty :: AssertionError -> Doc ann
pretty = \case
        GenericAssertion Text
t -> Doc ann
"Generic assertion:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
t

-- | This lets people use 'T.Text' as their error type.
instance AsAssertionError T.Text where
    _AssertionError :: p AssertionError (f AssertionError) -> p Text (f Text)
_AssertionError = (AssertionError -> Text)
-> (Text -> Maybe AssertionError) -> Prism' Text AssertionError
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' (String -> Text
T.pack (String -> Text)
-> (AssertionError -> String) -> AssertionError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AssertionError -> String
forall a. Show a => a -> String
show) (Maybe AssertionError -> Text -> Maybe AssertionError
forall a b. a -> b -> a
const Maybe AssertionError
forall a. Maybe a
Nothing)

data ContractError =
    WalletContractError WalletAPIError
  | ChainIndexContractError T.Text ChainIndexResponse
  | ConstraintResolutionContractError MkTxError
  | ToCardanoConvertContractError ToCardanoError
  | ResumableContractError MatchingError
  | CCheckpointContractError CheckpointError
  | EndpointDecodeContractError
      { ContractError -> EndpointDescription
eeEndpointDescription :: EndpointDescription
      -- ^ The endpoint description which the decoding error occurred from
      , ContractError -> EndpointValue Value
eeEndpointValue       :: EndpointValue JSON.Value
      -- ^ The endpoint value that was used as an endpoint parameter
      , ContractError -> Text
eeErrorMessage        :: T.Text
      -- ^ JSON decoding error message
      }
  | OtherContractError T.Text
    deriving stock (Int -> ContractError -> ShowS
[ContractError] -> ShowS
ContractError -> String
(Int -> ContractError -> ShowS)
-> (ContractError -> String)
-> ([ContractError] -> ShowS)
-> Show ContractError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ContractError] -> ShowS
$cshowList :: [ContractError] -> ShowS
show :: ContractError -> String
$cshow :: ContractError -> String
showsPrec :: Int -> ContractError -> ShowS
$cshowsPrec :: Int -> ContractError -> ShowS
Show, ContractError -> ContractError -> Bool
(ContractError -> ContractError -> Bool)
-> (ContractError -> ContractError -> Bool) -> Eq ContractError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ContractError -> ContractError -> Bool
$c/= :: ContractError -> ContractError -> Bool
== :: ContractError -> ContractError -> Bool
$c== :: ContractError -> ContractError -> Bool
Eq, (forall x. ContractError -> Rep ContractError x)
-> (forall x. Rep ContractError x -> ContractError)
-> Generic ContractError
forall x. Rep ContractError x -> ContractError
forall x. ContractError -> Rep ContractError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ContractError x -> ContractError
$cfrom :: forall x. ContractError -> Rep ContractError x
Generic)
    deriving anyclass ([ContractError] -> Encoding
[ContractError] -> Value
ContractError -> Encoding
ContractError -> Value
(ContractError -> Value)
-> (ContractError -> Encoding)
-> ([ContractError] -> Value)
-> ([ContractError] -> Encoding)
-> ToJSON ContractError
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ContractError] -> Encoding
$ctoEncodingList :: [ContractError] -> Encoding
toJSONList :: [ContractError] -> Value
$ctoJSONList :: [ContractError] -> Value
toEncoding :: ContractError -> Encoding
$ctoEncoding :: ContractError -> Encoding
toJSON :: ContractError -> Value
$ctoJSON :: ContractError -> Value
Aeson.ToJSON, Value -> Parser [ContractError]
Value -> Parser ContractError
(Value -> Parser ContractError)
-> (Value -> Parser [ContractError]) -> FromJSON ContractError
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [ContractError]
$cparseJSONList :: Value -> Parser [ContractError]
parseJSON :: Value -> Parser ContractError
$cparseJSON :: Value -> Parser ContractError
Aeson.FromJSON)
makeClassyPrisms ''ContractError

instance Pretty ContractError where
  pretty :: ContractError -> Doc ann
pretty = \case
    WalletContractError WalletAPIError
e               -> Doc ann
"Wallet error:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> WalletAPIError -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty WalletAPIError
e
    ChainIndexContractError Text
expectedResp ChainIndexResponse
actualResp
        -> Doc ann
"Wrong response type from chain index request: Expected"
        Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
expectedResp
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
", got"
        Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ChainIndexResponse -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ChainIndexResponse
actualResp
    ConstraintResolutionContractError MkTxError
e -> Doc ann
"Constraint resolution error:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> MkTxError -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty MkTxError
e
    ToCardanoConvertContractError ToCardanoError
e   -> Doc ann
"To Cardano conversion error:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ToCardanoError -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ToCardanoError
e
    ResumableContractError MatchingError
e            -> Doc ann
"Resumable error:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> MatchingError -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty MatchingError
e
    CCheckpointContractError CheckpointError
e          -> Doc ann
"Checkpoint error:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> CheckpointError -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty CheckpointError
e
    EndpointDecodeContractError (EndpointDescription String
ed) (EndpointValue Value
ev) Text
err
        -> Doc ann
"Failed to decode endpoint \""
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
ed
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"\" with value"
        Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Value -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow Value
ev
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
":"
        Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
err
    OtherContractError Text
t                -> Doc ann
"Other error:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
t

-- | This lets people use 'T.Text' as their error type.
instance AsContractError T.Text where
    _ContractError :: p ContractError (f ContractError) -> p Text (f Text)
_ContractError = (ContractError -> Text)
-> (Text -> Maybe ContractError) -> Prism' Text ContractError
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' (String -> Text
T.pack (String -> Text)
-> (ContractError -> String) -> ContractError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContractError -> String
forall a. Show a => a -> String
show) (Maybe ContractError -> Text -> Maybe ContractError
forall a b. a -> b -> a
const Maybe ContractError
forall a. Maybe a
Nothing)

instance IsString ContractError where
  fromString :: String -> ContractError
fromString = Text -> ContractError
OtherContractError (Text -> ContractError)
-> (String -> Text) -> String -> ContractError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. IsString a => String -> a
fromString

instance AsCheckpointError ContractError where
  _CheckpointError :: p CheckpointError (f CheckpointError)
-> p ContractError (f ContractError)
_CheckpointError = p CheckpointError (f CheckpointError)
-> p ContractError (f ContractError)
forall r. AsContractError r => Prism' r CheckpointError
_CCheckpointContractError