Alternative approach to Annotator (#4733)

* Add `Maybe ByteString` to `Decoder` thus providing an alternative to `Annotator`

eras/byron/ledger/impl/src/Cardano/Chain/Byron/API/Common.hs

@@ -106,7 +106,7 @@ reAnnotateUsing ::
   f a ->
   f ByteString
 reAnnotateUsing encoder decoder =
-  (\bs -> splice bs $ CBOR.deserialiseFromBytes (toPlainDecoder byronProtVer decoder) bs)
+  (\bs -> splice bs $ CBOR.deserialiseFromBytes (toPlainDecoder (Just bs) byronProtVer decoder) bs)
     . CBOR.toLazyByteString
     . toPlainEncoding byronProtVer
     . encoder

eras/conway/impl/src/Cardano/Ledger/Conway/TxCert.hs

@@ -58,7 +58,6 @@ import Cardano.Ledger.Binary (
   encodeListLen,
   encodeNullStrictMaybe,
   encodeWord8,
-  toPlainDecoder,
   toPlainEncoding,
  )
 import Cardano.Ledger.Binary.Coders (Decode (..), Encode (..), decode, encode, (!>), (<!))
@@ -609,7 +608,7 @@ instance
   ) =>
   FromCBOR (ConwayTxCert era)
   where
