Remove prismatic error handling from Ck/Cek machines

Author: SeungheonOh

plutus-core/cost-model/budgeting-bench/Benchmarks/Nops.hs

@@ -22,7 +22,6 @@ import PlutusCore.Evaluation.Machine.BuiltinCostModel hiding (BuiltinCostModel)
 import PlutusCore.Evaluation.Machine.ExBudgetingDefaults
 import PlutusCore.Evaluation.Machine.ExMemoryUsage (ExMemoryUsage)
 import PlutusCore.Evaluation.Machine.MachineParameters
-import PlutusCore.Evaluation.Result (evaluationFailure)
 import PlutusCore.Pretty
 import PlutusPrelude
 import UntypedPlutusCore.Evaluation.Machine.Cek
@@ -137,7 +136,7 @@ infixr >:
 n >: k =
     case n of
       SomeConstant (Some (ValueOf DefaultUniInteger _)) -> k
-      _                                                 -> evaluationFailure
+      _                                                 -> builtinResultFailure
 {-# INLINE (>:) #-}
 
 {- | The meanings of the builtins.  Each one takes a number of arguments and

plutus-core/plutus-core/examples/PlutusCore/Examples/Builtins.hs

@@ -24,7 +24,6 @@ import PlutusCore.Data
 import PlutusCore.Evaluation.Machine.BuiltinCostModel
 import PlutusCore.Evaluation.Machine.ExBudget
 import PlutusCore.Evaluation.Machine.ExBudgetStream
-import PlutusCore.Evaluation.Result (evaluationFailure)
 import PlutusCore.Pretty
 
 import PlutusCore.StdLib.Data.ScottList qualified as Plc
@@ -199,7 +198,7 @@ instance tyname ~ TyName => KnownTypeAst tyname DefaultUni Void where
 instance UniOf term ~ DefaultUni => MakeKnownIn DefaultUni term Void where
     makeKnown = absurd
 instance UniOf term ~ DefaultUni => ReadKnownIn DefaultUni term Void where
-    readKnown _ = throwing _StructuralUnliftingError "Can't unlift to 'Void'"
+    readKnown _ = throwStructuralUnliftingError "Can't unlift to 'Void'"
 
 data BuiltinErrorCall = BuiltinErrorCall
     deriving stock (Show, Eq)
@@ -286,7 +285,7 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni ExtensionFun where
         idAssumeCheckBoolPlc val =
             case asConstant val of
                 Right (Some (ValueOf DefaultUniBool b)) -> pure b
-                _                                       -> evaluationFailure
+                _                                       -> builtinResultFailure
 
     toBuiltinMeaning _semvar IdSomeConstantBool =
         makeBuiltinMeaning
@@ -296,7 +295,7 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni ExtensionFun where
         idSomeConstantBoolPlc :: SomeConstant uni Bool -> BuiltinResult Bool
         idSomeConstantBoolPlc = \case
             SomeConstant (Some (ValueOf DefaultUniBool b)) -> pure b
-            _                                              -> evaluationFailure
+            _                                              -> builtinResultFailure
 
     toBuiltinMeaning _semvar IdIntegerAsBool =
         makeBuiltinMeaning
@@ -306,7 +305,7 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni ExtensionFun where
         idIntegerAsBool :: SomeConstant uni Integer -> BuiltinResult (SomeConstant uni Integer)
         idIntegerAsBool = \case
             con@(SomeConstant (Some (ValueOf DefaultUniBool _))) -> pure con
-            _                                                    -> evaluationFailure
+            _                                                    -> builtinResultFailure
 
     toBuiltinMeaning _semvar IdFInteger =
         makeBuiltinMeaning
@@ -397,7 +396,7 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni ExtensionFun where
 
     toBuiltinMeaning _semvar ErrorPrime =
         makeBuiltinMeaning
-            (evaluationFailure :: forall a. BuiltinResult a)
+            (builtinResultFailure :: forall a. BuiltinResult a)
             whatever
 
     toBuiltinMeaning _semvar Comma =

plutus-core/plutus-core/src/PlutusCore/Bitwise.hs

@@ -24,8 +24,7 @@ module PlutusCore.Bitwise (
   maximumOutputLength
   ) where
 
-import PlutusCore.Builtin (BuiltinResult, emit)
-import PlutusCore.Evaluation.Result (evaluationFailure)
+import PlutusCore.Builtin (BuiltinResult, builtinResultFailure, emit)
 
 import ByteString.StrictBuilder (Builder)
 import ByteString.StrictBuilder qualified as Builder
@@ -64,15 +63,15 @@ integerToByteString endiannessArg lengthArg input
   | lengthArg < 0 = do
       emit "integerToByteString: negative length argument"
       emit $ "Length requested: " <> (pack . show $ input)
-      evaluationFailure
+      builtinResultFailure
   -- Check that the requested length does not exceed the limit.  *NB*: if we remove the limit we'll
   -- still have to make sure that the length fits into an Int.
   | lengthArg > maximumOutputLength = do
       emit . pack $ "integerToByteString: requested length is too long (maximum is "
                ++ show maximumOutputLength
                ++ " bytes)"
       emit $ "Length requested: " <> (pack . show $ lengthArg)
-      evaluationFailure
+      builtinResultFailure
   -- If the requested length is zero (ie, an explicit output size is not
   -- specified) we still have to make sure that the output won't exceed the size
   -- limit.  If the requested length is nonzero and less than the limit,
@@ -86,7 +85,7 @@ integerToByteString endiannessArg lengthArg input
                ++ show (8 * maximumOutputLength)
                ++ "-1)"
       emit $ "Length required: " <> (pack . show $ bytesRequiredFor input)
-      evaluationFailure
+      builtinResultFailure
   | otherwise = let endianness = endiannessArgToByteOrder endiannessArg in
     -- We use fromIntegral here, despite advice to the contrary in general when defining builtin
     -- denotations. This is because, if we've made it this far, we know that overflow or truncation
@@ -98,14 +97,14 @@ integerToByteString endiannessArg lengthArg input
           -- This does work proportional to the size of input. However, we're in a failing case
           -- anyway, and the user's paid for work proportional to this size in any case.
           emit $ "Input: " <> (pack . show $ input)
-          evaluationFailure
+          builtinResultFailure
         NotEnoughDigits -> do
           emit "integerToByteString: cannot represent Integer in given number of bytes"
           -- This does work proportional to the size of input. However, we're in a failing case
           -- anyway, and the user's paid for work proportional to this size in any case.
           emit $ "Input: " <> (pack . show $ input)
           emit $ "Bytes requested: " <> (pack . show $ lengthArg)
-          evaluationFailure
+          builtinResultFailure
       Right result -> pure result
 
 -- | Conversion from 'Integer' to 'ByteString', as per
@@ -528,11 +527,11 @@ readBit bs ix
   | ix < 0 = do
       emit "readBit: index out of bounds"
       emit $ "Index: " <> (pack . show $ ix)
-      evaluationFailure
+      builtinResultFailure
   | ix >= len * 8 = do
       emit "readBit: index out of bounds"
       emit $ "Index: " <> (pack . show $ ix)
-      evaluationFailure
+      builtinResultFailure
   | otherwise = do
       let (bigIx, littleIx) = ix `quotRem` 8
       let flipIx = len - bigIx - 1
@@ -548,7 +547,7 @@ writeBits bs ixs bit = case unsafeDupablePerformIO . try $ go of
   Left (WriteBitsException i) -> do
     emit "writeBits: index out of bounds"
     emit $ "Index: " <> (pack . show $ i)
-    evaluationFailure
+    builtinResultFailure
   Right result -> pure result
   where
     -- This is written in a somewhat strange way. See Note [writeBits and
@@ -588,13 +587,13 @@ replicateByte :: Integer -> Word8 -> BuiltinResult ByteString
 replicateByte len w8
   | len < 0 = do
       emit "replicateByte: negative length requested"
-      evaluationFailure
+      builtinResultFailure
   | len > maximumOutputLength = do
       emit . pack $ "replicateByte: requested length is too long (maximum is "
                ++ show maximumOutputLength
                ++ " bytes)"
       emit $ "Length requested: " <> (pack . show $ len)
-      evaluationFailure
+      builtinResultFailure
   | otherwise = pure . BS.replicate (fromIntegral len) $ w8
 
 -- | Wrapper for calling 'unsafesShiftByteString' safely. Specifically, we avoid various edge cases:

plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs

@@ -17,7 +17,6 @@
 
 module PlutusCore.Builtin.KnownType
     ( BuiltinError
-    , throwBuiltinErrorWithCause
     , KnownBuiltinTypeIn
     , KnownBuiltinType
     , BuiltinResult (..)
@@ -30,7 +29,6 @@ module PlutusCore.Builtin.KnownType
     , ReadKnownIn (..)
     , ReadKnown
     , makeKnownOrFail
-    , readKnownSelf
     ) where
 
 import PlutusPrelude
@@ -39,11 +37,10 @@ import PlutusCore.Builtin.HasConstant
 import PlutusCore.Builtin.Polymorphism
 import PlutusCore.Builtin.Result
 import PlutusCore.Core
-import PlutusCore.Evaluation.ErrorWithCause
 import PlutusCore.Evaluation.Result
 import PlutusCore.Pretty
 
-import Data.Either.Extras
+import Control.Monad.Except
 import Data.Functor.Identity
 import Data.String
 import GHC.Exts (inline, oneShot)
@@ -276,7 +273,7 @@ readKnownConstant val = asConstant val >>= oneShot \case
         -- optimize some of the matching away.
         case uniExp `geq` uniAct of
             Just Refl -> pure x
-            Nothing   -> throwing _UnliftingEvaluationError $ typeMismatchError uniExp uniAct
+            Nothing   -> throwError $ BuiltinUnliftingEvaluationError $ typeMismatchError uniExp uniAct
 {-# INLINE readKnownConstant #-}
 
 -- | A non-empty spine. Isomorphic to 'NonEmpty', except is strict and is defined as a single
@@ -361,13 +358,6 @@ makeKnownOrFail x = case makeKnown x of
     BuiltinFailure _ _           -> EvaluationFailure
 {-# INLINE makeKnownOrFail #-}
 
--- | Same as 'readKnown', but the cause of a potential failure is the provided term itself.
-readKnownSelf
-    :: (ReadKnown val a, AsUnliftingEvaluationError err, AsEvaluationFailure err)
-    => val -> Either (ErrorWithCause err val) a
-readKnownSelf val = fromRightM (throwBuiltinErrorWithCause val) $ readKnown val
-{-# INLINE readKnownSelf #-}
-
 instance MakeKnownIn uni val a => MakeKnownIn uni val (BuiltinResult a) where
     makeKnown res = res >>= makeKnown
     {-# INLINE makeKnown #-}

plutus-core/plutus-core/src/PlutusCore/Builtin/Result.hs

@@ -10,35 +10,27 @@
 
 module PlutusCore.Builtin.Result
     ( EvaluationError (..)
-    , AsEvaluationError (..)
     , UnliftingError (..)
     , UnliftingEvaluationError (..)
     , BuiltinError (..)
     , BuiltinResult (..)
-    , AsUnliftingEvaluationError (..)
-    , AsUnliftingError (..)
-    , AsBuiltinError (..)
-    , AsBuiltinResult (..)
-    , _UnliftingErrorVia
-    , _StructuralUnliftingError
-    , _OperationalUnliftingError
     , throwNotAConstant
     , throwUnderTypeError
+    , throwOperationalUnliftingError
+    , throwStructuralUnliftingError
     , emit
     , withLogs
     , throwing
     , throwing_
+    , builtinResultFailure
     ) 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)
@@ -93,56 +85,6 @@ data BuiltinResult a
     | BuiltinFailure (DList Text) BuiltinError
     deriving stock (Show, Foldable)
 
-mtraverse makeClassyPrisms
-    [ ''UnliftingError
-    , ''UnliftingEvaluationError
-    , ''BuiltinError
-    , ''BuiltinResult
-    ]
-
-instance AsEvaluationError UnliftingEvaluationError UnliftingError UnliftingError where
-    _EvaluationError = 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 = go . coerced where
-        go =
-            prism'
-                (bimap
-                    (review _UnliftingError)
-                    (review _UnliftingError))
-                (bitraverse
-                    (reoption . matching _UnliftingError)
-                    (reoption . matching _UnliftingError))
-    {-# INLINE _UnliftingEvaluationError #-}
-
-instance AsUnliftingEvaluationError BuiltinError where
-    _UnliftingEvaluationError = _BuiltinUnliftingEvaluationError . _UnliftingEvaluationError
-    {-# INLINE _UnliftingEvaluationError #-}
-
-instance AsEvaluationFailure BuiltinError where
-    _EvaluationFailure = _EvaluationFailureVia 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 = _BuiltinFailure . iso (\_ -> ()) (\_ -> pure evaluationFailure)
-    {-# INLINE _EvaluationFailure #-}
-
 instance MonadFail BuiltinResult where
     fail err = BuiltinFailure (pure $ Text.pack err) BuiltinEvaluationFailure
     {-# INLINE fail #-}
@@ -184,28 +126,23 @@ variable).
 --
 -- This is useful for providing 'AsUnliftingError' instances for types such as 'CkUserError' and
 -- 'CekUserError'.
-_UnliftingErrorVia :: Pretty err => err -> Prism' err UnliftingError
-_UnliftingErrorVia err = iso (MkUnliftingError . display) (const err)
-{-# INLINE _UnliftingErrorVia #-}
-
--- | See Note [Structural vs operational errors within builtins]
-_StructuralUnliftingError :: AsBuiltinError err => Prism' err UnliftingError
-_StructuralUnliftingError = _BuiltinUnliftingEvaluationError . _StructuralError
-{-# INLINE _StructuralUnliftingError #-}
-
--- | See Note [Structural vs operational errors within builtins]
-_OperationalUnliftingError :: AsBuiltinError err => Prism' err UnliftingError
-_OperationalUnliftingError = _BuiltinUnliftingEvaluationError . _OperationalError
-{-# INLINE _OperationalUnliftingError #-}
 
 throwNotAConstant :: MonadError BuiltinError m => m void
-throwNotAConstant = throwing _StructuralUnliftingError "Not a constant"
+throwNotAConstant = throwError (BuiltinUnliftingEvaluationError $ MkUnliftingEvaluationError $ StructuralError $ MkUnliftingError "Not a constant")
 {-# INLINE throwNotAConstant #-}
 
 throwUnderTypeError :: MonadError BuiltinError m => m void
-throwUnderTypeError = throwing _StructuralUnliftingError "Panic: 'TypeError' was bypassed"
+throwUnderTypeError = throwError (BuiltinUnliftingEvaluationError $ MkUnliftingEvaluationError $ StructuralError $ MkUnliftingError "Panic: 'TypeError' was bypassed")
 {-# INLINE throwUnderTypeError #-}
 
+throwOperationalUnliftingError :: MonadError BuiltinError m => UnliftingError -> m void
+throwOperationalUnliftingError =
+  throwError . BuiltinUnliftingEvaluationError . MkUnliftingEvaluationError . OperationalError
+
+throwStructuralUnliftingError :: MonadError BuiltinError m => UnliftingError -> m void
+throwStructuralUnliftingError =
+  throwError . BuiltinUnliftingEvaluationError . MkUnliftingEvaluationError . StructuralError
+
 -- | Add a log line to the logs.
 emit :: Text -> BuiltinResult ()
 emit txt = BuiltinSuccessWithLogs (pure txt) ()
@@ -284,3 +221,6 @@ instance MonadError BuiltinError BuiltinResult where
     BuiltinFailure _ err `catchError` f = f err
     res                  `catchError` _ = res
     {-# INLINE catchError #-}
+
+builtinResultFailure :: BuiltinResult a
+builtinResultFailure = BuiltinFailure mempty BuiltinEvaluationFailure

plutus-core/plutus-core/src/PlutusCore/Crypto/Utils.hs

@@ -3,8 +3,7 @@
 
 module PlutusCore.Crypto.Utils (failWithMessage, byteStringAsHex) where
 
-import PlutusCore.Builtin.Result (BuiltinResult, emit)
-import PlutusCore.Evaluation.Result (evaluationFailure)
+import PlutusCore.Builtin.Result (BuiltinResult, builtinResultFailure, emit)
 
 import Data.ByteString (ByteString, foldr')
 import Data.Kind (Type)
@@ -14,7 +13,7 @@ import Text.Printf (printf)
 failWithMessage :: forall (a :: Type). Text -> Text -> BuiltinResult a
 failWithMessage location reason = do
   emit $ location <> ": " <> reason
-  evaluationFailure
+  builtinResultFailure
 
 byteStringAsHex :: ByteString -> String
 byteStringAsHex bs = "0x" ++ (Prelude.concat $ foldr' (\w s -> (printf "%02x" w):s) [] bs)