{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}

module PlutusCore.Evaluation.ErrorWithCause
    ( ErrorWithCause (..)
    , throwingWithCause
    , throwingWithCause_
    , throwBuiltinErrorWithCause
    ) where

import PlutusPrelude

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

import Control.Lens
import Control.Monad.Except
import Prettyprinter

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

instance Bifunctor ErrorWithCause where
    bimap :: forall a b c d.
(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)
    {-# INLINE bimap #-}

instance AsEvaluationFailure err => AsEvaluationFailure (ErrorWithCause err cause) where
    _EvaluationFailure :: Prism' (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 ()
Prism' err ()
_EvaluationFailure
    {-# INLINE _EvaluationFailure #-}

instance (Pretty err, Pretty cause) => Pretty (ErrorWithCause err cause) where
    pretty :: forall ann. ErrorWithCause err cause -> Doc ann
pretty (ErrorWithCause err
e Maybe cause
c) = err -> Doc ann
forall ann. 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 ann. Maybe cause -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Maybe cause
c

instance (PrettyBy config cause, PrettyBy config err) =>
            PrettyBy config (ErrorWithCause err cause) where
    prettyBy :: forall ann. config -> ErrorWithCause err cause -> Doc ann
prettyBy config
config (ErrorWithCause err
err Maybe cause
mayCause) = [Doc ann] -> Doc ann
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
        [ Doc ann
"An error has occurred:"
        , Doc ann
forall ann. Doc ann
hardline
        , config -> err -> Doc ann
forall ann. config -> err -> Doc ann
forall config a ann. PrettyBy config a => config -> a -> Doc ann
prettyBy config
config err
err
        , 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 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 ann. Doc ann -> 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
prettyPlcReadableSimple

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

-- | "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 :: 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
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 a. ErrorWithCause e term -> m a
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
{-# INLINE throwingWithCause #-}

-- | "Prismatically" throw a contentless error and its (optional) cause. 'throwingWithCause_' is to
-- 'throwingWithCause' as 'throwing_' is to 'throwing'.
throwingWithCause_
    -- Binds @exc@ so it can be used as a convenient parameter with @TypeApplications@.
    :: forall exc e term m x. (exc ~ ErrorWithCause e term, MonadError exc m)
    => AReview e () -> Maybe term -> m x
throwingWithCause_ :: forall exc e term (m :: * -> *) x.
(exc ~ ErrorWithCause e term, MonadError exc m) =>
AReview e () -> Maybe term -> m x
throwingWithCause_ AReview e ()
l = AReview e () -> () -> Maybe term -> m x
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 ()
l ()
{-# INLINE throwingWithCause_ #-}

-- | 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 (ErrorWithCause err cause) m
       , AsUnliftingEvaluationError err, AsEvaluationFailure err
       )
    => cause -> BuiltinError -> m void
throwBuiltinErrorWithCause :: forall err cause (m :: * -> *) void.
(MonadError (ErrorWithCause err cause) m,
 AsUnliftingEvaluationError err, AsEvaluationFailure err) =>
cause -> BuiltinError -> m void
throwBuiltinErrorWithCause cause
cause = \case
    BuiltinUnliftingEvaluationError UnliftingEvaluationError
unlErr ->
        AReview err UnliftingEvaluationError
-> UnliftingEvaluationError -> Maybe cause -> m void
forall exc e t term (m :: * -> *) x.
(exc ~ ErrorWithCause e term, MonadError exc m) =>
AReview e t -> t -> Maybe term -> m x
throwingWithCause AReview err UnliftingEvaluationError
forall r.
AsUnliftingEvaluationError r =>
Prism' r UnliftingEvaluationError
Prism' err UnliftingEvaluationError
_UnliftingEvaluationError UnliftingEvaluationError
unlErr (Maybe cause -> m void) -> Maybe cause -> m void
forall a b. (a -> b) -> a -> b
$ cause -> Maybe cause
forall a. a -> Maybe a
Just cause
cause
    BuiltinError
BuiltinEvaluationFailure ->
        AReview err () -> Maybe cause -> m void
forall exc e term (m :: * -> *) x.
(exc ~ ErrorWithCause e term, MonadError exc m) =>
AReview e () -> Maybe term -> m x
throwingWithCause_ AReview err ()
forall err. AsEvaluationFailure err => Prism' err ()
Prism' err ()
_EvaluationFailure (Maybe cause -> m void) -> Maybe cause -> m void
forall a b. (a -> b) -> a -> b
$ cause -> Maybe cause
forall a. a -> Maybe a
Just cause
cause
{-# INLINE throwBuiltinErrorWithCause #-}