Add generators and coverage for protocol parameters

lib/core/cardano-wallet-core.cabal

@@ -47,6 +47,7 @@ library
     , cardano-numeric
     , cardano-ledger-core
     , cardano-ledger-byron-test
+    , cardano-ledger-alonzo
     , cardano-slotting
     , cborg
     , containers
@@ -330,6 +331,7 @@ test-suite unit
     , network-uri
     , nothunks
     , persistent
+    , plutus-ledger-api
     , pretty-simple
     , regex-pcre-builtin
     , OddWord

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

@@ -1,5 +1,7 @@
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 
 module Cardano.Api.Gen
@@ -62,14 +64,28 @@ module Cardano.Api.Gen
   , genTxOutValue
   , genTxOut
   , genTxOutDatumHash
+  , genNat
+  , genRational
+  , genRationalInt64
+  , genEpochNo
+  , genCostModel
+  , genCostModels
+  , genExecutionUnitPrices
+  , genProtocolParameters
   ) where
 
 import Prelude
 
 import Cardano.Api hiding
     ( txIns )
+import Cardano.Api.Byron
+    ( KeyWitness (ByronKeyWitness), WitnessNetworkIdOrByronAddress (..) )
 import Cardano.Api.Shelley
-    ( Hash (..), PlutusScript (..), StakeCredential (..) )
+    ( Hash (..)
+    , PlutusScript (..)
+    , ProtocolParameters (..)
+    , StakeCredential (..)
+    )
 import Cardano.Ledger.Credential
     ( Ix, Ptr (..) )
 import Cardano.Ledger.SafeHash
@@ -80,40 +96,56 @@ import Data.Coerce
     ( coerce )
 import Data.Int
     ( Int64 )
+import Data.Map
+    ( Map )
 import Data.Maybe
     ( maybeToList )
+import Data.Ratio
+    ( Ratio, (%) )
 import Data.String
     ( fromString )
 import Data.Text
     ( Text )
 import Data.Word
-    ( Word64, Word8 )
+    ( Word32, Word64, Word8 )
+import Numeric.Natural
+    ( Natural )
 import Test.Cardano.Crypto.Gen
-    ()
+    ( genProtocolMagicId )
 import Test.QuickCheck
     ( Gen
     , Large (..)
     , Positive (..)
     , arbitrary
     , choose
+    , chooseBoundedIntegral
     , chooseInt
+    , chooseInteger
     , elements
     , frequency
+    , liftArbitrary
     , listOf
+    , listOf1
     , oneof
     , scale
     , sized
     , vector
     , vectorOf
     )
+import Test.QuickCheck.Hedgehog
+    ( hedgehog )
 
+import qualified Cardano.Api as Api
 import qualified Cardano.Binary as CBOR
 import qualified Cardano.Crypto.Hash as Crypto
 import qualified Cardano.Crypto.Seed as Crypto
+import qualified Cardano.Ledger.Alonzo.Language as Alonzo
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Short as SBS
 import qualified Data.Map as Map
+import qualified Data.Set as Set
 import qualified Data.Text as T
+import qualified Plutus.V1.Ledger.Api as Plutus
 import qualified Shelley.Spec.Ledger.TxBody as Ledger
     ( EraIndependentTxBody )
 
@@ -146,7 +178,7 @@ genSlotNo = SlotNo <$> arbitrary
 
 genLovelace :: Gen Lovelace
 genLovelace = do
-    (Large (n :: Word64)) <- arbitrary
+    (Large (n :: Word32)) <- arbitrary
     pure $ quantityToLovelace $ Quantity $ toInteger n
 
 genTxFee :: CardanoEra era -> Gen (TxFee era)
@@ -591,7 +623,7 @@ genAddressInEra era =
 
 genUnsignedQuantity :: Gen Quantity
 genUnsignedQuantity = do
-    (Large (n :: Word64)) <- arbitrary
+    (Large (n :: Word32)) <- arbitrary
     pure $ fromIntegral n
 
 -- | Generate a 'Value' suitable for usage in a transaction output, i.e. any
@@ -627,3 +659,90 @@ genHashScriptData :: Gen (Cardano.Api.Hash ScriptData)
 genHashScriptData =
     ScriptDataHash . unsafeMakeSafeHash . mkDummyHash
         <$> (scale (`mod` 10) arbitrary)
+
+genNat :: Gen Natural
+genNat = do
+    Large (n :: Word64) <- arbitrary
+    pure $ fromIntegral n
+
+genRational :: Gen Rational
+genRational =
+    (\d -> ratioToRational (1 % d)) <$> genDenominator
+  where
+    genDenominator :: Gen Word64
+    genDenominator = do
+        (Positive (Large n)) <- arbitrary
+        pure n
+
+    ratioToRational :: Ratio Word64 -> Rational
+    ratioToRational = toRational
+
+-- TODO: consolidate this back to just genRational once this is merged:
+-- https://github.com/input-output-hk/cardano-ledger-specs/pull/2330
+genRationalInt64 :: Gen Rational
+genRationalInt64 =
+    (\d -> ratioToRational (1 % d)) <$> genDenominator
+  where
+    genDenominator :: Gen Int64
+    genDenominator = do
+        (Positive (Large n)) <- arbitrary
+        pure n
+
+    ratioToRational :: Ratio Int64 -> Rational
+    ratioToRational = toRational
+
+genPraosNonce :: Gen PraosNonce
+genPraosNonce = makePraosNonce <$> arbitrary
+
+genEpochNo :: Gen EpochNo
+genEpochNo = EpochNo <$> arbitrary
+
+genCostModel :: Gen CostModel
+genCostModel = case Plutus.defaultCostModelParams of
+  Nothing -> error "Plutus defaultCostModelParams is broken."
+  Just dcm ->
+      CostModel
+    -- TODO This needs to be the cost model struct for whichever
+    -- Plutus version we're using, once we support multiple Plutus versions.
+    <$> mapM (const $ chooseInteger (0, 5000)) dcm
+
+genCostModels :: Gen (Map AnyPlutusScriptVersion CostModel)
+genCostModels = do
+    n <- chooseInt (0, length plutusScriptVersions)
+    Map.fromList
+        <$> vectorOf n ((,) <$> elements plutusScriptVersions <*> genCostModel)
+  where
+    plutusScriptVersions :: [AnyPlutusScriptVersion]
+    plutusScriptVersions = [minBound..maxBound]
+
+genExecutionUnitPrices :: Gen ExecutionUnitPrices
+genExecutionUnitPrices = ExecutionUnitPrices <$> genRational <*> genRational
+
+genProtocolParameters :: Gen ProtocolParameters
+genProtocolParameters =
+  ProtocolParameters
+    <$> ((,) <$> genNat <*> genNat)
+    <*> genRational
+    <*> liftArbitrary genPraosNonce
+    <*> genNat
+    <*> genNat
+    <*> genNat
+    <*> genNat
+    <*> genNat
+    <*> liftArbitrary genLovelace
+    <*> genLovelace
+    <*> genLovelace
+    <*> genLovelace
+    <*> genEpochNo
+    <*> genNat
+    <*> genRationalInt64
+    <*> genRational
+    <*> genRational
+    <*> liftArbitrary genLovelace
+    <*> genCostModels
+    <*> liftArbitrary genExecutionUnitPrices
+    <*> liftArbitrary genExecutionUnits
+    <*> liftArbitrary genExecutionUnits
+    <*> liftArbitrary genNat
+    <*> liftArbitrary genNat
+    <*> liftArbitrary genNat