-- 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 (..)
    , BuiltinError (..)
    , MachineError (..)
    , EvaluationError (..)
    , ErrorWithCause (..)
    , EvaluationException
    , notAConstant
    , throwErrorWithCause
    , splitStructuralOperational
    , unsafeSplitStructuralOperational
    , BuiltinErrorToEvaluationError
    , builtinErrorToEvaluationError
    , throwBuiltinErrorWithCause
    ) where

import PlutusPrelude

import PlutusCore.Builtin.Result
import PlutusCore.Evaluation.ErrorWithCause
import PlutusCore.Evaluation.Result
import PlutusCore.Pretty

import Control.Monad.Except
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
    | NonConstrScrutinizedMachineError
      -- ^ An attempt to scrutinize a non-constr.
    | MissingCaseBranchMachineError Word64
      -- ^ An attempt to go into a non-existent case branch.
    | PanicMachineError String
      -- ^ A GHC exception was thrown.
    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)

type EvaluationException structural operational =
    ErrorWithCause (EvaluationError structural operational)

{- Note [Ignoring context in OperationalError]
The 'OperationalError' 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 'OperationalError' 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 OperationalError].
-- | Preserve the contents of an 'StructuralError' as a 'Left' and turn an
-- 'OperationalError' 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
    StructuralError 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
    OperationalError 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 'StructuralError' and turn an 'OperationalError' 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
NonConstrScrutinizedMachineError =
        Doc ann
"A non-constructor/non-builtin value was scrutinized in a case expression"
    prettyBy config
_      (MissingCaseBranchMachineError 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
    prettyBy config
_      (PanicMachineError String
err) = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat
        [ Doc ann
"Panic: a GHC exception was thrown, please report this as a bug."
        , Doc ann
"The error: " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
err
        ]

class BuiltinErrorToEvaluationError structural operational where
  builtinErrorToEvaluationError :: BuiltinError -> EvaluationError structural operational

-- | Attach a @cause@ to a 'BuiltinError' and throw that.
-- Note that an evaluator might require the cause to be computed lazily for best performance on the
-- happy path, hence this function must not force its first argument.
-- TODO: wrap @cause@ in 'Lazy' once we have it.
throwBuiltinErrorWithCause
    :: ( MonadError (EvaluationException structural operational cause) m
       , BuiltinErrorToEvaluationError structural operational
       )
    => cause -> BuiltinError -> m void
throwBuiltinErrorWithCause :: forall structural operational cause (m :: * -> *) void.
(MonadError (EvaluationException structural operational cause) m,
 BuiltinErrorToEvaluationError structural operational) =>
cause -> BuiltinError -> m void
throwBuiltinErrorWithCause cause
cause BuiltinError
e = EvaluationError structural operational -> cause -> m void
forall e cause (m :: * -> *) x.
MonadError (ErrorWithCause e cause) m =>
e -> cause -> m x
throwErrorWithCause (BuiltinError -> EvaluationError structural operational
forall structural operational.
BuiltinErrorToEvaluationError structural operational =>
BuiltinError -> EvaluationError structural operational
builtinErrorToEvaluationError BuiltinError
e) cause
cause
{-# INLINE throwBuiltinErrorWithCause #-}