Add generators and coverage for TxOut

lib/core/src/Cardano/Api/Gen.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Cardano.Api.Gen
   ( genTxIn
@@ -56,18 +57,27 @@ module Cardano.Api.Gen
   , genAddressByron
   , genAddressShelley
   , genAddressInEra
+  , genUnsignedQuantity
+  , genValueForTxOut
+  , genTxOutValue
+  , genTxOut
+  , genTxOutDatumHash
   ) where
 
 import Prelude
 
 import Cardano.Api hiding
     ( txIns )
 import Cardano.Api.Shelley
-    ( PlutusScript (..), StakeCredential (..) )
+    ( Hash (..), PlutusScript (..), StakeCredential (..) )
 import Cardano.Ledger.Credential
     ( Ix, Ptr (..) )
+import Cardano.Ledger.SafeHash
+    ( unsafeMakeSafeHash )
 import Data.ByteString
     ( ByteString )
+import Data.Coerce
+    ( coerce )
 import Data.Int
     ( Int64 )
 import Data.Maybe
@@ -99,7 +109,6 @@ import Test.QuickCheck
 
 import qualified Cardano.Binary as CBOR
 import qualified Cardano.Crypto.Hash as Crypto
-import qualified Cardano.Crypto.Hash.Class as Crypto
 import qualified Cardano.Crypto.Seed as Crypto
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Short as SBS
@@ -580,3 +589,41 @@ genAddressInEra era =
         , shelleyAddressInEra <$> genAddressShelley
         ]
 
+genUnsignedQuantity :: Gen Quantity
+genUnsignedQuantity = do
+    (Large (n :: Word64)) <- arbitrary
+    pure $ fromIntegral n
+
+-- | Generate a 'Value' suitable for usage in a transaction output, i.e. any
+-- asset ID and a positive quantity.
+genValueForTxOut :: Gen Value
+genValueForTxOut = genValue genAssetId genUnsignedQuantity
+
+genTxOutValue :: CardanoEra era -> Gen (TxOutValue era)
+genTxOutValue era =
+  case multiAssetSupportedInEra era of
+    Left adaOnlyInEra     -> TxOutAdaOnly adaOnlyInEra <$> genLovelace
+    Right multiAssetInEra -> TxOutValue multiAssetInEra <$> genValueForTxOut
+
+genTxOut :: CardanoEra era -> Gen (TxOut era)
+genTxOut era =
+  TxOut <$> genAddressInEra era
+        <*> genTxOutValue era
+        <*> genTxOutDatumHash era
+
+genTxOutDatumHash :: CardanoEra era -> Gen (TxOutDatumHash era)
+genTxOutDatumHash era =
+    case scriptDataSupportedInEra era of
+        Nothing -> pure TxOutDatumHashNone
+        Just supported -> oneof
+            [ pure TxOutDatumHashNone
+            , TxOutDatumHash supported <$> genHashScriptData
+            ]
+
+mkDummyHash :: forall h a. Crypto.HashAlgorithm h => Int -> Crypto.Hash h a
+mkDummyHash = coerce . Crypto.hashWithSerialiser @h CBOR.toCBOR
+
+genHashScriptData :: Gen (Cardano.Api.Hash ScriptData)
+genHashScriptData =
+    ScriptDataHash . unsafeMakeSafeHash . mkDummyHash
+        <$> (scale (`mod` 10) arbitrary)

lib/core/test/unit/Cardano/Api/GenSpec.hs

@@ -16,6 +16,7 @@ import Cardano.Api
     , AssetName (..)
     , BuildTx
     , CardanoEra (..)
+    , CardanoEraStyle (..)
     , ExecutionUnits (..)
     , KeyWitnessInCtx (..)
     , Lovelace
@@ -39,6 +40,9 @@ import Cardano.Api
     , TxMetadataInEra (..)
     , TxMetadataValue (..)
     , TxMintValue (..)
+    , TxOut (..)
+    , TxOutDatumHash (..)
+    , TxOutValue (..)
     , TxScriptValidity (..)
     , TxValidityLowerBound (..)
     , TxValidityUpperBound (..)
@@ -47,9 +51,11 @@ import Cardano.Api
     , WitCtxStake
     , Witness (..)
     , auxScriptsSupportedInEra
+    , cardanoEraStyle
     , collateralSupportedInEra
     , extraKeyWitnessesSupportedInEra
     , multiAssetSupportedInEra
+    , scriptDataSupportedInEra
     , scriptLanguageSupportedInEra
     , txFeesExplicitInEra
     , txMetadataSupportedInEra
