From 1a6b48b710cb187e2e1bba1f0a655d419b23a8ff Mon Sep 17 00:00:00 2001 From: Zachary Churchill Date: Tue, 28 Dec 2021 12:44:08 -0500 Subject: [PATCH] correct FromCBOR instance --- .../babbage/impl/cardano-ledger-babbage.cabal | 8 +- .../impl/src/Cardano/Ledger/Babbage/TxBody.hs | 293 +++++++++++------- libs/cardano-data/src/Data/Coders.hs | 8 + 3 files changed, 199 insertions(+), 110 deletions(-) diff --git a/eras/babbage/impl/cardano-ledger-babbage.cabal b/eras/babbage/impl/cardano-ledger-babbage.cabal index b0f21a9fa89..1aee3d52930 100644 --- a/eras/babbage/impl/cardano-ledger-babbage.cabal +++ b/eras/babbage/impl/cardano-ledger-babbage.cabal @@ -42,9 +42,11 @@ library bytestring, cardano-binary, cardano-crypto-class, + cardano-data, + cardano-ledger-alonzo, cardano-ledger-core, + cardano-ledger-shelley, cardano-ledger-shelley-ma, - cardano-ledger-alonzo, cardano-prelude, cardano-slotting, containers, @@ -53,12 +55,12 @@ library measures, mtl, nothunks, + plutus-core, plutus-ledger-api, plutus-tx, - plutus-core, prettyprinter, serialise, - cardano-ledger-shelley, + set-algebra, small-steps, strict-containers, text, diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody.hs index 5c40afec1c4..bd50ef64915 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody.hs @@ -26,8 +26,10 @@ module Cardano.Ledger.Babbage.TxBody ( TxBody, inputs, collateral, - collateralReturn, + referenceInputs, outputs, + collateralReturn, + totalCollateral, txcerts, txwdrls, txfee, @@ -39,10 +41,14 @@ module Cardano.Ledger.Babbage.TxBody adHash, txnetworkid ), + Datum (..), + datumDatahash, inputs', collateral', - collateralReturn', + referenceInputs', outputs', + collateralReturn', + totalCollateral', certs', wdrls', txfee', @@ -53,7 +59,7 @@ module Cardano.Ledger.Babbage.TxBody scriptIntegrityHash', adHash', txnetworkid', - AlonzoBody, + BabbageBody, EraIndependentScriptIntegrity, ScriptIntegrityHash, ) @@ -110,6 +116,7 @@ import Cardano.Ledger.Val encodeMint, isZero, ) +import Control.DeepSeq (NFData (rnf), rwhnf) import Data.Coders import Data.Maybe (fromMaybe) import Data.MemoBytes (Mem, MemoBytes (..), memoBytes) @@ -117,6 +124,8 @@ import Data.Sequence.Strict (StrictSeq) import qualified Data.Sequence.Strict as StrictSeq import Data.Set (Set) import qualified Data.Set as Set +import Data.Sharing (FromSharedCBOR (..), Interns, fromNotSharedCBOR, interns) +import qualified Data.Text as T import Data.Typeable (Proxy (..), Typeable, (:~:) (Refl)) import Data.Word import GHC.Generics (Generic) @@ -163,6 +172,10 @@ deriving stock instance ) => Eq (TxOut era) +-- | Already in NF +instance NFData (TxOut era) where + rnf = rwhnf + viewCompactTxOut :: forall era. Era era => @@ -196,29 +209,28 @@ viewTxOut :: forall era. Era era => TxOut era -> - (Addr (Crypto era), Core.Value era, StrictMaybe (DataHash (Crypto era))) -viewTxOut (TxOutCompact' bs c) = (addr, val, SNothing) + (Addr (Crypto era), Core.Value era, Datum era) +viewTxOut (TxOutCompact' bs c) = (addr, val, NoDatum) where addr = decompactAddr bs val = fromCompact c -viewTxOut (TxOutCompactDH' bs c dh) = (addr, val, SJust dh) +viewTxOut (TxOutCompactDH' bs c dh) = (addr, val, DatumHash dh) where addr = decompactAddr bs val = fromCompact c -viewTxOut (TxOutCompactDatum bs c datum) = (addr, val, SJust dh) +viewTxOut (TxOutCompactDatum bs c d) = (addr, val, Datum d) where addr = decompactAddr bs val = fromCompact c - dh = hashData datum viewTxOut (TxOut_AddrHash28_AdaOnly stakeRef a b c d adaVal) | Just Refl <- sameNat (Proxy @(SizeHash (CC.ADDRHASH (Crypto era)))) (Proxy @28) = let addr = decodeAddress28 stakeRef a b c d - in (addr, inject (fromCompact adaVal), SNothing) + in (addr, inject (fromCompact adaVal), NoDatum) viewTxOut (TxOut_AddrHash28_AdaOnly_DataHash32 stakeRef a b c d adaVal e f g h) | Just Refl <- sameNat (Proxy @(SizeHash (CC.HASH (Crypto era)))) (Proxy @32), Just Refl <- sameNat (Proxy @(SizeHash (CC.ADDRHASH (Crypto era)))) (Proxy @28) = let addr = decodeAddress28 stakeRef a b c d - in (addr, inject (fromCompact adaVal), SJust (decodeDataHash32 e f g h)) + in (addr, inject (fromCompact adaVal), DatumHash (decodeDataHash32 e f g h)) viewTxOut (TxOut_AddrHash28_AdaOnly {}) = error "Impossible: Compacted and address or hash of non-standard size" viewTxOut (TxOut_AddrHash28_AdaOnly_DataHash32 {}) = error "Impossible: Compacted and address or hash of non-standard size" @@ -233,6 +245,18 @@ instance deriving via InspectHeapNamed "TxOut" (TxOut era) instance NoThunks (TxOut era) +data Datum era + = NoDatum + | DatumHash !(DataHash (Crypto era)) + | Datum !(Data era) + deriving (Eq, Ord, Show) + +datumDatahash :: Era era => Datum era -> StrictMaybe (DataHash (Crypto era)) +datumDatahash = \case + NoDatum -> SNothing + (DatumHash d) -> SJust d + (Datum d) -> SJust $ hashData d + pattern TxOut :: forall era. ( Era era, @@ -242,28 +266,29 @@ pattern TxOut :: ) => Addr (Crypto era) -> Core.Value era -> - StrictMaybe (DataHash (Crypto era)) -> + Datum (era) -> TxOut era pattern TxOut addr vl dh <- (viewTxOut -> (addr, vl, dh)) where - TxOut (Addr network paymentCred stakeRef) vl SNothing + TxOut (Addr network paymentCred stakeRef) vl NoDatum | StakeRefBase stakeCred <- stakeRef, Just adaCompact <- getAdaOnly (Proxy @era) vl, Just (Refl, a, b, c, d) <- encodeAddress28 network paymentCred = TxOut_AddrHash28_AdaOnly stakeCred a b c d adaCompact - TxOut (Addr network paymentCred stakeRef) vl (SJust dh) + TxOut (Addr network paymentCred stakeRef) vl (DatumHash dh) | StakeRefBase stakeCred <- stakeRef, Just adaCompact <- getAdaOnly (Proxy @era) vl, Just (Refl, a, b, c, d) <- encodeAddress28 network paymentCred, Just (Refl, e, f, g, h) <- encodeDataHash32 dh = TxOut_AddrHash28_AdaOnly_DataHash32 stakeCred a b c d adaCompact e f g h - TxOut addr vl mdh = + TxOut addr vl d = let v = fromMaybe (error "Illegal value in txout") $ toCompact vl a = compactAddr addr - in case mdh of - SNothing -> TxOutCompact' a v - SJust dh -> TxOutCompactDH' a v dh + in case d of + NoDatum -> TxOutCompact' a v + DatumHash dh -> TxOutCompactDH' a v dh + Datum d' -> TxOutCompactDatum a v d' {-# COMPLETE TxOut #-} @@ -278,7 +303,7 @@ pattern TxOutCompact :: pattern TxOutCompact addr vl <- (viewCompactTxOut -> (addr, vl, SNothing)) where - TxOutCompact cAddr cVal = TxOut (decompactAddr cAddr) (fromCompact cVal) SNothing + TxOutCompact cAddr cVal = TxOut (decompactAddr cAddr) (fromCompact cVal) NoDatum -- TODO deprecate pattern TxOutCompactDH :: @@ -292,7 +317,7 @@ pattern TxOutCompactDH :: pattern TxOutCompactDH addr vl dh <- (viewCompactTxOut -> (addr, vl, SJust dh)) where - TxOutCompactDH cAddr cVal = TxOut (decompactAddr cAddr) (fromCompact cVal) . SJust + TxOutCompactDH cAddr cVal = TxOut (decompactAddr cAddr) (fromCompact cVal) . DatumHash {-# COMPLETE TxOutCompact, TxOutCompactDH #-} @@ -303,8 +328,10 @@ type ScriptIntegrityHash crypto = SafeHash crypto EraIndependentScriptIntegrity data TxBodyRaw era = TxBodyRaw { _inputs :: !(Set (TxIn (Crypto era))), _collateral :: !(Set (TxIn (Crypto era))), - _collateralReturn :: !(StrictMaybe (TxOut era)), + _referenceInputs :: !(Set (TxIn (Crypto era))), _outputs :: !(StrictSeq (TxOut era)), + _collateralReturn :: !(StrictMaybe (TxOut era)), + _totalCollateral :: !Coin, _certs :: !(StrictSeq (DCert (Crypto era))), _wdrls :: !(Wdrl (Crypto era)), _txfee :: !Coin, @@ -314,7 +341,7 @@ data TxBodyRaw era = TxBodyRaw _mint :: !(Value (Crypto era)), -- The spec makes it clear that the mint field is a -- Cardano.Ledger.Mary.Value.Value, not a Core.Value. - -- Operations on the TxBody in the AlonzoEra depend upon this. + -- Operations on the TxBody in the BabbageEra depend upon this. _scriptIntegrityHash :: !(StrictMaybe (ScriptIntegrityHash (Crypto era))), _adHash :: !(StrictMaybe (AuxiliaryDataHash (Crypto era))), _txnetworkid :: !(StrictMaybe Network) @@ -377,13 +404,12 @@ deriving via Show (Core.Value era), DecodeNonNegative (Core.Value era), FromCBOR (Annotator (Core.Script era)), - FromCBOR (Data era), Core.SerialisableData (PParamsDelta era) ) => FromCBOR (Annotator (TxBody era)) -- The Set of constraints necessary to use the TxBody pattern -type AlonzoBody era = +type BabbageBody era = ( Era era, Compactible (Core.Value era), ToCBOR (Core.Script era), @@ -391,11 +417,13 @@ type AlonzoBody era = ) pattern TxBody :: - AlonzoBody era => + BabbageBody era => + Set (TxIn (Crypto era)) -> Set (TxIn (Crypto era)) -> Set (TxIn (Crypto era)) -> - StrictMaybe (TxOut era) -> StrictSeq (TxOut era) -> + StrictMaybe (TxOut era) -> + Coin -> StrictSeq (DCert (Crypto era)) -> Wdrl (Crypto era) -> Coin -> @@ -410,8 +438,10 @@ pattern TxBody :: pattern TxBody { inputs, collateral, - collateralReturn, + referenceInputs, outputs, + collateralReturn, + totalCollateral, txcerts, txwdrls, txfee, @@ -428,8 +458,10 @@ pattern TxBody TxBodyRaw { _inputs = inputs, _collateral = collateral, - _collateralReturn = collateralReturn, + _referenceInputs = referenceInputs, _outputs = outputs, + _collateralReturn = collateralReturn, + _totalCollateral = totalCollateral, _certs = txcerts, _wdrls = txwdrls, _txfee = txfee, @@ -447,8 +479,10 @@ pattern TxBody TxBody inputsX collateralX - collateralReturnX + referenceInputsX outputsX + collateralReturnX + totalCollateralX certsX wdrlsX txfeeX @@ -465,8 +499,10 @@ pattern TxBody TxBodyRaw inputsX collateralX - collateralReturnX + referenceInputsX outputsX + collateralReturnX + totalCollateralX certsX wdrlsX txfeeX @@ -485,14 +521,16 @@ instance (c ~ Crypto era) => HashAnnotated (TxBody era) EraIndependentTxBody c -- ============================================================================== -- We define these accessor functions manually, because if we define them using --- the record syntax in the TxBody pattern, they inherit the (AlonzoBody era) +-- the record syntax in the TxBody pattern, they inherit the (BabbageBody era) -- constraint as a precondition. This is unnecessary, as one can see below -- they need not be constrained at all. This should be fixed in the GHC compiler. inputs' :: TxBody era -> Set (TxIn (Crypto era)) collateral' :: TxBody era -> Set (TxIn (Crypto era)) -collateralReturn' :: TxBody era -> StrictMaybe (TxOut era) +referenceInputs' :: TxBody era -> Set (TxIn (Crypto era)) outputs' :: TxBody era -> StrictSeq (TxOut era) +collateralReturn' :: TxBody era -> StrictMaybe (TxOut era) +totalCollateral' :: TxBody era -> Coin certs' :: TxBody era -> StrictSeq (DCert (Crypto era)) txfee' :: TxBody era -> Coin wdrls' :: TxBody era -> Wdrl (Crypto era) @@ -508,10 +546,14 @@ txnetworkid' :: TxBody era -> StrictMaybe Network collateral' (TxBodyConstr (Memo raw _)) = _collateral raw -collateralReturn' (TxBodyConstr (Memo raw _)) = _collateralReturn raw +referenceInputs' (TxBodyConstr (Memo raw _)) = _referenceInputs raw outputs' (TxBodyConstr (Memo raw _)) = _outputs raw +collateralReturn' (TxBodyConstr (Memo raw _)) = _collateralReturn raw + +totalCollateral' (TxBodyConstr (Memo raw _)) = _totalCollateral raw + certs' (TxBodyConstr (Memo raw _)) = _certs raw wdrls' (TxBodyConstr (Memo raw _)) = _wdrls raw @@ -547,7 +589,8 @@ instance <> toCBOR addr <> toCBOR cv toCBOR (TxOutCompactDatum addr cv d) = - encodeListLen 3 + encodeListLen 4 + <> toCBOR True <> toCBOR addr <> toCBOR cv <> toCBOR d @@ -561,41 +604,60 @@ instance ( Era era, DecodeNonNegative (Core.Value era), Show (Core.Value era), - Compactible (Core.Value era), - FromCBOR (Data era) + Compactible (Core.Value era) + ) => + FromCBOR (Annotator (TxOut era)) + where + fromCBOR = fromNotSharedCBOR + +instance + ( Era era, + DecodeNonNegative (Core.Value era), + Show (Core.Value era), + Compactible (Core.Value era) ) => - FromCBOR (TxOut era) + FromSharedCBOR (Annotator (TxOut era)) where - fromCBOR = do + type Share (Annotator (TxOut era)) = Interns (Credential 'Staking (Crypto era)) + fromSharedCBOR credsInterns = do lenOrIndef <- decodeListLenOrIndef - case lenOrIndef of - Nothing -> do - a <- fromCBOR - cv <- decodeNonNegative - decodeBreakOr >>= \case - True -> pure $ TxOutCompact a cv - False -> do - dh <- fromCBOR - decodeBreakOr >>= \case - True -> pure $ TxOutCompactDH a cv dh - False -> cborError $ DecoderErrorCustom "txout" "Excess terms in txout" + let internTxOut :: TxOut era -> TxOut era + internTxOut = \case + TxOut_AddrHash28_AdaOnly cred a b c d ada -> + TxOut_AddrHash28_AdaOnly (interns credsInterns cred) a b c d ada + TxOut_AddrHash28_AdaOnly_DataHash32 cred a b c d ada e f g h -> + TxOut_AddrHash28_AdaOnly_DataHash32 (interns credsInterns cred) a b c d ada e f g h + txOut -> txOut + internTxOut <$$> case lenOrIndef of + Nothing -> + fmap pure $ do + a <- fromCBOR + cv <- decodeNonNegative + decodeBreakOr >>= \case + True -> pure $ TxOutCompact a cv + False -> do + dh <- fromCBOR + decodeBreakOr >>= \case + True -> pure $ TxOutCompactDH a cv dh + False -> cborError $ DecoderErrorCustom "txout" "Excess terms in txout" Just 2 -> - TxOutCompact - <$> fromCBOR - <*> decodeNonNegative + fmap pure $ + TxOutCompact + <$> fromCBOR + <*> decodeNonNegative Just 3 -> - decodeBreakOr >>= \case - True -> - TxOutCompactDatum - <$> fromCBOR - <*> decodeNonNegative - <*> fromCBOR - False -> - TxOutCompactDH - <$> fromCBOR - <*> decodeNonNegative - <*> fromCBOR - Just _ -> cborError $ DecoderErrorCustom "txout" "wrong number of terms in txout" + fmap pure $ + TxOutCompactDH + <$> fromCBOR + <*> decodeNonNegative + <*> fromCBOR + Just 4 -> do + _ <- fromCBOR @Bool + a <- fromCBOR + b <- decodeNonNegative + c <- fromCBOR + pure $ TxOutCompactDatum a b <$> c + Just n -> cborError $ DecoderErrorCustom "txout" $ "wrong number of terms in txout: " <> T.pack (show n) encodeTxBodyRaw :: ( Era era, @@ -607,8 +669,10 @@ encodeTxBodyRaw TxBodyRaw { _inputs, _collateral, - _collateralReturn, + _referenceInputs, _outputs, + _collateralReturn, + _totalCollateral, _certs, _wdrls, _txfee, @@ -621,13 +685,15 @@ encodeTxBodyRaw _txnetworkid } = Keyed - ( \i ifee ca o f t c w u b rsh mi sh ah ni -> - TxBodyRaw i ifee ca o c w f (ValidityInterval b t) u rsh mi sh ah ni + ( \i ifee ri o cr tc f t c w u b rsh mi sh ah ni -> + TxBodyRaw i ifee ri o cr tc c w f (ValidityInterval b t) u rsh mi sh ah ni ) !> Key 0 (E encodeFoldable _inputs) !> Key 13 (E encodeFoldable _collateral) - !> Key 16 (To _collateralReturn) + !> Key 18 (E encodeFoldable _referenceInputs) !> Key 1 (E encodeFoldable _outputs) + !> Key 16 (To _collateralReturn) + !> Key 17 (To _totalCollateral) !> Key 2 (To _txfee) !> encodeKeyedStrictMaybe 3 top !> Omit null (Key 4 (E encodeFoldable _certs)) @@ -647,6 +713,12 @@ encodeTxBodyRaw fromSJust (SJust x) = x fromSJust SNothing = error "SNothing in fromSJust. This should never happen, it is guarded by isSNothing" +doubleFmap, (<$$>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b) +{-# INLINE doubleFmap #-} +doubleFmap = fmap . fmap +{-# INLINE (<$$>) #-} +(<$$>) = doubleFmap + instance forall era. ( Era era, @@ -657,16 +729,15 @@ instance DecodeNonNegative (Core.Value era), FromCBOR (Annotator (Core.Script era)), FromCBOR (PParamsDelta era), - FromCBOR (Data era), ToCBOR (PParamsDelta era) ) => - FromCBOR (TxBodyRaw era) + FromCBOR (Annotator (TxBodyRaw era)) where fromCBOR = decode $ SparseKeyed "TxBodyRaw" - initial + (pure initial) bodyFields requiredFields where @@ -675,8 +746,10 @@ instance TxBodyRaw mempty mempty - SNothing + mempty StrictSeq.empty + SNothing + mempty StrictSeq.empty (Wdrl mempty) mempty @@ -687,43 +760,51 @@ instance SNothing SNothing SNothing - bodyFields :: (Word -> Field (TxBodyRaw era)) + bodyFields :: (Word -> Field (Annotator (TxBodyRaw era))) bodyFields 0 = - field + fieldA (\x tx -> tx {_inputs = x}) (D (decodeSet fromCBOR)) bodyFields 13 = - field + fieldA (\x tx -> tx {_collateral = x}) (D (decodeSet fromCBOR)) - bodyFields 16 = - field - (\x tx -> tx {_collateralReturn = x}) - (D (SJust <$> fromCBOR)) + bodyFields 18 = + fieldA + (\x tx -> tx {_referenceInputs = x}) + (D (decodeSet fromCBOR)) bodyFields 1 = - field + fieldAA (\x tx -> tx {_outputs = x}) - (D (decodeStrictSeq fromCBOR)) - bodyFields 2 = field (\x tx -> tx {_txfee = x}) From + (D (decodeAnnStrictSeq fromCBOR)) + bodyFields 16 = + fieldAA + (\x tx -> tx {_collateralReturn = x}) + (D (sequenceA <$> fromCBOR)) + bodyFields 17 = + fieldA + (\x tx -> tx {_totalCollateral = x}) + (D (fromCBOR)) + bodyFields 2 = fieldA (\x tx -> tx {_txfee = x}) From bodyFields 3 = - field + fieldA (\x tx -> tx {_vldt = (_vldt tx) {invalidHereafter = x}}) (D (SJust <$> fromCBOR)) bodyFields 4 = - field + fieldA (\x tx -> tx {_certs = x}) (D (decodeStrictSeq fromCBOR)) - bodyFields 5 = field (\x tx -> tx {_wdrls = x}) From - bodyFields 6 = field (\x tx -> tx {_update = x}) (D (SJust <$> fromCBOR)) - bodyFields 7 = field (\x tx -> tx {_adHash = x}) (D (SJust <$> fromCBOR)) + bodyFields 5 = fieldA (\x tx -> tx {_wdrls = x}) From + bodyFields 6 = fieldA (\x tx -> tx {_update = x}) (D (SJust <$> fromCBOR)) + bodyFields 7 = fieldA (\x tx -> tx {_adHash = x}) (D (SJust <$> fromCBOR)) bodyFields 8 = - field + fieldA (\x tx -> tx {_vldt = (_vldt tx) {invalidBefore = x}}) (D (SJust <$> fromCBOR)) - bodyFields 9 = field (\x tx -> tx {_mint = x}) (D decodeMint) - bodyFields 11 = field (\x tx -> tx {_scriptIntegrityHash = x}) (D (SJust <$> fromCBOR)) - bodyFields 14 = field (\x tx -> tx {_reqSignerHashes = x}) (D (decodeSet fromCBOR)) - bodyFields 15 = field (\x tx -> tx {_txnetworkid = x}) (D (SJust <$> fromCBOR)) + bodyFields 9 = fieldA (\x tx -> tx {_mint = x}) (D decodeMint) + bodyFields 11 = fieldA (\x tx -> tx {_scriptIntegrityHash = x}) (D (SJust <$> fromCBOR)) + bodyFields 14 = fieldA (\x tx -> tx {_reqSignerHashes = x}) (D (decodeSet fromCBOR)) + bodyFields 15 = fieldA (\x tx -> tx {_txnetworkid = x}) (D (SJust <$> fromCBOR)) bodyFields n = field (\_ t -> t) (Invalid n) requiredFields = [ (0, "inputs"), @@ -731,22 +812,6 @@ instance (2, "fee") ] -instance - ( Era era, - Typeable (Core.Script era), - Typeable (Core.AuxiliaryData era), - Compactible (Core.Value era), - Show (Core.Value era), - DecodeNonNegative (Core.Value era), - FromCBOR (Annotator (Core.Script era)), - FromCBOR (PParamsDelta era), - FromCBOR (Data era), - ToCBOR (PParamsDelta era) - ) => - FromCBOR (Annotator (TxBodyRaw era)) - where - fromCBOR = pure <$> fromCBOR - -- ==================================================== -- HasField instances to be consistent with earlier Eras @@ -780,6 +845,15 @@ instance (Crypto era ~ c) => HasField "mint" (TxBody era) (Mary.Value c) where instance (Crypto era ~ c) => HasField "collateral" (TxBody era) (Set (TxIn c)) where getField (TxBodyConstr (Memo m _)) = _collateral m +instance (Crypto era ~ c) => HasField "referenceInputs" (TxBody era) (Set (TxIn c)) where + getField (TxBodyConstr (Memo m _)) = _referenceInputs m + +instance HasField "collateralReturn" (TxBody era) (StrictMaybe (TxOut era)) where + getField (TxBodyConstr (Memo m _)) = _collateralReturn m + +instance HasField "totalCollateral" (TxBody era) (Coin) where + getField (TxBodyConstr (Memo m _)) = _totalCollateral m + instance (Crypto era ~ c) => HasField "minted" (TxBody era) (Set (ScriptHash c)) where getField (TxBodyConstr (Memo m _)) = Set.map policyID (policies (_mint m)) @@ -816,3 +890,8 @@ instance (Era era, Core.Value era ~ val, Compactible val) => HasField "value" (T instance (Era era, c ~ Crypto era) => HasField "datahash" (TxOut era) (StrictMaybe (DataHash c)) where getField (TxOutCompact _ _) = SNothing getField (TxOutCompactDH _ _ d) = SJust d + +instance (Era era) => HasField "datum" (TxOut era) (StrictMaybe (Data era)) where + getField (TxOutCompact _ _) = SNothing + getField (TxOutCompactDatum _ _ d) = SJust d + getField (TxOutCompactDH _ _ _) = SNothing diff --git a/libs/cardano-data/src/Data/Coders.hs b/libs/cardano-data/src/Data/Coders.hs index 5b5de0f609c..f65c281040f 100644 --- a/libs/cardano-data/src/Data/Coders.hs +++ b/libs/cardano-data/src/Data/Coders.hs @@ -45,9 +45,11 @@ module Data.Coders decode, runE, -- Used in testing decodeList, + decodeAnnList, decodePair, decodeSeq, decodeStrictSeq, + decodeAnnStrictSeq, decodeSet, decodeAnnSet, decodeRecordNamed, @@ -228,12 +230,18 @@ unusedRequiredKeys used required name = decodeList :: Decoder s a -> Decoder s [a] decodeList = decodeCollection decodeListLenOrIndef +decodeAnnList :: Decoder s (Annotator t) -> Decoder s (Annotator [t]) +decodeAnnList dec = do xs <- decodeList dec; pure (sequenceA xs) + decodeSeq :: Decoder s a -> Decoder s (Seq a) decodeSeq decoder = Seq.fromList <$> decodeList decoder decodeStrictSeq :: Decoder s a -> Decoder s (StrictSeq a) decodeStrictSeq decoder = StrictSeq.fromList <$> decodeList decoder +decodeAnnStrictSeq :: Decoder s (Annotator a) -> Decoder s (Annotator (StrictSeq a)) +decodeAnnStrictSeq dec = do xs <- decodeList dec; pure (StrictSeq.fromList <$> (sequenceA xs)) + decodeSet :: Ord a => Decoder s a -> Decoder s (Set a) decodeSet decoder = Set.fromList <$> decodeList decoder