[Errors] Preserve operational unlifting errors

IntersectMBO · Jun 6, 2024 · d85e2ae · d85e2ae
1 parent f1f2e9f
commit d85e2ae
Show file tree

Hide file tree

Showing 3 changed files with 22 additions and 10 deletions.
diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs b/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

diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs b/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 #-}
 

diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/Result.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/Result.hs
@@ -215,3 +215,23 @@ instance Monad BuiltinResult where
 
     (>>) = (*>)
     {-# INLINE (>>) #-}
+
+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 #-}