Add SerialiseAsCBOR instance for TxOut

Author: palas

cardano-api/src/Cardano/Api/Tx/Internal/Output.hs

@@ -1,17 +1,21 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE DisambiguateRecordFields #-}
 {-# LANGUAGE EmptyCase #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 module Cardano.Api.Tx.Internal.Output
   ( -- * Transaction outputs
@@ -62,7 +66,7 @@ import Cardano.Api.Era.Internal.Eon.BabbageEraOnwards
 import Cardano.Api.Era.Internal.Eon.Convert
 import Cardano.Api.Era.Internal.Eon.ShelleyBasedEra
 import Cardano.Api.Error (Error (..), displayError)
-import Cardano.Api.Hash
+import Cardano.Api.HasTypeProxy qualified as HTP
 import Cardano.Api.Ledger.Internal.Reexport qualified as Ledger
 import Cardano.Api.Monad.Error
 import Cardano.Api.Parser.Text qualified as P
@@ -81,11 +85,11 @@ import Cardano.Ledger.Alonzo.Core qualified as L
 import Cardano.Ledger.Api qualified as L
 import Cardano.Ledger.BaseTypes (StrictMaybe (..))
 import Cardano.Ledger.Coin qualified as L
-import Cardano.Ledger.Core ()
 import Cardano.Ledger.Core qualified as Core
 import Cardano.Ledger.Core qualified as Ledger
 import Cardano.Ledger.Plutus.Data qualified as Plutus
 
+import Codec.CBOR.Encoding (Encoding)
 import Data.Aeson (object, withObject, (.:), (.:?), (.=))
 import Data.Aeson qualified as Aeson
 import Data.Aeson.Key qualified as Aeson
@@ -99,6 +103,7 @@ import Data.Sequence.Strict qualified as Seq
 import Data.Text (Text)
 import Data.Text.Encoding qualified as Text
 import Data.Type.Equality
+import Data.Typeable (Typeable)
 import Data.Word
 import GHC.Exts (IsList (..))
 import GHC.Stack
@@ -120,6 +125,24 @@ data TxOut ctx era
       (TxOutValue era)
       (TxOutDatum ctx era)
       (ReferenceScript era)
+  deriving SerialiseAsCBOR
+
+instance (Typeable ctx, IsShelleyBasedEra era) => HTP.HasTypeProxy (TxOut ctx era) where
+  data AsType (TxOut ctx era) = AsTxOut (AsType era)
+  proxyToAsType :: HTP.Proxy (TxOut ctx era) -> AsType (TxOut ctx era)
+  proxyToAsType _ = AsTxOut (HTP.asType @era)
+
+instance (Typeable ctx, IsShelleyBasedEra era) => ToCBOR (TxOut ctx era) where
+  toCBOR :: TxOut ctx era -> Encoding
+  toCBOR txOut =
+    shelleyBasedEraConstraints (shelleyBasedEra @era) $
+      Ledger.toEraCBOR @(ShelleyLedgerEra era) (toShelleyTxOutAny shelleyBasedEra txOut)
+
+instance (Typeable ctx, IsShelleyBasedEra era) => FromCBOR (TxOut ctx era) where
+  fromCBOR :: Ledger.Decoder s (TxOut ctx era)
+  fromCBOR =
+    shelleyBasedEraConstraints (shelleyBasedEra @era) $
+      fromShelleyTxOut <$> pure shelleyBasedEra <*> L.fromEraCBOR @(ShelleyLedgerEra era)
 
 deriving instance Eq (TxOut ctx era)
 

cardano-api/test/cardano-api-test/Test/Cardano/Api/CBOR.hs

@@ -110,6 +110,18 @@ prop_roundtrip_tx_CBOR = H.property $ do
   x <- H.forAll $ genTx era
   shelleyBasedEraConstraints era $ H.trippingCbor (proxyToAsType Proxy) x
 
+prop_roundtrip_tx_out_CBOR :: Property
+prop_roundtrip_tx_out_CBOR = H.property $ do
+  AnyShelleyBasedEra era <- H.noteShowM . H.forAll $ Gen.element [minBound .. maxBound]
+  x <- H.forAll $ genTx era
+  txOut <- H.forAll $ Gen.element $ txOuts $ getTxBodyContent $ getTxBody x
+  txOutRT <- H.evalEither $ rtOnce era txOut -- We do this because some information gets lost on serialisation
+  shelleyBasedEraConstraints era $ H.trippingCbor (proxyToAsType Proxy) txOutRT
+ where
+  rtOnce
+    :: ShelleyBasedEra era -> TxOut CtxTx era -> Either CBOR.DecoderError (TxOut CtxTx era)
+  rtOnce sbe t = shelleyBasedEraConstraints sbe $ deserialiseFromCBOR (proxyToAsType Proxy) (serialiseToCBOR t)
+
 prop_roundtrip_witness_CBOR :: Property
 prop_roundtrip_witness_CBOR = H.property $ do
   AnyShelleyBasedEra era <- H.noteShowM . H.forAll $ Gen.element [minBound .. maxBound]
@@ -521,6 +533,7 @@ tests =
     , testProperty "roundtrip ScriptData CBOR" prop_roundtrip_ScriptData_CBOR
     , testProperty "roundtrip TxWitness Cddl" prop_roundtrip_TxWitness_Cddl
     , testProperty "roundtrip tx CBOR" prop_roundtrip_tx_CBOR
+    , testProperty "roundtrip tx out CBOR" prop_roundtrip_tx_out_CBOR
     , testProperty
         "roundtrip GovernancePoll CBOR"
         prop_roundtrip_GovernancePoll_CBOR