{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module PlutusCore.Evaluation.Machine.Exception
( UnliftingError (..)
, AsUnliftingError (..)
, BuiltinError (..)
, MachineError (..)
, AsMachineError (..)
, EvaluationError (..)
, AsEvaluationError (..)
, ErrorWithCause (..)
, EvaluationException
, throwNotAConstant
, throwing
, throwing_
, throwingWithCause
, splitStructuralOperational
, unsafeSplitStructuralOperational
) where
import PlutusPrelude
import PlutusCore.Builtin.Result
import PlutusCore.Evaluation.ErrorWithCause
import PlutusCore.Evaluation.Result
import PlutusCore.Pretty
import Control.Lens
import Data.Either.Extras
import Data.Word (Word64)
import Prettyprinter
data MachineError fun
= NonPolymorphicInstantiationMachineError
| NonWrapUnwrappedMachineError
| NonFunctionalApplicationMachineError
| OpenTermEvaluatedMachineError
| UnliftingMachineError UnliftingError
| BuiltinTermArgumentExpectedMachineError
| UnexpectedBuiltinTermArgumentMachineError
| NonConstrScrutinized
| MissingCaseBranch Word64
deriving stock (Int -> MachineError fun -> ShowS
[MachineError fun] -> ShowS
MachineError fun -> String
(Int -> MachineError fun -> ShowS)
-> (MachineError fun -> String)
-> ([MachineError fun] -> ShowS)
-> Show (MachineError fun)
forall fun. Int -> MachineError fun -> ShowS
forall fun. [MachineError fun] -> ShowS
forall fun. MachineError fun -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall fun. Int -> MachineError fun -> ShowS
showsPrec :: Int -> MachineError fun -> ShowS
$cshow :: forall fun. MachineError fun -> String
show :: MachineError fun -> String
$cshowList :: forall fun. [MachineError fun] -> ShowS
showList :: [MachineError fun] -> ShowS
Show, MachineError fun -> MachineError fun -> Bool
(MachineError fun -> MachineError fun -> Bool)
-> (MachineError fun -> MachineError fun -> Bool)
-> Eq (MachineError fun)
forall fun. MachineError fun -> MachineError fun -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall fun. MachineError fun -> MachineError fun -> Bool
== :: MachineError fun -> MachineError fun -> Bool
$c/= :: forall fun. MachineError fun -> MachineError fun -> Bool
/= :: MachineError fun -> MachineError fun -> Bool
Eq, (forall a b. (a -> b) -> MachineError a -> MachineError b)
-> (forall a b. a -> MachineError b -> MachineError a)
-> Functor MachineError
forall a b. a -> MachineError b -> MachineError a
forall a b. (a -> b) -> MachineError a -> MachineError b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> MachineError a -> MachineError b
fmap :: forall a b. (a -> b) -> MachineError a -> MachineError b
$c<$ :: forall a b. a -> MachineError b -> MachineError a
<$ :: forall a b. a -> MachineError b -> MachineError a
Functor, (forall x. MachineError fun -> Rep (MachineError fun) x)
-> (forall x. Rep (MachineError fun) x -> MachineError fun)
-> Generic (MachineError fun)
forall x. Rep (MachineError fun) x -> MachineError fun
forall x. MachineError fun -> Rep (MachineError fun) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall fun x. Rep (MachineError fun) x -> MachineError fun
forall fun x. MachineError fun -> Rep (MachineError fun) x
$cfrom :: forall fun x. MachineError fun -> Rep (MachineError fun) x
from :: forall x. MachineError fun -> Rep (MachineError fun) x
$cto :: forall fun x. Rep (MachineError fun) x -> MachineError fun
to :: forall x. Rep (MachineError fun) x -> MachineError fun
Generic)
deriving anyclass (MachineError fun -> ()
(MachineError fun -> ()) -> NFData (MachineError fun)
forall fun. MachineError fun -> ()
forall a. (a -> ()) -> NFData a
$crnf :: forall fun. MachineError fun -> ()
rnf :: MachineError fun -> ()
NFData)
mtraverse makeClassyPrisms
[ ''MachineError
]
instance structural ~ MachineError fun =>
AsMachineError (EvaluationError structural operational) fun where
_MachineError :: Prism' (EvaluationError structural operational) (MachineError fun)
_MachineError = p (MachineError fun) (f (MachineError fun))
-> p (EvaluationError structural operational)
(f (EvaluationError structural operational))
forall r structural operational.
AsEvaluationError r structural operational =>
Prism' r structural
Prism' (EvaluationError structural operational) (MachineError fun)
_StructuralEvaluationError
{-# INLINE _MachineError #-}
instance AsUnliftingError (MachineError fun) where
_UnliftingError :: Prism' (MachineError fun) UnliftingError
_UnliftingError = p UnliftingError (f UnliftingError)
-> p (MachineError fun) (f (MachineError fun))
forall r fun. AsMachineError r fun => Prism' r UnliftingError
Prism' (MachineError fun) UnliftingError
_UnliftingMachineError
{-# INLINE _UnliftingError #-}
type EvaluationException structural operational =
ErrorWithCause (EvaluationError structural operational)
splitStructuralOperational
:: Either (EvaluationException structural operational term) a
-> Either (ErrorWithCause structural term) (EvaluationResult a)
splitStructuralOperational :: forall structural operational term a.
Either (EvaluationException structural operational term) a
-> Either (ErrorWithCause structural term) (EvaluationResult a)
splitStructuralOperational (Right a
term) = EvaluationResult a
-> Either (ErrorWithCause structural term) (EvaluationResult a)
forall a b. b -> Either a b
Right (EvaluationResult a
-> Either (ErrorWithCause structural term) (EvaluationResult a))
-> EvaluationResult a
-> Either (ErrorWithCause structural term) (EvaluationResult a)
forall a b. (a -> b) -> a -> b
$ a -> EvaluationResult a
forall a. a -> EvaluationResult a
EvaluationSuccess a
term
splitStructuralOperational (Left (ErrorWithCause EvaluationError structural operational
evalErr Maybe term
cause)) = case EvaluationError structural operational
evalErr of
StructuralEvaluationError structural
err -> ErrorWithCause structural term
-> Either (ErrorWithCause structural term) (EvaluationResult a)
forall a b. a -> Either a b
Left (ErrorWithCause structural term
-> Either (ErrorWithCause structural term) (EvaluationResult a))
-> ErrorWithCause structural term
-> Either (ErrorWithCause structural term) (EvaluationResult a)
forall a b. (a -> b) -> a -> b
$ structural -> Maybe term -> ErrorWithCause structural term
forall err cause. err -> Maybe cause -> ErrorWithCause err cause
ErrorWithCause structural
err Maybe term
cause
OperationalEvaluationError operational
_ -> EvaluationResult a
-> Either (ErrorWithCause structural term) (EvaluationResult a)
forall a b. b -> Either a b
Right EvaluationResult a
forall a. EvaluationResult a
EvaluationFailure
unsafeSplitStructuralOperational
:: (PrettyPlc structural, PrettyPlc term, Typeable structural, Typeable term)
=> Either (EvaluationException structural operational term) a
-> EvaluationResult a
unsafeSplitStructuralOperational :: forall structural term operational a.
(PrettyPlc structural, PrettyPlc term, Typeable structural,
Typeable term) =>
Either (EvaluationException structural operational term) a
-> EvaluationResult a
unsafeSplitStructuralOperational = Either (ErrorWithCause structural term) (EvaluationResult a)
-> EvaluationResult a
forall e a. Exception e => Either e a -> a
unsafeFromEither (Either (ErrorWithCause structural term) (EvaluationResult a)
-> EvaluationResult a)
-> (Either (EvaluationException structural operational term) a
-> Either (ErrorWithCause structural term) (EvaluationResult a))
-> Either (EvaluationException structural operational term) a
-> EvaluationResult a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (EvaluationException structural operational term) a
-> Either (ErrorWithCause structural term) (EvaluationResult a)
forall structural operational term a.
Either (EvaluationException structural operational term) a
-> Either (ErrorWithCause structural term) (EvaluationResult a)
splitStructuralOperational
instance (HasPrettyDefaults config ~ 'True, Pretty fun) =>
PrettyBy config (MachineError fun) where
prettyBy :: forall ann. config -> MachineError fun -> Doc ann
prettyBy config
_ MachineError fun
NonPolymorphicInstantiationMachineError =
Doc ann
"Attempted to instantiate a non-polymorphic term."
prettyBy config
_ MachineError fun
NonWrapUnwrappedMachineError =
Doc ann
"Cannot unwrap a not wrapped term."
prettyBy config
_ MachineError fun
NonFunctionalApplicationMachineError =
Doc ann
"Attempted to apply a non-function."
prettyBy config
_ MachineError fun
OpenTermEvaluatedMachineError =
Doc ann
"Cannot evaluate an open term"
prettyBy config
_ MachineError fun
BuiltinTermArgumentExpectedMachineError =
Doc ann
"A builtin expected a term argument, but something else was received"
prettyBy config
_ MachineError fun
UnexpectedBuiltinTermArgumentMachineError =
Doc ann
"A builtin received a term argument when something else was expected"
prettyBy config
_ (UnliftingMachineError UnliftingError
unliftingError) =
UnliftingError -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. UnliftingError -> Doc ann
pretty UnliftingError
unliftingError
prettyBy config
_ MachineError fun
NonConstrScrutinized =
Doc ann
"A non-constructor value was scrutinized in a case expression"
prettyBy config
_ (MissingCaseBranch Word64
i) =
Doc ann
"Case expression missing the branch required by the scrutinee tag:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Word64 -> Doc ann
forall ann. Word64 -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Word64
i