[Builtins] Expose 'BuiltinResult' (IntersectMBO#5728)

Author: effectfully

plutus-core/changelog.d/20240117_230746_effectfully_expose_BuiltinResult.md

@@ -0,0 +1,3 @@
+### Changed
+
+- #5728 added `BuiltinResult` and leveraged in places where we used to use `Emitter (EvaluationResult Smth)`.

plutus-core/plutus-core.cabal

@@ -113,6 +113,7 @@ library
     PlutusCore.Default
     PlutusCore.Default.Builtins
     PlutusCore.Error
+    PlutusCore.Evaluation.ErrorWithCause
     PlutusCore.Evaluation.Machine.BuiltinCostModel
     PlutusCore.Evaluation.Machine.Ck
     PlutusCore.Evaluation.Machine.CostingFun.Core
@@ -205,6 +206,7 @@ library
     PlutusCore.Builtin.KnownTypeAst
     PlutusCore.Builtin.Meaning
     PlutusCore.Builtin.Polymorphism
+    PlutusCore.Builtin.Result
     PlutusCore.Builtin.Runtime
     PlutusCore.Builtin.TestKnown
     PlutusCore.Builtin.TypeScheme

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.Machine.Exception
 import PlutusCore.Pretty
 
 import PlutusCore.StdLib.Data.ScottList qualified as Plc

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

@@ -11,6 +11,7 @@ import PlutusCore.Builtin.KnownType as Export
 import PlutusCore.Builtin.KnownTypeAst as Export
 import PlutusCore.Builtin.Meaning as Export
 import PlutusCore.Builtin.Polymorphism as Export
+import PlutusCore.Builtin.Result as Export
 import PlutusCore.Builtin.Runtime as Export
 import PlutusCore.Builtin.TestKnown as Export
 import PlutusCore.Builtin.TypeScheme as Export

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

@@ -13,6 +13,9 @@ module PlutusCore.Builtin.Convert (
   byteStringToInteger
   ) where
 
+import PlutusCore.Builtin (BuiltinResult, emit)
+import PlutusCore.Evaluation.Result (evaluationFailure)
+
 import ByteString.StrictBuilder (Builder)
 import ByteString.StrictBuilder qualified as Builder
 import Control.Monad (guard)
@@ -22,18 +25,15 @@ import Data.ByteString qualified as BS
 import Data.Text (pack)
 import Data.Word (Word64, Word8)
 import GHC.ByteOrder (ByteOrder (BigEndian, LittleEndian))
-import PlutusCore.Builtin.Emitter (Emitter, emit)
-import PlutusCore.Evaluation.Result (EvaluationResult (EvaluationFailure))
 
 -- | Wrapper for 'integerToByteString' to make it more convenient to define as a builtin.
-integerToByteStringWrapper ::
-  Bool -> Integer -> Integer -> Emitter (EvaluationResult ByteString)
+integerToByteStringWrapper :: Bool -> Integer -> Integer -> BuiltinResult ByteString
 integerToByteStringWrapper endiannessArg lengthArg input
   -- Check that we are within the Int range on the non-negative side.
   | lengthArg < 0 || lengthArg >= 536870912 = do
       emit "integerToByteString: inappropriate length argument"
       emit $ "Length requested: " <> (pack . show $ input)
-      pure EvaluationFailure
+      evaluationFailure
   -- As this builtin hasn't been costed yet, we have to impose a temporary limit of 10KiB on requested
   -- sizes via the padding argument. This shouldn't be necessary long-term, as once this function is
   -- costed, this won't be a problem.
@@ -42,7 +42,7 @@ integerToByteStringWrapper endiannessArg lengthArg input
   | lengthArg > 10240 = do
       emit "integerToByteString: padding argument too large"
       emit "If you are seeing this, it is a bug: please report this!"
-      pure EvaluationFailure
+      evaluationFailure
   | 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
@@ -54,15 +54,15 @@ integerToByteStringWrapper 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)
-          pure EvaluationFailure
+          evaluationFailure
         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)
