diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs index c6770fe96c1..a87eefe58d7 100644 --- 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 index 3ecd33a823d..2c04f75ee56 100644 --- 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 index d559df8f123..b3406624db1 100644 --- 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 #-}