[Errors] Preserve operational unlifting errors

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