-- | 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 RankNTypes             #-}
{-# LANGUAGE TemplateHaskell        #-}
{-# LANGUAGE TypeFamilies           #-}
{-# LANGUAGE TypeOperators          #-}
{-# LANGUAGE UndecidableInstances   #-}

module PlutusCore.Evaluation.Machine.Exception
    ( UnliftingError (..)
    , AsUnliftingError (..)
    , MachineError (..)
    , AsMachineError (..)
    , EvaluationError (..)
    , AsEvaluationError (..)
    , ErrorWithCause (..)
    , EvaluationException
    , mapCauseInMachineException
    , throwing_
    , throwingWithCause
    , extractEvaluationResult
    , unsafeExtractEvaluationResult
    ) where

import PlutusPrelude

import PlutusCore.Core.Instance.Pretty.Common ()
import PlutusCore.Evaluation.Result
import PlutusCore.Pretty

import Control.Lens
import Control.Monad.Error.Lens (throwing_)
import Control.Monad.Except
import Data.String (IsString)
import Data.Text (Text)
import ErrorCode
import Prettyprinter

-- | When unlifting of a PLC term into a Haskell value fails, this error is thrown.
newtype UnliftingError
    = UnliftingErrorE Text
    deriving stock (Int -> UnliftingError -> ShowS
[UnliftingError] -> ShowS
UnliftingError -> String
(Int -> UnliftingError -> ShowS)
-> (UnliftingError -> String)
-> ([UnliftingError] -> ShowS)
-> Show UnliftingError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnliftingError] -> ShowS
$cshowList :: [UnliftingError] -> ShowS
show :: UnliftingError -> String
$cshow :: UnliftingError -> String
showsPrec :: Int -> UnliftingError -> ShowS
$cshowsPrec :: Int -> UnliftingError -> ShowS
Show, UnliftingError -> UnliftingError -> Bool
(UnliftingError -> UnliftingError -> Bool)
-> (UnliftingError -> UnliftingError -> Bool) -> Eq UnliftingError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnliftingError -> UnliftingError -> Bool
$c/= :: UnliftingError -> UnliftingError -> Bool
== :: UnliftingError -> UnliftingError -> Bool
$c== :: UnliftingError -> UnliftingError -> Bool
Eq)
    deriving newtype (String -> UnliftingError
(String -> UnliftingError) -> IsString UnliftingError
forall a. (String -> a) -> IsString a
fromString :: String -> UnliftingError
$cfromString :: String -> UnliftingError
IsString, b -> UnliftingError -> UnliftingError
NonEmpty UnliftingError -> UnliftingError
UnliftingError -> UnliftingError -> UnliftingError
(UnliftingError -> UnliftingError -> UnliftingError)
-> (NonEmpty UnliftingError -> UnliftingError)
-> (forall b. Integral b => b -> UnliftingError -> UnliftingError)
-> Semigroup UnliftingError
forall b. Integral b => b -> UnliftingError -> UnliftingError
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> UnliftingError -> UnliftingError
$cstimes :: forall b. Integral b => b -> UnliftingError -> UnliftingError
sconcat :: NonEmpty UnliftingError -> UnliftingError
$csconcat :: NonEmpty UnliftingError -> UnliftingError
<> :: UnliftingError -> UnliftingError -> UnliftingError
$c<> :: UnliftingError -> UnliftingError -> UnliftingError
Semigroup, UnliftingError -> ()
(UnliftingError -> ()) -> NFData UnliftingError
forall a. (a -> ()) -> NFData a
rnf :: UnliftingError -> ()
$crnf :: UnliftingError -> ()
NFData)

-- | 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 'ConstAppError'.
    | BuiltinTermArgumentExpectedMachineError
      -- ^ A builtin expected a term argument, but something else was received
    | UnexpectedBuiltinTermArgumentMachineError
      -- ^ A builtin received a term argument when something else was expected
    | EmptyBuiltinArityMachineError
      -- ^ We've reached a state where a builtin instantiation or application is attempted
      -- when the arity is zero. In the absence of nullary builtins, this should be impossible.
      -- See the machine implementations for details.
    | UnknownBuiltin fun
    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. Show fun => Int -> MachineError fun -> ShowS
forall fun. Show fun => [MachineError fun] -> ShowS
forall fun. Show fun => MachineError fun -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MachineError fun] -> ShowS
$cshowList :: forall fun. Show fun => [MachineError fun] -> ShowS
show :: MachineError fun -> String
$cshow :: forall fun. Show fun => MachineError fun -> String
showsPrec :: Int -> MachineError fun -> ShowS
$cshowsPrec :: forall fun. Show fun => Int -> MachineError fun -> ShowS
Show, MachineError fun -> MachineError fun -> Bool
(MachineError fun -> MachineError fun -> Bool)
-> (MachineError fun -> MachineError fun -> Bool)
-> Eq (MachineError fun)
forall fun. Eq fun => MachineError fun -> MachineError fun -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MachineError fun -> MachineError fun -> Bool
$c/= :: forall fun. Eq fun => MachineError fun -> MachineError fun -> Bool
== :: MachineError fun -> MachineError fun -> Bool
$c== :: forall fun. Eq fun => MachineError fun -> MachineError fun -> Bool
Eq, a -> MachineError b -> MachineError a
(a -> b) -> MachineError a -> MachineError b
(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
<$ :: a -> MachineError b -> MachineError a
$c<$ :: forall a b. a -> MachineError b -> MachineError a
fmap :: (a -> b) -> MachineError a -> MachineError b
$cfmap :: forall a b. (a -> b) -> MachineError a -> MachineError b
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
$cto :: forall fun x. Rep (MachineError fun) x -> MachineError fun
$cfrom :: forall fun x. MachineError fun -> Rep (MachineError fun) x
Generic)
    deriving anyclass (MachineError fun -> ()
(MachineError fun -> ()) -> NFData (MachineError fun)
forall fun. NFData fun => MachineError fun -> ()
forall a. (a -> ()) -> NFData a
rnf :: MachineError fun -> ()
$crnf :: forall fun. NFData fun => MachineError fun -> ()
NFData)

-- | The type of errors (all of them) which can occur during evaluation
-- (some are used-caused, some are internal).
data EvaluationError user internal
    = InternalEvaluationError internal
      -- ^ Indicates bugs.
    | UserEvaluationError user
      -- ^ Indicates user errors.
    deriving stock (Int -> EvaluationError user internal -> ShowS
[EvaluationError user internal] -> ShowS
EvaluationError user internal -> String
(Int -> EvaluationError user internal -> ShowS)
-> (EvaluationError user internal -> String)
-> ([EvaluationError user internal] -> ShowS)
-> Show (EvaluationError user internal)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall user internal.
(Show internal, Show user) =>
Int -> EvaluationError user internal -> ShowS
forall user internal.
(Show internal, Show user) =>
[EvaluationError user internal] -> ShowS
forall user internal.
(Show internal, Show user) =>
EvaluationError user internal -> String
showList :: [EvaluationError user internal] -> ShowS
$cshowList :: forall user internal.
(Show internal, Show user) =>
[EvaluationError user internal] -> ShowS
show :: EvaluationError user internal -> String
$cshow :: forall user internal.
(Show internal, Show user) =>
EvaluationError user internal -> String
showsPrec :: Int -> EvaluationError user internal -> ShowS
$cshowsPrec :: forall user internal.
(Show internal, Show user) =>
Int -> EvaluationError user internal -> ShowS
Show, EvaluationError user internal
-> EvaluationError user internal -> Bool
(EvaluationError user internal
 -> EvaluationError user internal -> Bool)
-> (EvaluationError user internal
    -> EvaluationError user internal -> Bool)
-> Eq (EvaluationError user internal)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall user internal.
(Eq internal, Eq user) =>
EvaluationError user internal
-> EvaluationError user internal -> Bool
/= :: EvaluationError user internal
-> EvaluationError user internal -> Bool
$c/= :: forall user internal.
(Eq internal, Eq user) =>
EvaluationError user internal
-> EvaluationError user internal -> Bool
== :: EvaluationError user internal
-> EvaluationError user internal -> Bool
$c== :: forall user internal.
(Eq internal, Eq user) =>
EvaluationError user internal
-> EvaluationError user internal -> Bool
Eq, a -> EvaluationError user b -> EvaluationError user a
(a -> b) -> EvaluationError user a -> EvaluationError user b
(forall a b.
 (a -> b) -> EvaluationError user a -> EvaluationError user b)
-> (forall a b.
    a -> EvaluationError user b -> EvaluationError user a)
-> Functor (EvaluationError user)
forall a b. a -> EvaluationError user b -> EvaluationError user a
forall a b.
(a -> b) -> EvaluationError user a -> EvaluationError user b
forall user a b.
a -> EvaluationError user b -> EvaluationError user a
forall user a b.
(a -> b) -> EvaluationError user a -> EvaluationError user b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> EvaluationError user b -> EvaluationError user a
$c<$ :: forall user a b.
a -> EvaluationError user b -> EvaluationError user a
fmap :: (a -> b) -> EvaluationError user a -> EvaluationError user b
$cfmap :: forall user a b.
(a -> b) -> EvaluationError user a -> EvaluationError user b
Functor, (forall x.
 EvaluationError user internal
 -> Rep (EvaluationError user internal) x)
-> (forall x.
    Rep (EvaluationError user internal) x
    -> EvaluationError user internal)
-> Generic (EvaluationError user internal)
forall x.
Rep (EvaluationError user internal) x
-> EvaluationError user internal
forall x.
EvaluationError user internal
-> Rep (EvaluationError user internal) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall user internal x.
Rep (EvaluationError user internal) x
-> EvaluationError user internal
forall user internal x.
EvaluationError user internal
-> Rep (EvaluationError user internal) x
$cto :: forall user internal x.
Rep (EvaluationError user internal) x
-> EvaluationError user internal
$cfrom :: forall user internal x.
EvaluationError user internal
-> Rep (EvaluationError user internal) x
Generic)
    deriving anyclass (EvaluationError user internal -> ()
(EvaluationError user internal -> ())
-> NFData (EvaluationError user internal)
forall a. (a -> ()) -> NFData a
forall user internal.
(NFData internal, NFData user) =>
EvaluationError user internal -> ()
rnf :: EvaluationError user internal -> ()
$crnf :: forall user internal.
(NFData internal, NFData user) =>
EvaluationError user internal -> ()
NFData)

mtraverse makeClassyPrisms
    [ ''UnliftingError
    , ''MachineError
    , ''EvaluationError
    ]

instance internal ~ MachineError fun => AsMachineError (EvaluationError user internal) fun where
    _MachineError :: p (MachineError fun) (f (MachineError fun))
-> p (EvaluationError user internal)
     (f (EvaluationError user internal))
_MachineError = p (MachineError fun) (f (MachineError fun))
-> p (EvaluationError user internal)
     (f (EvaluationError user internal))
forall r user internal.
AsEvaluationError r user internal =>
Prism' r internal
_InternalEvaluationError
instance AsUnliftingError internal => AsUnliftingError (EvaluationError user internal) where
    _UnliftingError :: p UnliftingError (f UnliftingError)
-> p (EvaluationError user internal)
     (f (EvaluationError user internal))
_UnliftingError = p internal (f internal)
-> p (EvaluationError user internal)
     (f (EvaluationError user internal))
forall r user internal.
AsEvaluationError r user internal =>
Prism' r internal
_InternalEvaluationError (p internal (f internal)
 -> p (EvaluationError user internal)
      (f (EvaluationError user internal)))
-> (p UnliftingError (f UnliftingError) -> p internal (f internal))
-> p UnliftingError (f UnliftingError)
-> p (EvaluationError user internal)
     (f (EvaluationError user internal))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p UnliftingError (f UnliftingError) -> p internal (f internal)
forall r. AsUnliftingError r => Prism' r UnliftingError
_UnliftingError
instance AsUnliftingError (MachineError fun) where
    _UnliftingError :: p UnliftingError (f UnliftingError)
-> p (MachineError fun) (f (MachineError fun))
_UnliftingError = p UnliftingError (f UnliftingError)
-> p (MachineError fun) (f (MachineError fun))
forall r fun. AsMachineError r fun => Prism' r UnliftingError
_UnliftingMachineError
instance AsEvaluationFailure user => AsEvaluationFailure (EvaluationError user internal) where
    _EvaluationFailure :: p () (f ())
-> p (EvaluationError user internal)
     (f (EvaluationError user internal))
_EvaluationFailure = p user (f user)
-> p (EvaluationError user internal)
     (f (EvaluationError user internal))
forall r user internal.
AsEvaluationError r user internal =>
Prism' r user
_UserEvaluationError (p user (f user)
 -> p (EvaluationError user internal)
      (f (EvaluationError user internal)))
-> (p () (f ()) -> p user (f user))
-> p () (f ())
-> p (EvaluationError user internal)
     (f (EvaluationError user internal))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p () (f ()) -> p user (f user)
forall err. AsEvaluationFailure err => Prism' err ()
_EvaluationFailure

-- | An error and (optionally) what caused it.
data ErrorWithCause err cause = ErrorWithCause
    { ErrorWithCause err cause -> err
_ewcError :: err
    , ErrorWithCause err cause -> Maybe cause
_ewcCause :: Maybe cause
    } deriving stock (ErrorWithCause err cause -> ErrorWithCause err cause -> Bool
(ErrorWithCause err cause -> ErrorWithCause err cause -> Bool)
-> (ErrorWithCause err cause -> ErrorWithCause err cause -> Bool)
-> Eq (ErrorWithCause err cause)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall err cause.
(Eq err, Eq cause) =>
ErrorWithCause err cause -> ErrorWithCause err cause -> Bool
/= :: ErrorWithCause err cause -> ErrorWithCause err cause -> Bool
$c/= :: forall err cause.
(Eq err, Eq cause) =>
ErrorWithCause err cause -> ErrorWithCause err cause -> Bool
== :: ErrorWithCause err cause -> ErrorWithCause err cause -> Bool
$c== :: forall err cause.
(Eq err, Eq cause) =>
ErrorWithCause err cause -> ErrorWithCause err cause -> Bool
Eq, a -> ErrorWithCause err b -> ErrorWithCause err a
(a -> b) -> ErrorWithCause err a -> ErrorWithCause err b
(forall a b.
 (a -> b) -> ErrorWithCause err a -> ErrorWithCause err b)
-> (forall a b. a -> ErrorWithCause err b -> ErrorWithCause err a)
-> Functor (ErrorWithCause err)
forall a b. a -> ErrorWithCause err b -> ErrorWithCause err a
forall a b.
(a -> b) -> ErrorWithCause err a -> ErrorWithCause err b
forall err a b. a -> ErrorWithCause err b -> ErrorWithCause err a
forall err a b.
(a -> b) -> ErrorWithCause err a -> ErrorWithCause err b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ErrorWithCause err b -> ErrorWithCause err a
$c<$ :: forall err a b. a -> ErrorWithCause err b -> ErrorWithCause err a
fmap :: (a -> b) -> ErrorWithCause err a -> ErrorWithCause err b
$cfmap :: forall err a b.
(a -> b) -> ErrorWithCause err a -> ErrorWithCause err b
Functor, ErrorWithCause err a -> Bool
(a -> m) -> ErrorWithCause err a -> m
(a -> b -> b) -> b -> ErrorWithCause err a -> b
(forall m. Monoid m => ErrorWithCause err m -> m)
-> (forall m a. Monoid m => (a -> m) -> ErrorWithCause err a -> m)
-> (forall m a. Monoid m => (a -> m) -> ErrorWithCause err a -> m)
-> (forall a b. (a -> b -> b) -> b -> ErrorWithCause err a -> b)
-> (forall a b. (a -> b -> b) -> b -> ErrorWithCause err a -> b)
-> (forall b a. (b -> a -> b) -> b -> ErrorWithCause err a -> b)
-> (forall b a. (b -> a -> b) -> b -> ErrorWithCause err a -> b)
-> (forall a. (a -> a -> a) -> ErrorWithCause err a -> a)
-> (forall a. (a -> a -> a) -> ErrorWithCause err a -> a)
-> (forall a. ErrorWithCause err a -> [a])
-> (forall a. ErrorWithCause err a -> Bool)
-> (forall a. ErrorWithCause err a -> Int)
-> (forall a. Eq a => a -> ErrorWithCause err a -> Bool)
-> (forall a. Ord a => ErrorWithCause err a -> a)
-> (forall a. Ord a => ErrorWithCause err a -> a)
-> (forall a. Num a => ErrorWithCause err a -> a)
-> (forall a. Num a => ErrorWithCause err a -> a)
-> Foldable (ErrorWithCause err)
forall a. Eq a => a -> ErrorWithCause err a -> Bool
forall a. Num a => ErrorWithCause err a -> a
forall a. Ord a => ErrorWithCause err a -> a
forall m. Monoid m => ErrorWithCause err m -> m
forall a. ErrorWithCause err a -> Bool
forall a. ErrorWithCause err a -> Int
forall a. ErrorWithCause err a -> [a]
forall a. (a -> a -> a) -> ErrorWithCause err a -> a
forall err a. Eq a => a -> ErrorWithCause err a -> Bool
forall err a. Num a => ErrorWithCause err a -> a
forall err a. Ord a => ErrorWithCause err a -> a
forall m a. Monoid m => (a -> m) -> ErrorWithCause err a -> m
forall err m. Monoid m => ErrorWithCause err m -> m
forall err a. ErrorWithCause err a -> Bool
forall err a. ErrorWithCause err a -> Int
forall err a. ErrorWithCause err a -> [a]
forall b a. (b -> a -> b) -> b -> ErrorWithCause err a -> b
forall a b. (a -> b -> b) -> b -> ErrorWithCause err a -> b
forall err a. (a -> a -> a) -> ErrorWithCause err a -> a
forall err m a. Monoid m => (a -> m) -> ErrorWithCause err a -> m
forall err b a. (b -> a -> b) -> b -> ErrorWithCause err a -> b
forall err a b. (a -> b -> b) -> b -> ErrorWithCause err a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: ErrorWithCause err a -> a
$cproduct :: forall err a. Num a => ErrorWithCause err a -> a
sum :: ErrorWithCause err a -> a
$csum :: forall err a. Num a => ErrorWithCause err a -> a
minimum :: ErrorWithCause err a -> a
$cminimum :: forall err a. Ord a => ErrorWithCause err a -> a
maximum :: ErrorWithCause err a -> a
$cmaximum :: forall err a. Ord a => ErrorWithCause err a -> a
elem :: a -> ErrorWithCause err a -> Bool
$celem :: forall err a. Eq a => a -> ErrorWithCause err a -> Bool
length :: ErrorWithCause err a -> Int
$clength :: forall err a. ErrorWithCause err a -> Int
null :: ErrorWithCause err a -> Bool
$cnull :: forall err a. ErrorWithCause err a -> Bool
toList :: ErrorWithCause err a -> [a]
$ctoList :: forall err a. ErrorWithCause err a -> [a]
foldl1 :: (a -> a -> a) -> ErrorWithCause err a -> a
$cfoldl1 :: forall err a. (a -> a -> a) -> ErrorWithCause err a -> a
foldr1 :: (a -> a -> a) -> ErrorWithCause err a -> a
$cfoldr1 :: forall err a. (a -> a -> a) -> ErrorWithCause err a -> a
foldl' :: (b -> a -> b) -> b -> ErrorWithCause err a -> b
$cfoldl' :: forall err b a. (b -> a -> b) -> b -> ErrorWithCause err a -> b
foldl :: (b -> a -> b) -> b -> ErrorWithCause err a -> b
$cfoldl :: forall err b a. (b -> a -> b) -> b -> ErrorWithCause err a -> b
foldr' :: (a -> b -> b) -> b -> ErrorWithCause err a -> b
$cfoldr' :: forall err a b. (a -> b -> b) -> b -> ErrorWithCause err a -> b
foldr :: (a -> b -> b) -> b -> ErrorWithCause err a -> b
$cfoldr :: forall err a b. (a -> b -> b) -> b -> ErrorWithCause err a -> b
foldMap' :: (a -> m) -> ErrorWithCause err a -> m
$cfoldMap' :: forall err m a. Monoid m => (a -> m) -> ErrorWithCause err a -> m
foldMap :: (a -> m) -> ErrorWithCause err a -> m
$cfoldMap :: forall err m a. Monoid m => (a -> m) -> ErrorWithCause err a -> m
fold :: ErrorWithCause err m -> m
$cfold :: forall err m. Monoid m => ErrorWithCause err m -> m
Foldable, Functor (ErrorWithCause err)
Foldable (ErrorWithCause err)
Functor (ErrorWithCause err)
-> Foldable (ErrorWithCause err)
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> ErrorWithCause err a -> f (ErrorWithCause err b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    ErrorWithCause err (f a) -> f (ErrorWithCause err a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> ErrorWithCause err a -> m (ErrorWithCause err b))
-> (forall (m :: * -> *) a.
    Monad m =>
    ErrorWithCause err (m a) -> m (ErrorWithCause err a))
-> Traversable (ErrorWithCause err)
(a -> f b) -> ErrorWithCause err a -> f (ErrorWithCause err b)
forall err. Functor (ErrorWithCause err)
forall err. Foldable (ErrorWithCause err)
forall err (m :: * -> *) a.
Monad m =>
ErrorWithCause err (m a) -> m (ErrorWithCause err a)
forall err (f :: * -> *) a.
Applicative f =>
ErrorWithCause err (f a) -> f (ErrorWithCause err a)
forall err (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ErrorWithCause err a -> m (ErrorWithCause err b)
forall err (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ErrorWithCause err a -> f (ErrorWithCause err b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
ErrorWithCause err (m a) -> m (ErrorWithCause err a)
forall (f :: * -> *) a.
Applicative f =>
ErrorWithCause err (f a) -> f (ErrorWithCause err a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ErrorWithCause err a -> m (ErrorWithCause err b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ErrorWithCause err a -> f (ErrorWithCause err b)
sequence :: ErrorWithCause err (m a) -> m (ErrorWithCause err a)
$csequence :: forall err (m :: * -> *) a.
Monad m =>
ErrorWithCause err (m a) -> m (ErrorWithCause err a)
mapM :: (a -> m b) -> ErrorWithCause err a -> m (ErrorWithCause err b)
$cmapM :: forall err (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ErrorWithCause err a -> m (ErrorWithCause err b)
sequenceA :: ErrorWithCause err (f a) -> f (ErrorWithCause err a)
$csequenceA :: forall err (f :: * -> *) a.
Applicative f =>
ErrorWithCause err (f a) -> f (ErrorWithCause err a)
traverse :: (a -> f b) -> ErrorWithCause err a -> f (ErrorWithCause err b)
$ctraverse :: forall err (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ErrorWithCause err a -> f (ErrorWithCause err b)
$cp2Traversable :: forall err. Foldable (ErrorWithCause err)
$cp1Traversable :: forall err. Functor (ErrorWithCause err)
Traversable, (forall x.
 ErrorWithCause err cause -> Rep (ErrorWithCause err cause) x)
-> (forall x.
    Rep (ErrorWithCause err cause) x -> ErrorWithCause err cause)
-> Generic (ErrorWithCause err cause)
forall x.
Rep (ErrorWithCause err cause) x -> ErrorWithCause err cause
forall x.
ErrorWithCause err cause -> Rep (ErrorWithCause err cause) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall err cause x.
Rep (ErrorWithCause err cause) x -> ErrorWithCause err cause
forall err cause x.
ErrorWithCause err cause -> Rep (ErrorWithCause err cause) x
$cto :: forall err cause x.
Rep (ErrorWithCause err cause) x -> ErrorWithCause err cause
$cfrom :: forall err cause x.
ErrorWithCause err cause -> Rep (ErrorWithCause err cause) x
Generic)
    deriving anyclass (ErrorWithCause err cause -> ()
(ErrorWithCause err cause -> ())
-> NFData (ErrorWithCause err cause)
forall a. (a -> ()) -> NFData a
forall err cause.
(NFData err, NFData cause) =>
ErrorWithCause err cause -> ()
rnf :: ErrorWithCause err cause -> ()
$crnf :: forall err cause.
(NFData err, NFData cause) =>
ErrorWithCause err cause -> ()
NFData)

instance Bifunctor ErrorWithCause where
    bimap :: (a -> b) -> (c -> d) -> ErrorWithCause a c -> ErrorWithCause b d
bimap a -> b
f c -> d
g (ErrorWithCause a
err Maybe c
cause) = b -> Maybe d -> ErrorWithCause b d
forall err cause. err -> Maybe cause -> ErrorWithCause err cause
ErrorWithCause (a -> b
f a
err) (c -> d
g (c -> d) -> Maybe c -> Maybe d
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe c
cause)

instance AsEvaluationFailure err => AsEvaluationFailure (ErrorWithCause err cause) where
    _EvaluationFailure :: p () (f ())
-> p (ErrorWithCause err cause) (f (ErrorWithCause err cause))
_EvaluationFailure = (ErrorWithCause err cause -> err)
-> (err -> ErrorWithCause err cause)
-> Iso
     (ErrorWithCause err cause) (ErrorWithCause err cause) err err
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso ErrorWithCause err cause -> err
forall err cause. ErrorWithCause err cause -> err
_ewcError ((err -> Maybe cause -> ErrorWithCause err cause)
-> Maybe cause -> err -> ErrorWithCause err cause
forall a b c. (a -> b -> c) -> b -> a -> c
flip err -> Maybe cause -> ErrorWithCause err cause
forall err cause. err -> Maybe cause -> ErrorWithCause err cause
ErrorWithCause Maybe cause
forall a. Maybe a
Nothing) (p err (f err)
 -> p (ErrorWithCause err cause) (f (ErrorWithCause err cause)))
-> (p () (f ()) -> p err (f err))
-> p () (f ())
-> p (ErrorWithCause err cause) (f (ErrorWithCause err cause))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p () (f ()) -> p err (f err)
forall err. AsEvaluationFailure err => Prism' err ()
_EvaluationFailure

instance (Pretty err, Pretty cause) => Pretty (ErrorWithCause err cause) where
    pretty :: ErrorWithCause err cause -> Doc ann
pretty (ErrorWithCause err
e Maybe cause
c) = err -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty err
e Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"caused by:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Maybe cause -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Maybe cause
c

type EvaluationException user internal =
    ErrorWithCause (EvaluationError user internal)

mapCauseInMachineException
    :: (term1 -> term2)
    -> EvaluationException user (MachineError fun) term1
    -> EvaluationException user (MachineError fun) term2
mapCauseInMachineException :: (term1 -> term2)
-> EvaluationException user (MachineError fun) term1
-> EvaluationException user (MachineError fun) term2
mapCauseInMachineException = (term1 -> term2)
-> EvaluationException user (MachineError fun) term1
-> EvaluationException user (MachineError fun) term2
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap

-- | "Prismatically" throw an error and its (optional) cause.
throwingWithCause
    -- Binds exc so it can be used as a convenient parameter with TypeApplications
    :: forall exc e t term m x
    . (exc ~ ErrorWithCause e term, MonadError exc m)
    => AReview e t -> t -> Maybe term -> m x
throwingWithCause :: AReview e t -> t -> Maybe term -> m x
throwingWithCause AReview e t
l t
t Maybe term
cause = AReview e t -> (e -> m x) -> t -> m x
forall b (m :: * -> *) t r.
MonadReader b m =>
AReview t b -> (t -> r) -> m r
reviews AReview e t
l (\e
e -> ErrorWithCause e term -> m x
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ErrorWithCause e term -> m x) -> ErrorWithCause e term -> m x
forall a b. (a -> b) -> a -> b
$ e -> Maybe term -> ErrorWithCause e term
forall err cause. err -> Maybe cause -> ErrorWithCause err cause
ErrorWithCause e
e Maybe term
cause) t
t

{- Note [Ignoring context in UserEvaluationError]
The UserEvaluationError error has a term argument, but
extractEvaluationResult 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
UserEvaluationError is used in cases when a PLC program itself goes
wrong (for example, a failure due to `(error)`, a failure during
builtin evavluation, or exceeding the gas limit).  This is used to
signal unsuccessful in validation and so is not regarded as a real
error; in contrast, machine errors, typechecking failures,
and so on are genuine errors and we report their context if available.
 -}

-- | Turn any 'UserEvaluationError' into an 'EvaluationFailure'.
extractEvaluationResult
    :: Either (EvaluationException user internal term) a
    -> Either (ErrorWithCause internal term) (EvaluationResult a)
extractEvaluationResult :: Either (EvaluationException user internal term) a
-> Either (ErrorWithCause internal term) (EvaluationResult a)
extractEvaluationResult (Right a
term) = EvaluationResult a
-> Either (ErrorWithCause internal term) (EvaluationResult a)
forall a b. b -> Either a b
Right (EvaluationResult a
 -> Either (ErrorWithCause internal term) (EvaluationResult a))
-> EvaluationResult a
-> Either (ErrorWithCause internal term) (EvaluationResult a)
forall a b. (a -> b) -> a -> b
$ a -> EvaluationResult a
forall a. a -> EvaluationResult a
EvaluationSuccess a
term
extractEvaluationResult (Left (ErrorWithCause EvaluationError user internal
evalErr Maybe term
cause)) = case EvaluationError user internal
evalErr of
    InternalEvaluationError internal
err -> ErrorWithCause internal term
-> Either (ErrorWithCause internal term) (EvaluationResult a)
forall a b. a -> Either a b
Left  (ErrorWithCause internal term
 -> Either (ErrorWithCause internal term) (EvaluationResult a))
-> ErrorWithCause internal term
-> Either (ErrorWithCause internal term) (EvaluationResult a)
forall a b. (a -> b) -> a -> b
$ internal -> Maybe term -> ErrorWithCause internal term
forall err cause. err -> Maybe cause -> ErrorWithCause err cause
ErrorWithCause internal
err Maybe term
cause
    UserEvaluationError user
_       -> EvaluationResult a
-> Either (ErrorWithCause internal term) (EvaluationResult a)
forall a b. b -> Either a b
Right (EvaluationResult a
 -> Either (ErrorWithCause internal term) (EvaluationResult a))
-> EvaluationResult a
-> Either (ErrorWithCause internal term) (EvaluationResult a)
forall a b. (a -> b) -> a -> b
$ EvaluationResult a
forall a. EvaluationResult a
EvaluationFailure

unsafeExtractEvaluationResult
    :: (PrettyPlc internal, PrettyPlc term, Typeable internal, Typeable term)
    => Either (EvaluationException user internal term) a
    -> EvaluationResult a
unsafeExtractEvaluationResult :: Either (EvaluationException user internal term) a
-> EvaluationResult a
unsafeExtractEvaluationResult = (ErrorWithCause internal term -> EvaluationResult a)
-> (EvaluationResult a -> EvaluationResult a)
-> Either (ErrorWithCause internal term) (EvaluationResult a)
-> EvaluationResult a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ErrorWithCause internal term -> EvaluationResult a
forall a e. Exception e => e -> a
throw EvaluationResult a -> EvaluationResult a
forall a. a -> a
id (Either (ErrorWithCause internal term) (EvaluationResult a)
 -> EvaluationResult a)
-> (Either (EvaluationException user internal term) a
    -> Either (ErrorWithCause internal term) (EvaluationResult a))
-> Either (EvaluationException user internal term) a
-> EvaluationResult a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (EvaluationException user internal term) a
-> Either (ErrorWithCause internal term) (EvaluationResult a)
forall user internal term a.
Either (EvaluationException user internal term) a
-> Either (ErrorWithCause internal term) (EvaluationResult a)
extractEvaluationResult

instance Pretty UnliftingError where
    pretty :: UnliftingError -> Doc ann
pretty (UnliftingErrorE Text
err) = [Doc ann] -> Doc ann
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
        [ Doc ann
"Could not unlift a builtin:", Doc ann
forall ann. Doc ann
hardline
        , Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
err
        ]

instance (HasPrettyDefaults config ~ 'True, Pretty fun) =>
            PrettyBy config (MachineError fun) where
    prettyBy :: 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
_      MachineError fun
EmptyBuiltinArityMachineError =
        Doc ann
"A builtin was applied to a term or type where no more arguments were expected"
    prettyBy config
_      (UnliftingMachineError UnliftingError
unliftingError)  =
        UnliftingError -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty UnliftingError
unliftingError
    prettyBy config
_      (UnknownBuiltin fun
fun)                  =
        Doc ann
"Encountered an unknown built-in function:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> fun -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty fun
fun

instance
        ( HasPrettyDefaults config ~ 'True
        , PrettyBy config internal, Pretty user
        ) => PrettyBy config (EvaluationError user internal) where
    prettyBy :: config -> EvaluationError user internal -> Doc ann
prettyBy config
config (InternalEvaluationError internal
err) = [Doc ann] -> Doc ann
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
        [ Doc ann
"error:", Doc ann
forall ann. Doc ann
hardline
        , config -> internal -> Doc ann
forall config a ann. PrettyBy config a => config -> a -> Doc ann
prettyBy config
config internal
err
        ]
    prettyBy config
_      (UserEvaluationError user
err) = [Doc ann] -> Doc ann
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
        [ Doc ann
"User error:", Doc ann
forall ann. Doc ann
hardline
        , user -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty user
err
        ]

instance (PrettyBy config cause, PrettyBy config err) =>
            PrettyBy config (ErrorWithCause err cause) where
    prettyBy :: config -> ErrorWithCause err cause -> Doc ann
prettyBy config
config (ErrorWithCause err
err Maybe cause
mayCause) =
        Doc ann
"An error has occurred: " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> config -> err -> Doc ann
forall config a ann. PrettyBy config a => config -> a -> Doc ann
prettyBy config
config err
err Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<>
            case Maybe cause
mayCause of
                Maybe cause
Nothing    -> Doc ann
forall a. Monoid a => a
mempty
                Just cause
cause -> Doc ann
forall ann. Doc ann
hardline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"Caused by:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> config -> cause -> Doc ann
forall config a ann. PrettyBy config a => config -> a -> Doc ann
prettyBy config
config cause
cause

instance (PrettyPlc cause, PrettyPlc err) =>
            Show (ErrorWithCause err cause) where
    show :: ErrorWithCause err cause -> String
show = Doc Any -> String
forall str ann. Render str => Doc ann -> str
render (Doc Any -> String)
-> (ErrorWithCause err cause -> Doc Any)
-> ErrorWithCause err cause
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorWithCause err cause -> Doc Any
forall a ann. PrettyPlc a => a -> Doc ann
prettyPlcReadableDebug

deriving anyclass instance
    (PrettyPlc cause, PrettyPlc err, Typeable cause, Typeable err) => Exception (ErrorWithCause err cause)

instance HasErrorCode UnliftingError where
      errorCode :: UnliftingError -> ErrorCode
errorCode        UnliftingErrorE {}        = Natural -> ErrorCode
ErrorCode Natural
30

instance HasErrorCode (MachineError err) where
      errorCode :: MachineError err -> ErrorCode
errorCode        EmptyBuiltinArityMachineError {}             = Natural -> ErrorCode
ErrorCode Natural
34
      errorCode        UnexpectedBuiltinTermArgumentMachineError {} = Natural -> ErrorCode
ErrorCode Natural
33
      errorCode        BuiltinTermArgumentExpectedMachineError {}   = Natural -> ErrorCode
ErrorCode Natural
32
      errorCode        OpenTermEvaluatedMachineError {}             = Natural -> ErrorCode
ErrorCode Natural
27
      errorCode        NonFunctionalApplicationMachineError {}      = Natural -> ErrorCode
ErrorCode Natural
26
      errorCode        NonWrapUnwrappedMachineError {}              = Natural -> ErrorCode
ErrorCode Natural
25
      errorCode        NonPolymorphicInstantiationMachineError {}   = Natural -> ErrorCode
ErrorCode Natural
24
      errorCode        (UnliftingMachineError UnliftingError
e)                    = UnliftingError -> ErrorCode
forall a. HasErrorCode a => a -> ErrorCode
errorCode UnliftingError
e
      errorCode        UnknownBuiltin {}                            = Natural -> ErrorCode
ErrorCode Natural
17

instance (HasErrorCode user, HasErrorCode internal) => HasErrorCode (EvaluationError user internal) where
  errorCode :: EvaluationError user internal -> ErrorCode
errorCode (InternalEvaluationError internal
e) = internal -> ErrorCode
forall a. HasErrorCode a => a -> ErrorCode
errorCode internal
e
  errorCode (UserEvaluationError user
e)     = user -> ErrorCode
forall a. HasErrorCode a => a -> ErrorCode
errorCode user
e

instance HasErrorCode err => HasErrorCode (ErrorWithCause err t) where
    errorCode :: ErrorWithCause err t -> ErrorCode
errorCode (ErrorWithCause err
e Maybe t
_) = err -> ErrorCode
forall a. HasErrorCode a => a -> ErrorCode
errorCode err
e