-  fromCBOR = toPlainDecoder (eraProtVerLow @era) decCBOR
+  fromCBOR = fromEraCBOR @era
 
 instance
   ( ConwayEraTxCert era

eras/shelley/impl/src/Cardano/Ledger/Shelley/Genesis.hs

@@ -478,7 +478,7 @@ instance Crypto c => ToCBOR (ShelleyGenesis c) where
           <> encCBOR sgStaking
 
 instance Crypto c => FromCBOR (ShelleyGenesis c) where
-  fromCBOR = toPlainDecoder shelleyProtVer $ do
+  fromCBOR = toPlainDecoder Nothing shelleyProtVer $ do
     decodeRecordNamed "ShelleyGenesis" (const 15) $ do
       sgSystemStart <- decCBOR
       sgNetworkMagic <- decCBOR

eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/Types.hs

@@ -41,7 +41,6 @@ import Cardano.Ledger.Binary (
   enforceDecoderVersion,
   ifDecoderVersionAtLeast,
   natVersion,
-  toPlainDecoder,
  )
 import Cardano.Ledger.Binary.Coders (Decode (From, RecD), Encode (..), decode, encode, (!>), (<!))
 import Cardano.Ledger.CertState (
@@ -362,7 +361,7 @@ instance (EraTxOut era, EraGov era) => ToCBOR (UTxOState era) where
   toCBOR = toEraCBOR @era
 
 instance (EraTxOut era, EraGov era) => FromCBOR (UTxOState era) where
-  fromCBOR = toPlainDecoder (eraProtVerLow @era) decNoShareCBOR
+  fromCBOR = fromEraShareCBOR @era
 
 instance (EraTxOut era, EraGov era) => ToJSON (UTxOState era) where
   toJSON = object . toUTxOStatePairs
@@ -556,7 +555,7 @@ instance (EraTxOut era, EraGov era) => ToCBOR (LedgerState era) where
   toCBOR = toEraCBOR @era
 
 instance (EraTxOut era, EraGov era) => FromCBOR (LedgerState era) where
-  fromCBOR = toPlainDecoder (eraProtVerLow @era) decNoShareCBOR
+  fromCBOR = fromEraShareCBOR @era
 
 instance (EraTxOut era, EraGov era) => ToJSON (LedgerState era) where
   toJSON = object . toLedgerStatePairs

libs/cardano-ledger-binary/CHANGELOG.md

@@ -2,6 +2,9 @@
 
 ## 1.5.0.0
 
+* Add `decodeAnnotated`
+* Add `getOriginalBytes`
+* `toPlainDecoder` now optionally expects one extra argument for the original `ByteString`
 * Extend `Coders` to accommodate `{Enc|Dec}CBORGroup`. #4666
   * Add `ToGroup` to `Encode`
   * Add `FromGroup` to `Decode`

libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding.hs

@@ -45,7 +45,7 @@ where
 
 import Cardano.Ledger.Binary.Decoding.Annotated
 import Cardano.Ledger.Binary.Decoding.DecCBOR
-import Cardano.Ledger.Binary.Decoding.Decoder
+import Cardano.Ledger.Binary.Decoding.Decoder hiding (getOriginalBytes)
 import Cardano.Ledger.Binary.Decoding.Drop
 import Cardano.Ledger.Binary.Decoding.Sharing
 import Cardano.Ledger.Binary.Decoding.Sized
@@ -143,8 +143,9 @@ deserialiseDecoder ::
   (forall s. Decoder s a) ->
   BSL.ByteString ->
   Either (Read.DeserialiseFailure, BS.ByteString) (a, BS.ByteString)
-deserialiseDecoder version decoder bs0 =
-  runST (supplyAllInput bs0 =<< Read.deserialiseIncremental (toPlainDecoder version decoder))
+deserialiseDecoder version decoder bsl =
+  runST $
+    supplyAllInput bsl =<< Read.deserialiseIncremental (toPlainDecoder (Just bsl) version decoder)
 {-# INLINE deserialiseDecoder #-}
 
 supplyAllInput ::

libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Annotated.hs

@@ -12,6 +12,7 @@
 
 module Cardano.Ledger.Binary.Decoding.Annotated (
   Annotated (..),
+  decodeAnnotated,
   ByteSpan (..),
   Decoded (..),
   annotationBytes,
@@ -34,6 +35,7 @@ import Cardano.Ledger.Binary.Decoding.Decoder (
   decodeList,
   decodeWithByteSpan,
   fromPlainDecoder,
+  getOriginalBytes,
   setTag,
   whenDecoderVersionAtLeast,
  )
@@ -113,6 +115,12 @@ annotationBytes bytes = fmap (BSL.toStrict . slice bytes)
 reAnnotate :: EncCBOR a => Version -> Annotated a b -> Annotated a BS.ByteString
 reAnnotate version (Annotated x _) = Annotated x (serialize' version x)
 
+decodeAnnotated :: Decoder s a -> Decoder s (Annotated a BSL.ByteString)
+decodeAnnotated decoder = do
+  bsl <- getOriginalBytes
+  fmap (slice bsl) <$> annotatedDecoder decoder
+{-# INLINE decodeAnnotated #-}
+
 class Decoded t where
   type BaseType t :: Type
   recoverBytes :: t -> BS.ByteString

libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/DecCBOR.hs

@@ -120,9 +120,9 @@ instance DecCBOR Version where
   {-# INLINE decCBOR #-}
 
 -- | Convert a versioned `DecCBOR` instance to a plain `Plain.Decoder` using Byron protocol
--- version.
+-- version and empty `BSL.ByteString`.
 fromByronCBOR :: DecCBOR a => Plain.Decoder s a
-fromByronCBOR = toPlainDecoder byronProtVer decCBOR
+fromByronCBOR = toPlainDecoder Nothing byronProtVer decCBOR
 {-# INLINE fromByronCBOR #-}
 
 --------------------------------------------------------------------------------

libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Decoder.hs

@@ -17,6 +17,7 @@ module Cardano.Ledger.Binary.Decoding.Decoder (
   fromPlainDecoder,
   withPlainDecoder,
   enforceDecoderVersion,
+  getOriginalBytes,
   DecoderError (..),
   C.ByteOffset,
   C.DecodeAction (..),
@@ -278,25 +279,25 @@ import Prelude hiding (decodeFloat)
 --------------------------------------------------------------------------------
 
 newtype Decoder s a = Decoder
-  { runDecoder :: Version -> C.Decoder s a
+  { runDecoder :: Maybe BSL.ByteString -> Version -> C.Decoder s a
   }
 
 instance Functor (Decoder s) where
-  fmap f (Decoder d) = Decoder (fmap f . d)
+  fmap f d = Decoder (\bsl v -> f <$> runDecoder d bsl v)
   {-# INLINE fmap #-}
 
 instance Applicative (Decoder s) where
-  pure x = Decoder (const (pure x))
+  pure x = Decoder (\_ _ -> pure x)
   {-# INLINE pure #-}
-  Decoder f <*> Decoder g = Decoder $ \v -> f v <*> g v
+  Decoder f <*> Decoder g = Decoder $ \bsl v -> f bsl v <*> g bsl v
   {-# INLINE (<*>) #-}
-  Decoder f *> Decoder g = Decoder $ \v -> f v *> g v
+  Decoder f *> Decoder g = Decoder $ \bsl v -> f bsl v *> g bsl v
   {-# INLINE (*>) #-}
 
 instance Monad (Decoder s) where
-  Decoder f >>= g = Decoder $ \v -> do
-    x <- f v
-    runDecoder (g x) v
+  Decoder f >>= g = Decoder $ \bsl v -> do
+    x <- f bsl v
+    runDecoder (g x) bsl v
   {-# INLINE (>>=) #-}
 
 instance MonadFail (Decoder s) where
@@ -306,24 +307,40 @@ instance MonadFail (Decoder s) where
 -- | Promote a regular `C.Decoder` to a versioned one. Which means it will work for all
 -- versions.
 fromPlainDecoder :: C.Decoder s a -> Decoder s a
-fromPlainDecoder d = Decoder (const d)
+fromPlainDecoder d = Decoder (\_ _ -> d)
 {-# INLINE fromPlainDecoder #-}
 
--- | Extract the underlying `C.Decoder` by specifying the concrete version to be used.
-toPlainDecoder :: Version -> Decoder s a -> C.Decoder s a
-toPlainDecoder v (Decoder d) = d v
+-- | Extract the underlying `C.Decoder` by optionally supplying the original bytes and
+-- specifying the concrete version to be used.
+toPlainDecoder ::
+  -- | Some decoders require the original bytes to be supplied as well. Such decoders will
+  -- fail whenever `Nothing` is supplied.
+  Maybe BSL.ByteString ->
+  Version ->
+  Decoder s a ->
+  C.Decoder s a
+toPlainDecoder bsl v (Decoder d) = d bsl v
 {-# INLINE toPlainDecoder #-}
 
 -- | Use the supplied decoder as a plain decoder with current version.
 withPlainDecoder :: Decoder s a -> (C.Decoder s a -> C.Decoder s b) -> Decoder s b
-withPlainDecoder vd f = Decoder $ \curVersion -> f (toPlainDecoder curVersion vd)
+withPlainDecoder vd f = Decoder $ \bsl -> f . runDecoder vd bsl
 {-# INLINE withPlainDecoder #-}
 
 -- | Ignore the current version of the decoder and enforce the supplied one instead.
 enforceDecoderVersion :: Version -> Decoder s a -> Decoder s a
-enforceDecoderVersion version = fromPlainDecoder . toPlainDecoder version
+enforceDecoderVersion version d = Decoder $ \bsl _ -> runDecoder d bsl version
 {-# INLINE enforceDecoderVersion #-}
 
+-- | Lookup the original bytes that are being used for deserialization. This action will
+-- fail deserialization whenever original bytes are not available.
+getOriginalBytes :: Decoder s BSL.ByteString
+getOriginalBytes =
+  Decoder $ \maybeBytes _ ->
+    case maybeBytes of
+      Nothing -> fail "Decoder was expected to provide the original ByteString"
+      Just bsl -> pure bsl
+
 --------------------------------------------------------------------------------
 -- Working with current decoder version
 --------------------------------------------------------------------------------
@@ -334,7 +351,7 @@ enforceDecoderVersion version = fromPlainDecoder . toPlainDecoder version
 -- >>> decodeFullDecoder 3 "Version" getDecoderVersion ""
 -- Right 3
 getDecoderVersion :: Decoder s Version
-getDecoderVersion = Decoder pure
+getDecoderVersion = Decoder $ \_ -> pure
 {-# INLINE getDecoderVersion #-}
 
 -- | Conditionally choose the newer or older decoder, depending on the current

libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/FlatTerm.hs

@@ -17,4 +17,4 @@ toFlatTerm :: Version -> Encoding -> C.FlatTerm
 toFlatTerm version = C.toFlatTerm . toPlainEncoding version
 
 fromFlatTerm :: Version -> (forall s. Decoder s a) -> C.FlatTerm -> Either String a
-fromFlatTerm version decoder = C.fromFlatTerm (toPlainDecoder version decoder)
+fromFlatTerm version decoder = C.fromFlatTerm (toPlainDecoder mempty version decoder)

libs/cardano-ledger-binary/testlib/Test/Cardano/Ledger/Binary/RoundTrip.hs

@@ -522,7 +522,8 @@ embedTripLabelExtra lbl encVersion decVersion (Trip encoder decoder dropper) s =
         Right val
           | Nothing <- mDropperError ->
               let flatTerm = CBOR.toFlatTerm encoding
-               in case CBOR.fromFlatTerm (toPlainDecoder decVersion decoder) flatTerm of
+                  plainDecoder = toPlainDecoder (Just encodedBytes) decVersion decoder
+               in case CBOR.fromFlatTerm plainDecoder flatTerm of
                     Left _err ->
                       -- Until we switch to a release of cborg that includes a fix for this issue:
                       -- https://github.com/well-typed/cborg/issues/324

libs/cardano-ledger-core/CHANGELOG.md

@@ -2,6 +2,9 @@
 
 ## 1.16.0.0
 
+* Remove requirement for `FromCBOR` instance for `TxOut` in `EraTxOut`
+* Add `decodeMemoized`
+* Add `DecCBOR` instance for `MemoBytes`
 * Add `VRFVerKeyHash` and `KeyRoleVRF`.
 * Switch `genDelegVrfHash`, `individualPoolStakeVrf` and `ppVrf` to using `VRFVerKeyHash`.
 * Add `{Enc|Dec}CBORGroup` instances for `Mismatch`. #4666

libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs

@@ -81,7 +81,6 @@ import Cardano.Ledger.Binary (
   DecShareCBOR (Share),
   EncCBOR,
   EncCBORGroup,
-  FromCBOR,
   Interns,
   Sized (sizedValue),
   ToCBOR,
@@ -276,7 +275,6 @@ class
   , DecCBOR (CompactForm (Value era))
   , EncCBOR (Value era)
   , ToCBOR (TxOut era)
-  , FromCBOR (TxOut era)
   , EncCBOR (TxOut era)
   , DecCBOR (TxOut era)
   , DecShareCBOR (TxOut era)

libs/cardano-ledger-core/src/Cardano/Ledger/Core/Era.hs

@@ -275,25 +275,34 @@ notSupportedInThisEraL :: HasCallStack => Lens' a b
 notSupportedInThisEraL = lens notSupportedInThisEra notSupportedInThisEra
 
 -- | Convert a type that implements `EncCBOR` to plain `Plain.Encoding` using the lowest
--- protocol version for the supplied @era@
+-- protocol version for the supplied @era@.
 toEraCBOR :: forall era t. (Era era, EncCBOR t) => t -> Plain.Encoding
 toEraCBOR = toPlainEncoding (eraProtVerLow @era) . encCBOR
 {-# INLINE toEraCBOR #-}
 
 -- | Convert a type that implements `DecCBOR` to plain `Plain.Decoder` using the lowest
 -- protocol version for the supplied @era@
+--
+-- This action should not be used for decoders that require access to original bytes, use
+-- `toPlainDecoder` instead.
 fromEraCBOR :: forall era t s. (Era era, DecCBOR t) => Plain.Decoder s t
 fromEraCBOR = eraDecoder @era decCBOR
 {-# INLINE fromEraCBOR #-}
 
 -- | Convert a type that implements `DecShareCBOR` to plain `Plain.Decoder` using the lowest
 -- protocol version for the supplied @era@
+--
+-- This action should not be used for decoders that require access to original bytes, use
+-- `toPlainDecoder` instead.
 fromEraShareCBOR :: forall era t s. (Era era, DecShareCBOR t) => Plain.Decoder s t
 fromEraShareCBOR = eraDecoder @era decNoShareCBOR
 {-# INLINE fromEraShareCBOR #-}
 
 -- | Convert a versioned `Decoder` to plain a `Plain.Decoder` using the lowest protocol
 -- version for the supplied @era@
+--
+-- This action should not be used for decoders that require access to original bytes, use
+-- `toPlainDecoder` instead.
 eraDecoder :: forall era t s. Era era => Decoder s t -> Plain.Decoder s t
-eraDecoder = toPlainDecoder (eraProtVerLow @era)
+eraDecoder = toPlainDecoder Nothing (eraProtVerLow @era)
 {-# INLINE eraDecoder #-}

libs/cardano-ledger-core/src/Cardano/Ledger/MemoBytes.hs

@@ -21,6 +21,7 @@ module Cardano.Ledger.MemoBytes (
   -- * Memoized
   Memoized (RawType),
   mkMemoized,
+  decodeMemoized,
   getMemoSafeHash,
   getMemoRawType,
   zipMemoRawType,

libs/cardano-ledger-core/src/Cardano/Ledger/MemoBytes/Internal.hs

@@ -44,6 +44,7 @@ module Cardano.Ledger.MemoBytes.Internal (
   -- * Memoized
   Memoized (RawType),
   mkMemoized,
+  decodeMemoized,
   getMemoSafeHash,
   getMemoRawType,
   zipMemoRawType,
@@ -59,9 +60,12 @@ where
 
 import Cardano.Crypto.Hash (HashAlgorithm (hashAlgorithmName))
 import Cardano.Ledger.Binary (
+  Annotated (..),
   Annotator (..),
   DecCBOR (decCBOR),
+  Decoder,
   EncCBOR,
+  decodeAnnotated,
   serialize,
   withSlice,
  )
@@ -115,16 +119,16 @@ instance (Typeable t, Typeable era) => Plain.ToCBOR (MemoBytes t era) where
   toCBOR (Memo' _ bytes _hash) = Plain.encodePreEncoded (fromShort bytes)
 
 instance
-  ( Typeable t
-  , DecCBOR (Annotator (t era))
-  , Era era
-  ) =>
+  (Typeable t, DecCBOR (Annotator (t era)), Era era) =>
   DecCBOR (Annotator (MemoBytes t era))
   where
   decCBOR = do
     (Annotator getT, Annotator getBytes) <- withSlice decCBOR
     pure (Annotator (\fullbytes -> mkMemoBytes (getT fullbytes) (getBytes fullbytes)))
 
+instance (Typeable t, DecCBOR (t era), Era era) => DecCBOR (MemoBytes t era) where
+  decCBOR = decodeMemoized decCBOR
+
 -- | Both binary representation and Haskell types are compared.
 instance Eq (t era) => Eq (MemoBytes t era) where
   x == y = mbBytes x == mbBytes y && mbRawType x == mbRawType y
@@ -216,6 +220,11 @@ class Memoized t where
 mkMemoized :: forall era t. (Era era, EncCBOR (RawType t era), Memoized t) => RawType t era -> t era
 mkMemoized rawType = wrapMemoBytes (mkMemoBytes rawType (serialize (eraProtVerLow @era) rawType))
 
+decodeMemoized :: Era era => Decoder s (t era) -> Decoder s (MemoBytes t era)
+decodeMemoized rawTypeDecoder = do
+  Annotated rawType lazyBytes <- decodeAnnotated rawTypeDecoder
+  pure $ mkMemoBytes rawType lazyBytes
+
 -- | Extract memoized SafeHash
 getMemoSafeHash :: Memoized t => t era -> SafeHash (EraCrypto era) (MemoHashIndex (RawType t))
 getMemoSafeHash t = mbHash (getMemoBytes t)

libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Evaluate.hs

@@ -180,7 +180,7 @@ instance Crypto c => ToCBOR (PlutusWithContext c) where
 instance Crypto c => FromCBOR (PlutusWithContext c) where
   fromCBOR = Plain.decodeRecordNamed "PlutusWithContext" (const 6) $ do
     pwcProtocolVersion <- fromCBOR
-    toPlainDecoder pwcProtocolVersion $ decodeWithPlutus $ \plutus -> do
+    toPlainDecoder Nothing pwcProtocolVersion $ decodeWithPlutus $ \plutus -> do
       let lang = plutusLanguage plutus
           pwcScript = Left plutus
           scriptHash = hashPlutusScript plutus