-- editorconfig-checker-disable-file
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase             #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE OverloadedStrings      #-}
{-# LANGUAGE RankNTypes             #-}
{-# LANGUAGE StrictData             #-}
{-# LANGUAGE TemplateHaskell        #-}

module PlutusCore.Builtin.Result
    ( EvaluationError (..)
    , AsEvaluationError (..)
    , UnliftingError (..)
    , UnliftingEvaluationError (..)
    , BuiltinError (..)
    , BuiltinResult (..)
    , AsUnliftingEvaluationError (..)
    , AsUnliftingError (..)
    , AsBuiltinError (..)
    , AsBuiltinResult (..)
    , _UnliftingErrorVia
    , _StructuralUnliftingError
    , _OperationalUnliftingError
    , throwNotAConstant
    , throwUnderTypeError
    , emit
    , withLogs
    , throwing
    , throwing_
    ) where

import PlutusPrelude

import PlutusCore.Evaluation.Error
import PlutusCore.Evaluation.Result

import Control.Lens
import Control.Monad.Error.Lens (throwing, throwing_)
import Control.Monad.Except
import Data.Bitraversable
import Data.DList (DList)
import Data.String (IsString)
import Data.Text (Text)
import Data.Text qualified as Text
import Prettyprinter

-- | The error message part of an 'UnliftingEvaluationError'.
newtype UnliftingError = MkUnliftingError
    { UnliftingError -> Text
unUnliftingError :: 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
$cshowsPrec :: Int -> UnliftingError -> ShowS
showsPrec :: Int -> UnliftingError -> ShowS
$cshow :: UnliftingError -> String
show :: UnliftingError -> String
$cshowList :: [UnliftingError] -> ShowS
showList :: [UnliftingError] -> ShowS
Show, UnliftingError -> UnliftingError -> Bool
(UnliftingError -> UnliftingError -> Bool)
-> (UnliftingError -> UnliftingError -> Bool) -> Eq UnliftingError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UnliftingError -> UnliftingError -> Bool
== :: UnliftingError -> UnliftingError -> Bool
$c/= :: UnliftingError -> UnliftingError -> Bool
/= :: UnliftingError -> UnliftingError -> Bool
Eq)
      deriving newtype (String -> UnliftingError
(String -> UnliftingError) -> IsString UnliftingError
forall a. (String -> a) -> IsString a
$cfromString :: String -> UnliftingError
fromString :: String -> UnliftingError
IsString, 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
$c<> :: UnliftingError -> UnliftingError -> UnliftingError
<> :: UnliftingError -> UnliftingError -> UnliftingError
$csconcat :: NonEmpty UnliftingError -> UnliftingError
sconcat :: NonEmpty UnliftingError -> UnliftingError
$cstimes :: forall b. Integral b => b -> UnliftingError -> UnliftingError
stimes :: forall b. Integral b => b -> UnliftingError -> UnliftingError
Semigroup, Semigroup UnliftingError
UnliftingError
Semigroup UnliftingError =>
UnliftingError
-> (UnliftingError -> UnliftingError -> UnliftingError)
-> ([UnliftingError] -> UnliftingError)
-> Monoid UnliftingError
[UnliftingError] -> UnliftingError
UnliftingError -> UnliftingError -> UnliftingError
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: UnliftingError
mempty :: UnliftingError
$cmappend :: UnliftingError -> UnliftingError -> UnliftingError
mappend :: UnliftingError -> UnliftingError -> UnliftingError
$cmconcat :: [UnliftingError] -> UnliftingError
mconcat :: [UnliftingError] -> UnliftingError
Monoid, UnliftingError -> ()
(UnliftingError -> ()) -> NFData UnliftingError
forall a. (a -> ()) -> NFData a
$crnf :: UnliftingError -> ()
rnf :: UnliftingError -> ()
NFData)

-- | When unlifting of a PLC term into a Haskell value fails, this error is thrown.
newtype UnliftingEvaluationError = MkUnliftingEvaluationError
    { UnliftingEvaluationError
-> EvaluationError UnliftingError UnliftingError
unUnliftingEvaluationError :: EvaluationError UnliftingError UnliftingError
    } deriving stock (Int -> UnliftingEvaluationError -> ShowS
[UnliftingEvaluationError] -> ShowS
UnliftingEvaluationError -> String
(Int -> UnliftingEvaluationError -> ShowS)
-> (UnliftingEvaluationError -> String)
-> ([UnliftingEvaluationError] -> ShowS)
-> Show UnliftingEvaluationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UnliftingEvaluationError -> ShowS
showsPrec :: Int -> UnliftingEvaluationError -> ShowS
$cshow :: UnliftingEvaluationError -> String
show :: UnliftingEvaluationError -> String
$cshowList :: [UnliftingEvaluationError] -> ShowS
showList :: [UnliftingEvaluationError] -> ShowS
Show, UnliftingEvaluationError -> UnliftingEvaluationError -> Bool
(UnliftingEvaluationError -> UnliftingEvaluationError -> Bool)
-> (UnliftingEvaluationError -> UnliftingEvaluationError -> Bool)
-> Eq UnliftingEvaluationError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UnliftingEvaluationError -> UnliftingEvaluationError -> Bool
== :: UnliftingEvaluationError -> UnliftingEvaluationError -> Bool
$c/= :: UnliftingEvaluationError -> UnliftingEvaluationError -> Bool
/= :: UnliftingEvaluationError -> UnliftingEvaluationError -> Bool
Eq)
      deriving newtype (UnliftingEvaluationError -> ()
(UnliftingEvaluationError -> ()) -> NFData UnliftingEvaluationError
forall a. (a -> ()) -> NFData a
$crnf :: UnliftingEvaluationError -> ()
rnf :: UnliftingEvaluationError -> ()
NFData)

-- | The type of errors that 'readKnown' and 'makeKnown' can return.
data BuiltinError
    = BuiltinUnliftingEvaluationError UnliftingEvaluationError
    | BuiltinEvaluationFailure
    deriving stock (Int -> BuiltinError -> ShowS
[BuiltinError] -> ShowS
BuiltinError -> String
(Int -> BuiltinError -> ShowS)
-> (BuiltinError -> String)
-> ([BuiltinError] -> ShowS)
-> Show BuiltinError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BuiltinError -> ShowS
showsPrec :: Int -> BuiltinError -> ShowS
$cshow :: BuiltinError -> String
show :: BuiltinError -> String
$cshowList :: [BuiltinError] -> ShowS
showList :: [BuiltinError] -> ShowS
Show, BuiltinError -> BuiltinError -> Bool
(BuiltinError -> BuiltinError -> Bool)
-> (BuiltinError -> BuiltinError -> Bool) -> Eq BuiltinError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BuiltinError -> BuiltinError -> Bool
== :: BuiltinError -> BuiltinError -> Bool
$c/= :: BuiltinError -> BuiltinError -> Bool
/= :: BuiltinError -> BuiltinError -> Bool
Eq)

-- | The monad that 'makeKnown' runs in.
-- Equivalent to @ExceptT BuiltinError (Writer (DList Text))@, except optimized in two ways:
--
-- 1. everything is strict
-- 2. has the 'BuiltinSuccess' constructor that is used for returning a value with no logs
--    attached, which is the most common case for us, so it helps a lot not to construct and
--    deconstruct a redundant tuple
--
-- Moving from @ExceptT BuiltinError (Writer (DList Text))@ to this data type gave us a speedup of
-- 8% of total evaluation time.
--
-- Logs are represented as a 'DList', because we don't particularly care about the efficiency of
-- logging, since there's no logging on the chain and builtins don't emit much anyway. Otherwise
-- we'd have to use @text-builder@ or @text-builder-linear@ or something of this sort.
data BuiltinResult a
    = -- 'BuiltinSuccess' is the first constructor to make it a bit more likely for GHC to
      -- branch-predict it (which is something that we want, because most builtins return this
      -- constructor). It is however not guaranteed that GHC will predict it, because even though
      -- it's likely going to be a recursive case (it certainly is in the CEK machine) and thus the
      -- constructor has precedence over 'BuiltinFailure', it doesn't have precedence over
      -- 'BuiltinSuccessWithLogs', since that case is equally likely to be recursive.
      --
      -- Unfortunately, GHC doesn't offer any explicit control over branch-prediction (see this
      -- ticket: https://gitlab.haskell.org/ghc/ghc/-/issues/849), so relying on hope is the best we
      -- can do here.
      BuiltinSuccess a
    | BuiltinSuccessWithLogs (DList Text) a
    | BuiltinFailure (DList Text) BuiltinError
    deriving stock (Int -> BuiltinResult a -> ShowS
[BuiltinResult a] -> ShowS
BuiltinResult a -> String
(Int -> BuiltinResult a -> ShowS)
-> (BuiltinResult a -> String)
-> ([BuiltinResult a] -> ShowS)
-> Show (BuiltinResult a)
forall a. Show a => Int -> BuiltinResult a -> ShowS
forall a. Show a => [BuiltinResult a] -> ShowS
forall a. Show a => BuiltinResult a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> BuiltinResult a -> ShowS
showsPrec :: Int -> BuiltinResult a -> ShowS
$cshow :: forall a. Show a => BuiltinResult a -> String
show :: BuiltinResult a -> String
$cshowList :: forall a. Show a => [BuiltinResult a] -> ShowS
showList :: [BuiltinResult a] -> ShowS
Show, (forall m. Monoid m => BuiltinResult m -> m)
-> (forall m a. Monoid m => (a -> m) -> BuiltinResult a -> m)
-> (forall m a. Monoid m => (a -> m) -> BuiltinResult a -> m)
-> (forall a b. (a -> b -> b) -> b -> BuiltinResult a -> b)
-> (forall a b. (a -> b -> b) -> b -> BuiltinResult a -> b)
-> (forall b a. (b -> a -> b) -> b -> BuiltinResult a -> b)
-> (forall b a. (b -> a -> b) -> b -> BuiltinResult a -> b)
-> (forall a. (a -> a -> a) -> BuiltinResult a -> a)
-> (forall a. (a -> a -> a) -> BuiltinResult a -> a)
-> (forall a. BuiltinResult a -> [a])
-> (forall a. BuiltinResult a -> Bool)
-> (forall a. BuiltinResult a -> Int)
-> (forall a. Eq a => a -> BuiltinResult a -> Bool)
-> (forall a. Ord a => BuiltinResult a -> a)
-> (forall a. Ord a => BuiltinResult a -> a)
-> (forall a. Num a => BuiltinResult a -> a)
-> (forall a. Num a => BuiltinResult a -> a)
-> Foldable BuiltinResult
forall a. Eq a => a -> BuiltinResult a -> Bool
forall a. Num a => BuiltinResult a -> a
forall a. Ord a => BuiltinResult a -> a
forall m. Monoid m => BuiltinResult m -> m
forall a. BuiltinResult a -> Bool
forall a. BuiltinResult a -> Int
forall a. BuiltinResult a -> [a]
forall a. (a -> a -> a) -> BuiltinResult a -> a
forall m a. Monoid m => (a -> m) -> BuiltinResult a -> m
forall b a. (b -> a -> b) -> b -> BuiltinResult a -> b
forall a b. (a -> b -> b) -> b -> BuiltinResult 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 m. Monoid m => BuiltinResult m -> m
fold :: forall m. Monoid m => BuiltinResult m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> BuiltinResult a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> BuiltinResult a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> BuiltinResult a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> BuiltinResult a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> BuiltinResult a -> b
foldr :: forall a b. (a -> b -> b) -> b -> BuiltinResult a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> BuiltinResult a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> BuiltinResult a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> BuiltinResult a -> b
foldl :: forall b a. (b -> a -> b) -> b -> BuiltinResult a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> BuiltinResult a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> BuiltinResult a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> BuiltinResult a -> a
foldr1 :: forall a. (a -> a -> a) -> BuiltinResult a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> BuiltinResult a -> a
foldl1 :: forall a. (a -> a -> a) -> BuiltinResult a -> a
$ctoList :: forall a. BuiltinResult a -> [a]
toList :: forall a. BuiltinResult a -> [a]
$cnull :: forall a. BuiltinResult a -> Bool
null :: forall a. BuiltinResult a -> Bool
$clength :: forall a. BuiltinResult a -> Int
length :: forall a. BuiltinResult a -> Int
$celem :: forall a. Eq a => a -> BuiltinResult a -> Bool
elem :: forall a. Eq a => a -> BuiltinResult a -> Bool
$cmaximum :: forall a. Ord a => BuiltinResult a -> a
maximum :: forall a. Ord a => BuiltinResult a -> a
$cminimum :: forall a. Ord a => BuiltinResult a -> a
minimum :: forall a. Ord a => BuiltinResult a -> a
$csum :: forall a. Num a => BuiltinResult a -> a
sum :: forall a. Num a => BuiltinResult a -> a
$cproduct :: forall a. Num a => BuiltinResult a -> a
product :: forall a. Num a => BuiltinResult a -> a
Foldable)

mtraverse makeClassyPrisms
    [ ''UnliftingError
    , ''UnliftingEvaluationError
    , ''BuiltinError
    , ''BuiltinResult
    ]

instance AsEvaluationError UnliftingEvaluationError UnliftingError UnliftingError where
    _EvaluationError :: Prism'
  UnliftingEvaluationError
  (EvaluationError UnliftingError UnliftingError)
_EvaluationError = p (EvaluationError UnliftingError UnliftingError)
  (f (EvaluationError UnliftingError UnliftingError))
-> p UnliftingEvaluationError (f UnliftingEvaluationError)
forall s t a b. (Coercible s a, Coercible t b) => Iso s t a b
Iso
  UnliftingEvaluationError
  UnliftingEvaluationError
  (EvaluationError UnliftingError UnliftingError)
  (EvaluationError UnliftingError UnliftingError)
coerced
    {-# INLINE _EvaluationError #-}

-- | An 'UnliftingEvaluationError' /is/ an 'EvaluationError', hence for this instance we only
-- require both @structural@ and @operational@ to have '_UnliftingError' prisms, so that we can
-- handle both the cases pointwisely.
instance (AsUnliftingError structural, AsUnliftingError operational) =>
        AsUnliftingEvaluationError (EvaluationError structural operational) where
    _UnliftingEvaluationError :: Prism'
  (EvaluationError structural operational) UnliftingEvaluationError
_UnliftingEvaluationError = p (EvaluationError UnliftingError UnliftingError)
  (f (EvaluationError UnliftingError UnliftingError))
-> p (EvaluationError structural operational)
     (f (EvaluationError structural operational))
go (p (EvaluationError UnliftingError UnliftingError)
   (f (EvaluationError UnliftingError UnliftingError))
 -> p (EvaluationError structural operational)
      (f (EvaluationError structural operational)))
-> (p UnliftingEvaluationError (f UnliftingEvaluationError)
    -> p (EvaluationError UnliftingError UnliftingError)
         (f (EvaluationError UnliftingError UnliftingError)))
-> p UnliftingEvaluationError (f UnliftingEvaluationError)
-> p (EvaluationError structural operational)
     (f (EvaluationError structural operational))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p UnliftingEvaluationError (f UnliftingEvaluationError)
-> p (EvaluationError UnliftingError UnliftingError)
     (f (EvaluationError UnliftingError UnliftingError))
forall s t a b. (Coercible s a, Coercible t b) => Iso s t a b
Iso
  (EvaluationError UnliftingError UnliftingError)
  (EvaluationError UnliftingError UnliftingError)
  UnliftingEvaluationError
  UnliftingEvaluationError
coerced where
        go :: p (EvaluationError UnliftingError UnliftingError)
  (f (EvaluationError UnliftingError UnliftingError))
-> p (EvaluationError structural operational)
     (f (EvaluationError structural operational))
go =
            (EvaluationError UnliftingError UnliftingError
 -> EvaluationError structural operational)
-> (EvaluationError structural operational
    -> Maybe (EvaluationError UnliftingError UnliftingError))
-> Prism'
     (EvaluationError structural operational)
     (EvaluationError UnliftingError UnliftingError)
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism'
                ((UnliftingError -> structural)
-> (UnliftingError -> operational)
-> EvaluationError UnliftingError UnliftingError
-> EvaluationError structural operational
forall a b c d.
(a -> b) -> (c -> d) -> EvaluationError a c -> EvaluationError b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap
                    (AReview structural UnliftingError -> UnliftingError -> structural
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview structural UnliftingError
forall r. AsUnliftingError r => Prism' r UnliftingError
Prism' structural UnliftingError
_UnliftingError)
                    (AReview operational UnliftingError -> UnliftingError -> operational
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview operational UnliftingError
forall r. AsUnliftingError r => Prism' r UnliftingError
Prism' operational UnliftingError
_UnliftingError))
                ((structural -> Maybe UnliftingError)
-> (operational -> Maybe UnliftingError)
-> EvaluationError structural operational
-> Maybe (EvaluationError UnliftingError UnliftingError)
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c)
-> (b -> f d) -> EvaluationError a b -> f (EvaluationError c d)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse
                    (Either structural UnliftingError -> Maybe UnliftingError
forall (f :: * -> *) (g :: * -> *) a.
(Foldable f, Alternative g) =>
f a -> g a
reoption (Either structural UnliftingError -> Maybe UnliftingError)
-> (structural -> Either structural UnliftingError)
-> structural
-> Maybe UnliftingError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. APrism structural structural UnliftingError UnliftingError
-> structural -> Either structural UnliftingError
forall s t a b. APrism s t a b -> s -> Either t a
matching APrism structural structural UnliftingError UnliftingError
forall r. AsUnliftingError r => Prism' r UnliftingError
Prism' structural UnliftingError
_UnliftingError)
                    (Either operational UnliftingError -> Maybe UnliftingError
forall (f :: * -> *) (g :: * -> *) a.
(Foldable f, Alternative g) =>
f a -> g a
reoption (Either operational UnliftingError -> Maybe UnliftingError)
-> (operational -> Either operational UnliftingError)
-> operational
-> Maybe UnliftingError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. APrism operational operational UnliftingError UnliftingError
-> operational -> Either operational UnliftingError
forall s t a b. APrism s t a b -> s -> Either t a
matching APrism operational operational UnliftingError UnliftingError
forall r. AsUnliftingError r => Prism' r UnliftingError
Prism' operational UnliftingError
_UnliftingError))
    {-# INLINE _UnliftingEvaluationError #-}

instance AsUnliftingEvaluationError BuiltinError where
    _UnliftingEvaluationError :: Prism' BuiltinError UnliftingEvaluationError
_UnliftingEvaluationError = p UnliftingEvaluationError (f UnliftingEvaluationError)
-> p BuiltinError (f BuiltinError)
forall r. AsBuiltinError r => Prism' r UnliftingEvaluationError
Prism' BuiltinError UnliftingEvaluationError
_BuiltinUnliftingEvaluationError (p UnliftingEvaluationError (f UnliftingEvaluationError)
 -> p BuiltinError (f BuiltinError))
-> (p UnliftingEvaluationError (f UnliftingEvaluationError)
    -> p UnliftingEvaluationError (f UnliftingEvaluationError))
-> p UnliftingEvaluationError (f UnliftingEvaluationError)
-> p BuiltinError (f BuiltinError)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p UnliftingEvaluationError (f UnliftingEvaluationError)
-> p UnliftingEvaluationError (f UnliftingEvaluationError)
forall r.
AsUnliftingEvaluationError r =>
Prism' r UnliftingEvaluationError
Prism' UnliftingEvaluationError UnliftingEvaluationError
_UnliftingEvaluationError
    {-# INLINE _UnliftingEvaluationError #-}

instance AsEvaluationFailure BuiltinError where
    _EvaluationFailure :: Prism' BuiltinError ()
_EvaluationFailure = BuiltinError -> Prism' BuiltinError ()
forall err. Eq err => err -> Prism' err ()
_EvaluationFailureVia BuiltinError
BuiltinEvaluationFailure
    {-# INLINE _EvaluationFailure #-}

-- >>> import PlutusCore.Evaluation.Result
-- >>> evaluationFailure :: BuiltinResult Bool
-- BuiltinFailure (fromList []) BuiltinEvaluationFailure
--
-- >>> import Control.Lens
-- >>> let res = BuiltinFailure (pure mempty) evaluationFailure :: BuiltinResult Bool
-- >>> matching _EvaluationFailure res
-- Right ()
--
-- >>> matching _BuiltinFailure $ BuiltinSuccess True
-- Left (BuiltinSuccess True)
instance AsEvaluationFailure (BuiltinResult a) where
    _EvaluationFailure :: Prism' (BuiltinResult a) ()
_EvaluationFailure = p (DList Text, BuiltinError) (f (DList Text, BuiltinError))
-> p (BuiltinResult a) (f (BuiltinResult a))
forall r a.
AsBuiltinResult r a =>
Prism' r (DList Text, BuiltinError)
Prism' (BuiltinResult a) (DList Text, BuiltinError)
_BuiltinFailure (p (DList Text, BuiltinError) (f (DList Text, BuiltinError))
 -> p (BuiltinResult a) (f (BuiltinResult a)))
-> (p () (f ())
    -> p (DList Text, BuiltinError) (f (DList Text, BuiltinError)))
-> p () (f ())
-> p (BuiltinResult a) (f (BuiltinResult a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((DList Text, BuiltinError) -> ())
-> (() -> (DList Text, BuiltinError))
-> Iso (DList Text, BuiltinError) (DList Text, BuiltinError) () ()
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (\(DList Text, BuiltinError)
_ -> ()) (\()
_ -> BuiltinError -> (DList Text, BuiltinError)
forall a. a -> (DList Text, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure BuiltinError
forall err. AsEvaluationFailure err => err
evaluationFailure)
    {-# INLINE _EvaluationFailure #-}

instance MonadFail BuiltinResult where
    fail :: forall a. String -> BuiltinResult a
fail String
err = DList Text -> BuiltinError -> BuiltinResult a
forall a. DList Text -> BuiltinError -> BuiltinResult a
BuiltinFailure (Text -> DList Text
forall a. a -> DList a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> DList Text) -> Text -> DList Text
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
err) BuiltinError
BuiltinEvaluationFailure
    {-# INLINE fail #-}

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

deriving newtype instance Pretty UnliftingEvaluationError

instance Pretty BuiltinError where
    pretty :: forall ann. BuiltinError -> Doc ann
pretty (BuiltinUnliftingEvaluationError UnliftingEvaluationError
err) = Doc ann
"Builtin evaluation failure:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> UnliftingEvaluationError -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. UnliftingEvaluationError -> Doc ann
pretty UnliftingEvaluationError
err
    pretty BuiltinError
BuiltinEvaluationFailure              = Doc ann
"Builtin evaluation failure"

{- Note [INLINE and OPAQUE on error-related definitions]
We mark error-related definitions such as prisms like '_StructuralUnliftingError' and regular
functions like 'throwNotAConstant' with @INLINE@, because this produces significantly less cluttered
GHC Core. Not doing so results in 20+% larger Core for builtins.

However in a few specific cases we use @OPAQUE@ instead to get tighter Core. @OPAQUE@ is the same as
@NOINLINE@ except the former _actually_ prevents GHC from inlining the definition unlike the latter.
See this for details: https://github.com/ghc-proposals/ghc-proposals/blob/5577fd008924de8d89cfa9855fa454512e7dcc75/proposals/0415-opaque-pragma.rst

It's hard to predict where @OPAQUE@ instead of @INLINE@ will help to make GHC Core tidier, so it's
mostly just looking into the Core and seeing where there's obvious duplication that can be removed.
Such cases tend to be functions returning a value of a concrete error type (as opposed to a type
variable).
-}

-- See Note [Ignoring context in OperationalEvaluationError].
-- | Construct a prism focusing on the @*EvaluationFailure@ part of @err@ by taking
-- that @*EvaluationFailure@ and
--
-- 1. pretty-printing and embedding it into an 'UnliftingError' for the setter part of the prism
-- 2. returning it directly for the opposite direction (there's no other way to convert an
--    'UnliftingError' to an evaluation failure, since the latter doesn't carry any content)
--
-- This is useful for providing 'AsUnliftingError' instances for types such as 'CkUserError' and
-- 'CekUserError'.
_UnliftingErrorVia :: Pretty err => err -> Prism' err UnliftingError
_UnliftingErrorVia :: forall err. Pretty err => err -> Prism' err UnliftingError
_UnliftingErrorVia err
err = (err -> UnliftingError)
-> (UnliftingError -> err)
-> Iso err err UnliftingError UnliftingError
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (Text -> UnliftingError
MkUnliftingError (Text -> UnliftingError) -> (err -> Text) -> err -> UnliftingError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. err -> Text
forall str a. (Pretty a, Render str) => a -> str
display) (err -> UnliftingError -> err
forall a b. a -> b -> a
const err
err)
{-# INLINE _UnliftingErrorVia #-}

_StructuralUnliftingError :: AsBuiltinError err => Prism' err UnliftingError
_StructuralUnliftingError :: forall err. AsBuiltinError err => Prism' err UnliftingError
_StructuralUnliftingError = p UnliftingEvaluationError (f UnliftingEvaluationError)
-> p err (f err)
forall r. AsBuiltinError r => Prism' r UnliftingEvaluationError
Prism' err UnliftingEvaluationError
_BuiltinUnliftingEvaluationError (p UnliftingEvaluationError (f UnliftingEvaluationError)
 -> p err (f err))
-> (p UnliftingError (f UnliftingError)
    -> p UnliftingEvaluationError (f UnliftingEvaluationError))
-> p UnliftingError (f UnliftingError)
-> p err (f err)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p UnliftingError (f UnliftingError)
-> p UnliftingEvaluationError (f UnliftingEvaluationError)
forall r structural operational.
AsEvaluationError r structural operational =>
Prism' r structural
Prism' UnliftingEvaluationError UnliftingError
_StructuralEvaluationError
{-# INLINE _StructuralUnliftingError #-}

_OperationalUnliftingError :: AsBuiltinError err => Prism' err UnliftingError
_OperationalUnliftingError :: forall err. AsBuiltinError err => Prism' err UnliftingError
_OperationalUnliftingError = p UnliftingEvaluationError (f UnliftingEvaluationError)
-> p err (f err)
forall r. AsBuiltinError r => Prism' r UnliftingEvaluationError
Prism' err UnliftingEvaluationError
_BuiltinUnliftingEvaluationError (p UnliftingEvaluationError (f UnliftingEvaluationError)
 -> p err (f err))
-> (p UnliftingError (f UnliftingError)
    -> p UnliftingEvaluationError (f UnliftingEvaluationError))
-> p UnliftingError (f UnliftingError)
-> p err (f err)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p UnliftingError (f UnliftingError)
-> p UnliftingEvaluationError (f UnliftingEvaluationError)
forall r structural operational.
AsEvaluationError r structural operational =>
Prism' r operational
Prism' UnliftingEvaluationError UnliftingError
_OperationalEvaluationError
{-# INLINE _OperationalUnliftingError #-}

throwNotAConstant :: MonadError BuiltinError m => m void
throwNotAConstant :: forall (m :: * -> *) void. MonadError BuiltinError m => m void
throwNotAConstant = AReview BuiltinError UnliftingError -> UnliftingError -> m void
forall e (m :: * -> *) t x.
MonadError e m =>
AReview e t -> t -> m x
throwing AReview BuiltinError UnliftingError
forall err. AsBuiltinError err => Prism' err UnliftingError
Prism' BuiltinError UnliftingError
_StructuralUnliftingError UnliftingError
"Not a constant"
{-# INLINE throwNotAConstant #-}

throwUnderTypeError :: MonadError BuiltinError m => m void
throwUnderTypeError :: forall (m :: * -> *) void. MonadError BuiltinError m => m void
throwUnderTypeError = AReview BuiltinError UnliftingError -> UnliftingError -> m void
forall e (m :: * -> *) t x.
MonadError e m =>
AReview e t -> t -> m x
throwing AReview BuiltinError UnliftingError
forall err. AsBuiltinError err => Prism' err UnliftingError
Prism' BuiltinError UnliftingError
_StructuralUnliftingError UnliftingError
"Panic: 'TypeError' was bypassed"
{-# INLINE throwUnderTypeError #-}

-- | Add a log line to the logs.
emit :: Text -> BuiltinResult ()
emit :: Text -> BuiltinResult ()
emit Text
txt = DList Text -> () -> BuiltinResult ()
forall a. DList Text -> a -> BuiltinResult a
BuiltinSuccessWithLogs (Text -> DList Text
forall a. a -> DList a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
txt) ()
{-# INLINE emit #-}

-- | Prepend logs to a 'BuiltinResult' computation.
withLogs :: DList Text -> BuiltinResult a -> BuiltinResult a
withLogs :: forall a. DList Text -> BuiltinResult a -> BuiltinResult a
withLogs DList Text
logs1 = \case
    BuiltinSuccess a
x               -> DList Text -> a -> BuiltinResult a
forall a. DList Text -> a -> BuiltinResult a
BuiltinSuccessWithLogs DList Text
logs1 a
x
    BuiltinSuccessWithLogs DList Text
logs2 a
x -> DList Text -> a -> BuiltinResult a
forall a. DList Text -> a -> BuiltinResult a
BuiltinSuccessWithLogs (DList Text
logs1 DList Text -> DList Text -> DList Text
forall a. Semigroup a => a -> a -> a
<> DList Text
logs2) a
x
    BuiltinFailure DList Text
logs2 BuiltinError
err       -> DList Text -> BuiltinError -> BuiltinResult a
forall a. DList Text -> BuiltinError -> BuiltinResult a
BuiltinFailure (DList Text
logs1 DList Text -> DList Text -> DList Text
forall a. Semigroup a => a -> a -> a
<> DList Text
logs2) BuiltinError
err
{-# INLINE withLogs #-}

instance Functor BuiltinResult where
    fmap :: forall a b. (a -> b) -> BuiltinResult a -> BuiltinResult b
fmap a -> b
f (BuiltinSuccess a
x)              = b -> BuiltinResult b
forall a. a -> BuiltinResult a
BuiltinSuccess (a -> b
f a
x)
    fmap a -> b
f (BuiltinSuccessWithLogs DList Text
logs a
x) = DList Text -> b -> BuiltinResult b
forall a. DList Text -> a -> BuiltinResult a
BuiltinSuccessWithLogs DList Text
logs (a -> b
f a
x)
    fmap a -> b
_ (BuiltinFailure DList Text
logs BuiltinError
err)       = DList Text -> BuiltinError -> BuiltinResult b
forall a. DList Text -> BuiltinError -> BuiltinResult a
BuiltinFailure DList Text
logs BuiltinError
err
    {-# INLINE fmap #-}

    -- Written out explicitly just in case.
    a
x <$ :: forall a b. a -> BuiltinResult b -> BuiltinResult a
<$ BuiltinSuccess b
_              = a -> BuiltinResult a
forall a. a -> BuiltinResult a
BuiltinSuccess a
x
    a
x <$ BuiltinSuccessWithLogs DList Text
logs b
_ = DList Text -> a -> BuiltinResult a
forall a. DList Text -> a -> BuiltinResult a
BuiltinSuccessWithLogs DList Text
logs a
x
    a
_ <$ BuiltinFailure DList Text
logs BuiltinError
err       = DList Text -> BuiltinError -> BuiltinResult a
forall a. DList Text -> BuiltinError -> BuiltinResult a
BuiltinFailure DList Text
logs BuiltinError
err
    {-# INLINE (<$) #-}

instance Applicative BuiltinResult where
    pure :: forall a. a -> BuiltinResult a
pure = a -> BuiltinResult a
forall a. a -> BuiltinResult a
BuiltinSuccess
    {-# INLINE pure #-}

    BuiltinSuccess a -> b
f              <*> :: forall a b.
BuiltinResult (a -> b) -> BuiltinResult a -> BuiltinResult b
<*> BuiltinResult a
a = (a -> b) -> BuiltinResult a -> BuiltinResult b
forall a b. (a -> b) -> BuiltinResult a -> BuiltinResult b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f BuiltinResult a
a
    BuiltinSuccessWithLogs DList Text
logs a -> b
f <*> BuiltinResult a
a = DList Text -> BuiltinResult b -> BuiltinResult b
forall a. DList Text -> BuiltinResult a -> BuiltinResult a
withLogs DList Text
logs (BuiltinResult b -> BuiltinResult b)
-> BuiltinResult b -> BuiltinResult b
forall a b. (a -> b) -> a -> b
$ (a -> b) -> BuiltinResult a -> BuiltinResult b
forall a b. (a -> b) -> BuiltinResult a -> BuiltinResult b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f BuiltinResult a
a
    BuiltinFailure DList Text
logs BuiltinError
err       <*> BuiltinResult a
_ = DList Text -> BuiltinError -> BuiltinResult b
forall a. DList Text -> BuiltinError -> BuiltinResult a
BuiltinFailure DList Text
logs BuiltinError
err
    {-# INLINE (<*>) #-}

    -- Better than the default implementation, because the value in the 'BuiltinSuccess' case
    -- doesn't need to be retained.
    BuiltinSuccess a
_              *> :: forall a b. BuiltinResult a -> BuiltinResult b -> BuiltinResult b
*> BuiltinResult b
b = BuiltinResult b
b
    BuiltinSuccessWithLogs DList Text
logs a
_ *> BuiltinResult b
b = DList Text -> BuiltinResult b -> BuiltinResult b
forall a. DList Text -> BuiltinResult a -> BuiltinResult a
withLogs DList Text
logs BuiltinResult b
b
    BuiltinFailure DList Text
logs BuiltinError
err       *> BuiltinResult b
_ = DList Text -> BuiltinError -> BuiltinResult b
forall a. DList Text -> BuiltinError -> BuiltinResult a
BuiltinFailure DList Text
logs BuiltinError
err
    {-# INLINE (*>) #-}

instance Monad BuiltinResult where
    BuiltinSuccess a
x              >>= :: forall a b.
BuiltinResult a -> (a -> BuiltinResult b) -> BuiltinResult b
>>= a -> BuiltinResult b
f = a -> BuiltinResult b
f a
x
    BuiltinSuccessWithLogs DList Text
logs a
x >>= a -> BuiltinResult b
f = DList Text -> BuiltinResult b -> BuiltinResult b
forall a. DList Text -> BuiltinResult a -> BuiltinResult a
withLogs DList Text
logs (BuiltinResult b -> BuiltinResult b)
-> BuiltinResult b -> BuiltinResult b
forall a b. (a -> b) -> a -> b
$ a -> BuiltinResult b
f a
x
    BuiltinFailure DList Text
logs BuiltinError
err       >>= a -> BuiltinResult b
_ = DList Text -> BuiltinError -> BuiltinResult b
forall a. DList Text -> BuiltinError -> BuiltinResult a
BuiltinFailure DList Text
logs BuiltinError
err
    {-# INLINE (>>=) #-}

    >> :: forall a b. BuiltinResult a -> BuiltinResult b -> BuiltinResult b
(>>) = BuiltinResult a -> BuiltinResult b -> BuiltinResult b
forall a b. BuiltinResult a -> BuiltinResult b -> BuiltinResult b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)
    {-# INLINE (>>) #-}

-- | 'throwError' puts every operational unlifting error into the 'BuiltinFailure' logs. This is to
-- compensate for the historical lack of error message content in operational errors (structural
-- ones don't have this problem) in our evaluators (the CK and CEK machines). It would be better to
-- fix the underlying issue and allow operational evaluation errors to carry some form of content,
-- but for now we just fix the symptom in order for the end user to see the error message that they
-- are supposed to see. The fix even makes some sense: what we do here is we emulate logging when
-- the thrown unlifting error is an operational one, i.e. this is similar to what some builtins do
-- manually (like when a crypto builtin fails and puts info about the failure into the logs).
instance MonadError BuiltinError BuiltinResult where
    throwError :: forall a. BuiltinError -> BuiltinResult a
throwError BuiltinError
builtinErr = DList Text -> BuiltinError -> BuiltinResult a
forall a. DList Text -> BuiltinError -> BuiltinResult a
BuiltinFailure DList Text
operationalLogs BuiltinError
builtinErr where
        operationalLogs :: DList Text
operationalLogs = case BuiltinError
builtinErr of
            BuiltinUnliftingEvaluationError
                (MkUnliftingEvaluationError
                    (OperationalEvaluationError
                        (MkUnliftingError Text
operationalErr))) -> Text -> DList Text
forall a. a -> DList a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
operationalErr
            BuiltinError
_ -> DList Text
forall a. Monoid a => a
mempty
    {-# INLINE throwError #-}

    -- Throwing logs out is lame, but embedding them into the error would be weird, since that
    -- would change the error. Not that any of that matters, we only implement this because it's a
    -- method of 'MonadError' and we can't not implement it.
    --
    -- We could make it @MonadError (DList Text, BuiltinError)@, but logs are arbitrary and are not
    -- necessarily an inherent part of an error, so preserving them is as questionable as not doing
    -- so.
    BuiltinFailure DList Text
_ BuiltinError
err catchError :: forall a.
BuiltinResult a
-> (BuiltinError -> BuiltinResult a) -> BuiltinResult a
`catchError` BuiltinError -> BuiltinResult a
f = BuiltinError -> BuiltinResult a
f BuiltinError
err
    BuiltinResult a
res                  `catchError` BuiltinError -> BuiltinResult a
_ = BuiltinResult a
res
    {-# INLINE catchError #-}