@@ -403,23 +409,92 @@ spec =
             describe "genAddressInEra" $ do
                 it "genAddressInEra ByronEra" $
                     property $ forAll
-                        (genAddressInEra ByronEra) genAddressInByronEraCoverage
+                        (genAddressInEra ByronEra)
+                        (genAddressInEraCoverage ByronEra)
                 it "genAddressInEra ShelleyEra" $
                     property $ forAll
                         (genAddressInEra ShelleyEra)
-                        genAddressInShelleyBasedEraCoverage
+                        (genAddressInEraCoverage ShelleyEra)
                 it "genAddressInEra AllegraEra" $
                     property $ forAll
                         (genAddressInEra AllegraEra)
-                        genAddressInShelleyBasedEraCoverage
+                        (genAddressInEraCoverage AllegraEra)
                 it "genAddressInEra MaryEra" $
                     property $ forAll
                         (genAddressInEra MaryEra)
-                        genAddressInShelleyBasedEraCoverage
+                        (genAddressInEraCoverage MaryEra)
                 it "genAddressInEra AlonzoEra" $
                     property $ forAll
                         (genAddressInEra AlonzoEra)
-                        genAddressInShelleyBasedEraCoverage
+                        (genAddressInEraCoverage AlonzoEra)
+            it "genUnsignedQuantity" $
+                property $
+                    forAll genUnsignedQuantity genUnsignedQuantityCoverage
+            it "genValueForTxOutCoverage" $
+                property $ forAll genValueForTxOut genValueForTxOutCoverage
+            describe "genTxOutDatumHash" $ do
+                it "genTxOutDatumHash ByronEra" $
+                    property $ forAll
+                        (genTxOutDatumHash ByronEra)
+                        (genTxOutDatumHashCoverage ByronEra)
+                it "genTxOutDatumHash ShelleyEra" $
+                    property $ forAll
+                        (genTxOutDatumHash ShelleyEra)
+                        (genTxOutDatumHashCoverage ShelleyEra)
+                it "genTxOutDatumHash AllegraEra" $
+                    property $ forAll
+                        (genTxOutDatumHash AllegraEra)
+                        (genTxOutDatumHashCoverage AllegraEra)
+                it "genTxOutDatumHash MaryEra" $
+                    property $ forAll
+                        (genTxOutDatumHash MaryEra)
+                        (genTxOutDatumHashCoverage MaryEra)
+                it "genTxOutDatumHash AlonzoEra" $
+                    property $ forAll
+                        (genTxOutDatumHash AlonzoEra)
+                        (genTxOutDatumHashCoverage AlonzoEra)
+            describe "genTxOutValue" $ do
+                it "genTxOutValue ByronEra" $
+                    property $ forAll
+                        (genTxOutValue ByronEra)
+                        (genTxOutValueCoverage ByronEra)
+                it "genTxOutValue ShelleyEra" $
+                    property $ forAll
+                        (genTxOutValue ShelleyEra)
+                        (genTxOutValueCoverage ShelleyEra)
+                it "genTxOutValue AllegraEra" $
+                    property $ forAll
+                        (genTxOutValue AllegraEra)
+                        (genTxOutValueCoverage AllegraEra)
+                it "genTxOutValue MaryEra" $
+                    property $ forAll
+                        (genTxOutValue MaryEra)
+                        (genTxOutValueCoverage MaryEra)
+                it "genTxOutValue AlonzoEra" $
+                    property $ forAll
+                        (genTxOutValue AlonzoEra)
+                        (genTxOutValueCoverage AlonzoEra)
+            describe "genTxOut" $ do
+                it "genTxOut ByronEra" $
+                    property $ forAll
+                        (genTxOut ByronEra)
+                        (genTxOutCoverage ByronEra)
+                it "genTxOut ShelleyEra" $
+                    property $ forAll
+                        (genTxOut ShelleyEra)
+                        (genTxOutCoverage ShelleyEra)
+                it "genTxOut AllegraEra" $
+                    property $ forAll
+                        (genTxOut AllegraEra)
+                        (genTxOutCoverage AllegraEra)
+                it "genTxOut MaryEra" $
+                    property $ forAll
+                        (genTxOut MaryEra)
+                        (genTxOutCoverage MaryEra)
+                it "genTxOut AlonzoEra" $
+                    property $ forAll
+                        (genTxOut AlonzoEra)
+                        (genTxOutCoverage AlonzoEra)
 
 genTxIxCoverage :: TxIx -> Property
 genTxIxCoverage (TxIx ix) = unsignedCoverage (Proxy @Word32) "txIx" ix
