-- editorconfig-checker-disable-file
-- | The exceptions that an abstract machine can throw.

-- appears in the generated instances
{-# 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

-- | Errors which can occur during a run of an abstract machine.
data MachineError fun
    = NonPolymorphicInstantiationMachineError
      -- ^ An attempt to reduce a not immediately reducible type instantiation.
    | NonWrapUnwrappedMachineError
      -- ^ An attempt to unwrap a not wrapped term.
    | NonFunctionalApplicationMachineError
      -- ^ An attempt to reduce a not immediately reducible application.
    | OpenTermEvaluatedMachineError
      -- ^ An attempt to evaluate an open term.
    | UnliftingMachineError UnliftingError
      -- ^ An attempt to compute a constant application resulted in 'UnliftingError'.
    | BuiltinTermArgumentExpectedMachineError
      -- ^ A builtin expected a term argument, but something else was received.
    | UnexpectedBuiltinTermArgumentMachineError
      -- ^ A builtin received a term argument when something else was expected
    | 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)

{- Note [Ignoring context in OperationalEvaluationError]
The 'OperationalEvaluationError' error has a term argument, but 'splitStructuralOperational' just
discards this and returns 'EvaluationFailure'. This means that, for example, if we use the @plc@
command to execute a program containing a division by zero, @plc@ exits silently without reporting
that anything has gone wrong (but returning a non-zero exit code to the shell via 'exitFailure').
This is because 'OperationalEvaluationError' is used in cases when a PLC program itself goes wrong
(see the Haddock of 'EvaluationError'). This is used to signal unsuccessful validation and so is
not regarded as a real error; in contrast structural errors are genuine errors and we report their
context if available.
-}

-- See the Haddock of 'EvaluationError' for what structural and operational errors are.
-- See Note [Ignoring context in OperationalEvaluationError].
-- | Preserve the contents of an 'StructuralEvaluationError' as a 'Left' and turn an
-- 'OperationalEvaluationError' into a @Right EvaluationFailure@ (thus erasing the content of the
-- error in the latter case).
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

-- | Throw on a 'StructuralEvaluationError' and turn an 'OperationalEvaluationError' into an
-- 'EvaluationFailure' (thus erasing the content of the error in the latter case).
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