{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-- editorconfig-checker-disable-file
-- appears in the generated instances
{-# OPTIONS_GHC -Wno-overlapping-patterns #-}

-- | The exceptions that an abstract machine can throw.
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
  = -- | An attempt to reduce a not immediately reducible type instantiation.
    NonPolymorphicInstantiationMachineError
  | -- | An attempt to unwrap a not wrapped term.
    NonWrapUnwrappedMachineError
  | -- | An attempt to reduce a not immediately reducible application.
    NonFunctionalApplicationMachineError
  | -- | An attempt to evaluate an open term.
    OpenTermEvaluatedMachineError
  | -- | An attempt to compute a constant application resulted in 'UnliftingError'.
    UnliftingMachineError UnliftingError
  | -- | A builtin expected a term argument, but something else was received.
    BuiltinTermArgumentExpectedMachineError
  | -- | A builtin received a term argument when something else was expected
    UnexpectedBuiltinTermArgumentMachineError
  | -- | An attempt to scrutinize a non-constr.
    NonConstrScrutinizedMachineError
  | -- | An attempt to go into a non-existent case branch.
    MissingCaseBranchMachineError Word64
  | -- | A GHC exception was thrown.
    PanicMachineError String
  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 #-}