[Errors] Preserve operational unlifting errors (#6181)

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

@@ -23,7 +23,6 @@ module PlutusCore.Builtin.KnownType
  , BuiltinResult (..)
  , ReadKnownM
  , MakeKnownIn (..)
- , liftReadKnownM
  , readKnownConstant
  , MakeKnown
  , ReadKnownIn (..)
@@ -262,12 +261,6 @@ typeMismatchError uniExp uniAct =
 -- | The monad that 'readKnown' runs in.
 type ReadKnownM = Either BuiltinError
 
--- | Lift a 'ReadKnownM' computation into 'BuiltinResult'.
-liftReadKnownM :: ReadKnownM a -> BuiltinResult a
-liftReadKnownM (Left err) = BuiltinFailure mempty err
-liftReadKnownM (Right x) = BuiltinSuccess x
-{-# INLINE liftReadKnownM #-}
-
 -- See Note [Unlifting a term as a value of a built-in type].
 -- | Convert a constant embedded into a PLC term to the corresponding Haskell value.
 readKnownConstant :: forall val a. KnownBuiltinType val a => val -> ReadKnownM a

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

@@ -30,6 +30,7 @@ import PlutusCore.Evaluation.Machine.ExBudgetStream
 import PlutusCore.Evaluation.Machine.ExMemoryUsage
 import PlutusCore.Name.Unique
 
+import Control.Monad.Except (throwError)
 import Data.Array
 import Data.Kind qualified as GHC
 import Data.Proxy
@@ -229,8 +230,6 @@ instance (Typeable res, KnownTypeAst TyName (UniOf val) res, MakeKnown val res)
  KnownMonotype val '[] res where
  knownMonotype = TypeSchemeResult
 
- -- We need to lift the 'ReadKnownM' action into 'BuiltinResult',
- -- hence 'liftReadKnownM'.
  toMonoF =
  either
  -- Unlifting has failed and we don't care about costing at this point, since we're about
@@ -245,7 +244,7 @@ instance (Typeable res, KnownTypeAst TyName (UniOf val) res, MakeKnown val res)
  -- either a budgeting failure or a budgeting success with a cost and a 'BuiltinResult'
  -- computation inside, but that would slow things down a bit and the current strategy is
  -- reasonable enough.
- (BuiltinCostedResult (ExBudgetLast mempty) . BuiltinFailure mempty)
+ (BuiltinCostedResult (ExBudgetLast mempty) . throwError)
  (\(x, cost) -> BuiltinCostedResult cost $ makeKnown x)
  {-# INLINE toMonoF #-}
 

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

@@ -225,3 +225,31 @@ instance Monad BuiltinResult where
 
  (>>) = (*>)
  {-# 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 builtinErr = BuiltinFailure operationalLogs builtinErr where
+ operationalLogs = case builtinErr of
+ BuiltinUnliftingEvaluationError
+ (MkUnliftingEvaluationError
+ (OperationalEvaluationError
+ (MkUnliftingError operationalErr))) -> pure operationalErr
+ _ -> mempty
+
+ -- 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 _ err `catchError` f = f err
+ res `catchError` _ = res
+ {-# INLINE catchError #-}

plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs

@@ -522,8 +522,11 @@ fails fileName fun typeArgs termArgs = do
  concatMap (\_ -> " <...>") termArgs
  in testNestedNamedM mempty name $
  testNestedNamedM mempty expectedToDisplay $
- nestedGoldenVsDoc fileName ".err" . vsep $
- map pretty logs ++ [prettyPlcReadableDef err]
+ nestedGoldenVsDoc fileName ".err" . vsep $ concat
+ [ [prettyPlcReadableDef err]
+ , ["Logs were:" | not $ null logs]
+ , map pretty logs
+ ]
 
 -- | Test all integer related builtins
 test_Integer :: TestNested

plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Golden/String/consByteString-out-of-range.err.golden

@@ -1,3 +1,5 @@
 An error has occurred:
 The machine terminated because of an error, either from a built-in function or from an explicit use of 'error'.
-Caused by: (consByteString 256 #68656c6c6f20776f726c64)
+Caused by: (consByteString 256 #68656c6c6f20776f726c64)
+Logs were:
+256 is not within the bounds of Word8