-          pure EvaluationFailure
-      Right result -> pure . pure $ result
+          evaluationFailure
+      Right result -> pure result
 
 -- | Wrapper for 'byteStringToInteger' to make it more convenient to define as a builtin.
 byteStringToIntegerWrapper ::
@@ -82,8 +82,7 @@ data IntegerToByteStringError =
 --
 -- For performance and clarity, the endianness argument uses
 -- 'ByteOrder', and the length argument is an 'Int'.
-integerToByteString ::
-  ByteOrder -> Int -> Integer -> Either IntegerToByteStringError ByteString
+integerToByteString :: ByteOrder -> Int -> Integer -> Either IntegerToByteStringError ByteString
 integerToByteString requestedByteOrder requestedLength input
   | input < 0 = Left NegativeInput
   | input == 0 = Right . BS.replicate requestedLength $ 0x00

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

@@ -1,7 +1,7 @@
 module PlutusCore.Builtin.Emitter
     ( Emitter (..)
     , runEmitter
-    , emit
+    , MonadEmitter (..)
     ) where
 
 import Control.Monad.Trans.Writer.Strict (Writer, runWriter, tell)
@@ -17,6 +17,10 @@ runEmitter :: Emitter a -> (a, DList Text)
 runEmitter = runWriter . unEmitter
 {-# INLINE runEmitter #-}
 
-emit :: Text -> Emitter ()
-emit = Emitter . tell . pure
-{-# INLINE emit #-}
+-- | A type class for \"this monad supports logging\".
+class MonadEmitter m where
+    emit :: Text -> m ()
+
+instance MonadEmitter Emitter where
+    emit = Emitter . tell . pure
+    {-# INLINE emit #-}

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

@@ -4,16 +4,16 @@
 {-# LANGUAGE TypeOperators     #-}
 
 module PlutusCore.Builtin.HasConstant
-    ( KnownTypeError (..)
+    ( BuiltinError (..)
     , throwNotAConstant
     , HasConstant (..)
     , HasConstantIn
     , fromValueOf
     , fromValue
     ) where
 
+import PlutusCore.Builtin.Result
 import PlutusCore.Core
-import PlutusCore.Evaluation.Machine.Exception
 import PlutusCore.Name
 
 import Universe
@@ -35,7 +35,7 @@ class HasConstant term where
     -- Switching from 'MonadError' to 'Either' here gave us a speedup of 2-4%.
     -- | Unwrap from a 'Constant'-like constructor throwing an 'UnliftingError' if the provided
     -- @term@ is not a wrapped Haskell value.
-    asConstant :: term -> Either KnownTypeError (Some (ValueOf (UniOf term)))
+    asConstant :: term -> Either BuiltinError (Some (ValueOf (UniOf term)))
 
     -- | Wrap a Haskell value as a @term@.
     fromConstant :: Some (ValueOf (UniOf term)) -> term

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

@@ -16,15 +16,15 @@
 {-# LANGUAGE StrictData             #-}
 
 module PlutusCore.Builtin.KnownType
-    ( KnownTypeError
-    , throwKnownTypeErrorWithCause
+    ( BuiltinError
+    , throwBuiltinErrorWithCause
     , KnownBuiltinTypeIn
     , KnownBuiltinType
-    , MakeKnownM (..)
+    , BuiltinResult (..)
     , ReadKnownM
+    , MakeKnownIn (..)
     , liftReadKnownM
     , readKnownConstant
-    , MakeKnownIn (..)
     , MakeKnown
     , ReadKnownIn (..)
     , ReadKnown
@@ -37,17 +37,15 @@ import PlutusPrelude
 import PlutusCore.Builtin.Emitter
 import PlutusCore.Builtin.HasConstant
 import PlutusCore.Builtin.Polymorphism
+import PlutusCore.Builtin.Result
 import PlutusCore.Core
-import PlutusCore.Evaluation.Machine.Exception
+import PlutusCore.Evaluation.ErrorWithCause
 import PlutusCore.Evaluation.Result
 import PlutusCore.Pretty
 
-import Control.Lens.TH (makeClassyPrisms)
 import Control.Monad.Except
-import Data.DList (DList)
 import Data.Either.Extras
 import Data.String
-import Data.Text (Text)
 import GHC.Exts (inline, oneShot)
 import GHC.TypeLits
 import Universe
@@ -67,7 +65,7 @@ It's critically important that 'readKnown' runs in the concrete 'Either' rather
 https://github.com/IntersectMBO/plutus/pull/4307
 
 Replacing the @AsUnliftingError err, AsEvaluationFailure err@ constraints with the dedicated
-'KnownTypeError' data type gave us a speedup of up to 4%.
+'BuiltinError' data type gave us a speedup of up to 4%.
 
 All the same considerations apply to 'makeKnown':
 https://github.com/IntersectMBO/plutus/pull/4421
@@ -241,16 +239,16 @@ Lifting is allowed to the following classes of types:
    one, and for another example define an instance for 'Void' in tests
 -}
 
--- | Attach a @cause@ to a 'KnownTypeError' and throw that.
+-- | Attach a @cause@ to a 'BuiltinError' and throw that.
 -- Note that an evaluator might require the cause to be computed lazily for best performance on the
 -- happy path, hence this function must not force its first argument.
 -- TODO: wrap @cause@ in 'Lazy' once we have it.
-throwKnownTypeErrorWithCause
+throwBuiltinErrorWithCause
     :: (MonadError (ErrorWithCause err cause) m, AsUnliftingError err, AsEvaluationFailure err)
-    => cause -> KnownTypeError -> m void
-throwKnownTypeErrorWithCause cause = \case
-    KnownTypeUnliftingError unlErr -> throwingWithCause _UnliftingError unlErr $ Just cause
-    KnownTypeEvaluationFailure     -> throwingWithCause _EvaluationFailure () $ Just cause
+    => cause -> BuiltinError -> m void
+throwBuiltinErrorWithCause cause = \case
+    BuiltinUnliftingError unlErr -> throwingWithCause _UnliftingError unlErr $ Just cause
+    BuiltinEvaluationFailure     -> throwingWithCause _EvaluationFailure () $ Just cause
 
 typeMismatchError
     :: PrettyParens (SomeTypeIn uni)
@@ -266,89 +264,19 @@ typeMismatchError uniExp uniAct = fromString $ concat
 -- failure message and evaluation is about to be shut anyway.
 {-# NOINLINE typeMismatchError #-}
 
--- | The monad that 'makeKnown' runs in.
--- Equivalent to @ExceptT KnownTypeError Emitter@, except optimized in two ways:
---
--- 1. everything is strict
--- 2. has the 'MakeKnownSuccess' constructor that is used for returning a value with no logs
---    attached, which is the most common case for us, so it helps a lot not to construct and
---    deconstruct a redundant tuple
---
--- Moving from @ExceptT KnownTypeError Emitter@ to this data type gave us a speedup of 8% of total
--- evaluation time.
---
--- Logs are represented as a 'DList', because we don't particularly care about the efficiency of
--- logging, since there's no logging on the chain and builtins don't emit much anyway. Otherwise
--- we'd have to use @text-builder@ or @text-builder-linear@ or something of this sort.
-data MakeKnownM a
-    = MakeKnownFailure (DList Text) KnownTypeError
-    | MakeKnownSuccess a
-    | MakeKnownSuccessWithLogs (DList Text) a
-
-makeClassyPrisms ''MakeKnownM
-
-instance AsEvaluationFailure (MakeKnownM a) where
-    _EvaluationFailure = _MakeKnownFailure . _EvaluationFailureVia (pure KnownTypeEvaluationFailure)
-    {-# INLINE _EvaluationFailure #-}
-
--- | Prepend logs to a 'MakeKnownM' computation.
-withLogs :: DList Text -> MakeKnownM a -> MakeKnownM a
-withLogs logs1 = \case
-    MakeKnownFailure logs2 err       -> MakeKnownFailure (logs1 <> logs2) err
-    MakeKnownSuccess x               -> MakeKnownSuccessWithLogs logs1 x
-    MakeKnownSuccessWithLogs logs2 x -> MakeKnownSuccessWithLogs (logs1 <> logs2) x
-{-# INLINE withLogs #-}
-
-instance Functor MakeKnownM where
-    fmap _ (MakeKnownFailure logs err)       = MakeKnownFailure logs err
-    fmap f (MakeKnownSuccess x)              = MakeKnownSuccess (f x)
-    fmap f (MakeKnownSuccessWithLogs logs x) = MakeKnownSuccessWithLogs logs (f x)
-    {-# INLINE fmap #-}
-
-    -- Written out explicitly just in case (see @fmap@ above for what the case might be).
-    _ <$ MakeKnownFailure logs err       = MakeKnownFailure logs err
-    x <$ MakeKnownSuccess _              = MakeKnownSuccess x
-    x <$ MakeKnownSuccessWithLogs logs _ = MakeKnownSuccessWithLogs logs x
-    {-# INLINE (<$) #-}
-
-instance Applicative MakeKnownM where
-    pure = MakeKnownSuccess
-    {-# INLINE pure #-}
-
-    MakeKnownFailure logs err       <*> _ = MakeKnownFailure logs err
-    MakeKnownSuccess f              <*> a = fmap f a
-    MakeKnownSuccessWithLogs logs f <*> a = withLogs logs $ fmap f a
-    {-# INLINE (<*>) #-}
-
-    -- Better than the default implementation, because the value in the 'MakeKnownSuccess' case
-    -- doesn't need to be retained.
-    MakeKnownFailure logs err       *> _ = MakeKnownFailure logs err
-    MakeKnownSuccess _              *> a = a
-    MakeKnownSuccessWithLogs logs _ *> a = withLogs logs a
-    {-# INLINE (*>) #-}
-
-instance Monad MakeKnownM where
-    MakeKnownFailure logs err       >>= _ = MakeKnownFailure logs err
-    MakeKnownSuccess x              >>= f = f x
-    MakeKnownSuccessWithLogs logs x >>= f = withLogs logs $ f x
-    {-# INLINE (>>=) #-}
-
-    (>>) = (*>)
-    {-# INLINE (>>) #-}
-
 -- Normally it's a good idea for an exported abstraction not to be a type synonym, since a @newtype@
 -- is cheap, looks good in error messages and clearly emphasize an abstraction barrier. However we
 -- make 'ReadKnownM' a type synonym for convenience: that way we don't need to derive all the
 -- instances (and add new ones whenever we need them), wrap and unwrap all the time (including in
 -- user code), which can be non-trivial for such performance-sensitive code (see e.g. 'coerceVia'
 -- and 'coerceArg') and there is no abstraction barrier anyway.
 -- | The monad that 'readKnown' runs in.
-type ReadKnownM = Either KnownTypeError
+type ReadKnownM = Either BuiltinError
 
--- | Lift a 'ReadKnownM' computation into 'MakeKnownM'.
-liftReadKnownM :: ReadKnownM a -> MakeKnownM a
-liftReadKnownM (Left err) = MakeKnownFailure mempty err
-liftReadKnownM (Right x)  = MakeKnownSuccess x
+-- | 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 values of built-in types].
@@ -363,15 +291,15 @@ readKnownConstant val = asConstant val >>= oneShot \case
         -- optimize some of the matching away.
         case uniExp `geq` uniAct of
             Just Refl -> pure x
-            Nothing   -> Left . KnownTypeUnliftingError $ typeMismatchError uniExp uniAct
+            Nothing   -> throwing _UnliftingError $ typeMismatchError uniExp uniAct
 {-# INLINE readKnownConstant #-}
 
 -- See Note [Performance of ReadKnownIn and MakeKnownIn instances].
 class uni ~ UniOf val => MakeKnownIn uni val a where
     -- | Convert a Haskell value to the corresponding PLC value.
     -- The inverse of 'readKnown'.
-    makeKnown :: a -> MakeKnownM val
-    default makeKnown :: KnownBuiltinType val a => a -> MakeKnownM val
+    makeKnown :: a -> BuiltinResult val
+    default makeKnown :: KnownBuiltinType val a => a -> BuiltinResult val
     -- Everything on evaluation path has to be strict in production, so in theory we don't need to
     -- force anything here. In practice however all kinds of weird things happen in tests and @val@
     -- can be non-strict enough to cause trouble here, so we're forcing the argument. Looking at the
@@ -400,9 +328,9 @@ type ReadKnown val = ReadKnownIn (UniOf val) val
 -- | Same as 'makeKnown', but allows for neither emitting nor storing the cause of a failure.
 makeKnownOrFail :: MakeKnownIn uni val a => a -> EvaluationResult val
 makeKnownOrFail x = case makeKnown x of
-    MakeKnownFailure _ _           -> EvaluationFailure
-    MakeKnownSuccess val           -> EvaluationSuccess val
-    MakeKnownSuccessWithLogs _ val -> EvaluationSuccess val
+    BuiltinFailure _ _           -> EvaluationFailure
+    BuiltinSuccess val           -> EvaluationSuccess val
+    BuiltinSuccessWithLogs _ val -> EvaluationSuccess val
 {-# INLINE makeKnownOrFail #-}
 
 -- | Same as 'readKnown', but the cause of a potential failure is the provided term itself.
@@ -411,14 +339,18 @@ readKnownSelf
        , AsUnliftingError err, AsEvaluationFailure err
        )
     => val -> Either (ErrorWithCause err val) a
-readKnownSelf val = fromRightM (throwKnownTypeErrorWithCause val) $ readKnown val
+readKnownSelf val = fromRightM (throwBuiltinErrorWithCause val) $ readKnown val
 {-# INLINE readKnownSelf #-}
 
 instance MakeKnownIn uni val a => MakeKnownIn uni val (EvaluationResult a) where
     makeKnown EvaluationFailure     = evaluationFailure
     makeKnown (EvaluationSuccess x) = makeKnown x
     {-# INLINE makeKnown #-}
 
+instance MakeKnownIn uni val a => MakeKnownIn uni val (BuiltinResult a) where
+    makeKnown res = res >>= makeKnown
+    {-# INLINE makeKnown #-}
+
 -- Catching 'EvaluationFailure' here would allow *not* to short-circuit when 'readKnown' fails
 -- to read a Haskell value of type @a@. Instead, in the denotation of the builtin function
 -- the programmer would be given an explicit 'EvaluationResult' value to handle, which means

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

@@ -33,6 +33,7 @@ module PlutusCore.Builtin.KnownTypeAst
 import PlutusCore.Builtin.Emitter
 import PlutusCore.Builtin.KnownKind
 import PlutusCore.Builtin.Polymorphism
+import PlutusCore.Builtin.Result
 import PlutusCore.Core
 import PlutusCore.Evaluation.Result
 import PlutusCore.Name
@@ -223,6 +224,13 @@ instance KnownTypeAst tyname uni a => KnownTypeAst tyname uni (EvaluationResult
     toTypeAst _ = toTypeAst $ Proxy @a
     {-# INLINE toTypeAst #-}
 
+instance KnownTypeAst tyname uni a => KnownTypeAst tyname uni (BuiltinResult a) where
+    type IsBuiltin _ (BuiltinResult a) = 'False
+    type ToHoles _ (BuiltinResult a) = '[TypeHole a]
+    type ToBinds uni acc (BuiltinResult a) = ToBinds uni acc a
+    toTypeAst _ = toTypeAst $ Proxy @a
+    {-# INLINE toTypeAst #-}
+
 instance KnownTypeAst tyname uni a => KnownTypeAst tyname uni (Emitter a) where
     type IsBuiltin _ (Emitter a) = 'False
     type ToHoles _ (Emitter a) = '[TypeHole a]