@@ -1178,23 +1253,24 @@ genPaymentCredentialCoverage paymentCred = checkCoverage
 instance Arbitrary PaymentCredential where
     arbitrary = genPaymentCredential
 
-genAddressInByronEraCoverage :: AddressInEra era -> Property
-genAddressInByronEraCoverage addr =
-    label "in Byron era, always generate byron addresses"
-    $ case addr of
-        AddressInEra ByronAddressInAnyEra _addr ->
-            True
-        _ ->
-            False
-    & counterexample "Non-Byron address was generated in Byron era"
-
-genAddressInShelleyBasedEraCoverage :: AddressInEra era -> Property
-genAddressInShelleyBasedEraCoverage addr = checkCoverage
-    $ cover 10 (isByronAddress addr)
-        "byron address"
-    $ cover 10 (isShelleyAddress addr)
-        "shelley address"
-        True
+genAddressInEraCoverage
+    :: CardanoEra era
+    -> AddressInEra era
+    -> Property
+genAddressInEraCoverage era addr =
+    case cardanoEraStyle era of
+        LegacyByronEra ->
+            if isByronAddress addr
+            then True
+                 & label "in Byron era, always generate byron addresses"
+            else False
+                 & counterexample "Non-Byron address was generated in Byron era"
+        ShelleyBasedEra _era -> checkCoverage
+            $ cover 10 (isByronAddress addr)
+                "byron address"
+            $ cover 10 (isShelleyAddress addr)
+                "shelley address"
+                True
 
     where
         isByronAddress = \case
@@ -1204,6 +1280,74 @@ genAddressInShelleyBasedEraCoverage addr = checkCoverage
             AddressInEra (ShelleyAddressInEra _era) _addr -> True
             _ -> False
 
+genUnsignedQuantityCoverage :: Quantity -> Property
+genUnsignedQuantityCoverage =
+    unsignedCoverage (Proxy @Word32) "unsigned quantity"
+
+genValueForTxOutCoverage :: Value -> Property
+genValueForTxOutCoverage val =
+    let
+        valList = valueToList val
+    in
+        checkCoverage
+        $ cover 1 (null valList)
+            "Value has no assets"
+        $ cover 10 (not $ null valList)
+            "Value has some assets"
+        $ cover 10 (length valList >= 3)
+            "Value has more assets"
+            True
+
+genTxOutDatumHashCoverage
+    :: CardanoEra era -> TxOutDatumHash era -> Property
+genTxOutDatumHashCoverage era datum =
+    case scriptDataSupportedInEra era of
+        Nothing ->
+            (datum == TxOutDatumHashNone)
+            & label "tx out datums not generated in unsupported era"
+            & counterexample ( "tx out datums were generated in unsupported "
+                               <> show era
+                             )
+        Just _ -> checkCoverage
+            $ cover 30 (hasNoDatumHash datum)
+                "no tx out datum hash"
+            $ cover 30 (hasDatumHash datum)
+                "tx out datum hash present"
+                True
+    where
+        hasNoDatumHash = (== TxOutDatumHashNone)
+
+        hasDatumHash = \case
+            TxOutDatumHashNone   -> False
+            (TxOutDatumHash _ _) -> True
+
+genTxOutValueCoverage :: CardanoEra era -> TxOutValue era -> Property
+genTxOutValueCoverage era val =
+    case multiAssetSupportedInEra era of
+        Left _ ->
+            case val of
+                (TxOutAdaOnly _ l) ->
+                    genLovelaceCoverage l
+                    & label ("ADA only supported in " <> show era)
+                _                  ->
+                    property False
+                    & counterexample (show era <> " should only support ADA")
+        Right _ ->
+            case val of
+                (TxOutValue _ value) ->
+                    genValueForTxOutCoverage value
+                    & label ("Multi-asset supported in " <> show era)
+                _ ->
+                    property False
+                    & counterexample (show era <> " should support multi-asset")
+
+genTxOutCoverage :: CardanoEra era -> TxOut era -> Property
+genTxOutCoverage era (TxOut addr val datum) = conjoin
+    [ genAddressInEraCoverage era addr
+    , genTxOutValueCoverage era val
+    , genTxOutDatumHashCoverage era datum
+    ]
+
 -- | Provide coverage for an unsigned number.
 unsignedCoverage
     :: ( Num a