-- 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 (..)
    , UnliftingError (..)
    , UnliftingEvaluationError (..)
    , BuiltinError (..)
    , BuiltinResult (..)
    , notAConstant
    , underTypeError
    , operationalUnliftingError
    , structuralUnliftingError
    , emit
    , withLogs
    , throwing
    , throwing_
    , builtinResultFailure
    ) where

import PlutusPrelude

import PlutusCore.Evaluation.Error

import Control.Monad.Error.Lens (throwing, throwing_)
import Control.Monad.Except
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)

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 'notAConstant' 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
former. 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 OperationalError].
-- | 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'.

operationalUnliftingError :: Text -> BuiltinError
operationalUnliftingError :: Text -> BuiltinError
operationalUnliftingError =
  UnliftingEvaluationError -> BuiltinError
BuiltinUnliftingEvaluationError (UnliftingEvaluationError -> BuiltinError)
-> (Text -> UnliftingEvaluationError) -> Text -> BuiltinError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvaluationError UnliftingError UnliftingError
-> UnliftingEvaluationError
MkUnliftingEvaluationError (EvaluationError UnliftingError UnliftingError
 -> UnliftingEvaluationError)
-> (Text -> EvaluationError UnliftingError UnliftingError)
-> Text
-> UnliftingEvaluationError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnliftingError -> EvaluationError UnliftingError UnliftingError
forall structural operational.
operational -> EvaluationError structural operational
OperationalError (UnliftingError -> EvaluationError UnliftingError UnliftingError)
-> (Text -> UnliftingError)
-> Text
-> EvaluationError UnliftingError UnliftingError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> UnliftingError
MkUnliftingError
{-# INLINE operationalUnliftingError #-}

structuralUnliftingError :: Text -> BuiltinError
structuralUnliftingError :: Text -> BuiltinError
structuralUnliftingError =
  UnliftingEvaluationError -> BuiltinError
BuiltinUnliftingEvaluationError (UnliftingEvaluationError -> BuiltinError)
-> (Text -> UnliftingEvaluationError) -> Text -> BuiltinError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvaluationError UnliftingError UnliftingError
-> UnliftingEvaluationError
MkUnliftingEvaluationError (EvaluationError UnliftingError UnliftingError
 -> UnliftingEvaluationError)
-> (Text -> EvaluationError UnliftingError UnliftingError)
-> Text
-> UnliftingEvaluationError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnliftingError -> EvaluationError UnliftingError UnliftingError
forall structural operational.
structural -> EvaluationError structural operational
StructuralError (UnliftingError -> EvaluationError UnliftingError UnliftingError)
-> (Text -> UnliftingError)
-> Text
-> EvaluationError UnliftingError UnliftingError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> UnliftingError
MkUnliftingError
{-# INLINE structuralUnliftingError #-}

notAConstant :: BuiltinError
notAConstant :: BuiltinError
notAConstant = Text -> BuiltinError
structuralUnliftingError Text
"Not a constant"
{-# INLINE notAConstant #-}

underTypeError :: BuiltinError
underTypeError :: BuiltinError
underTypeError = Text -> BuiltinError
structuralUnliftingError Text
"Panic: 'TypeError' was bypassed"
{-# INLINE underTypeError #-}

-- | 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
                    (OperationalError
                        (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 #-}

builtinResultFailure :: BuiltinResult a
builtinResultFailure :: forall a. BuiltinResult a
builtinResultFailure = DList Text -> BuiltinError -> BuiltinResult a
forall a. DList Text -> BuiltinError -> BuiltinResult a
BuiltinFailure DList Text
forall a. Monoid a => a
mempty BuiltinError
BuiltinEvaluationFailure
{-# INLINE builtinResultFailure #-}