added exampleTx.

libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Consensus.hs

@@ -72,6 +72,7 @@ import qualified Cardano.Ledger.Shelley.PParams as ShelleyPP
 import qualified Cardano.Ledger.Alonzo.PParams as AlonzoPP
 import qualified Cardano.Ledger.Babbage.PParams as BabbagePP
 import qualified  Cardano.Ledger.Conway.PParams as ConwayPP
+import Cardano.Protocol.TPraos.API(PraosCrypto)
 
 type KeyPairWits era = [KeyPair 'Witness (Cardano.Ledger.Era.Crypto era)]
 
@@ -84,6 +85,15 @@ emptyPPUpdate (Alonzo _) = AlonzoPP.emptyPParamsUpdate
 emptyPPUpdate (Babbage _) = BabbagePP.emptyPParamsUpdate
 emptyPPUpdate (Conway _) = ConwayPP.emptyPParamsUpdate
 
+
+emptyPP :: Proof era -> Core.PParams era
+emptyPP (Shelley _) = ShelleyPP.emptyPParams
+emptyPP (Allegra _) = ShelleyPP.emptyPParams
+emptyPP (Mary _) = ShelleyPP.emptyPParams
+emptyPP (Alonzo _) = AlonzoPP.emptyPParams
+emptyPP (Babbage _) = BabbagePP.emptyPParams
+emptyPP (Conway _) = ConwayPP.emptyPParams
+
 {-------------------------------------------------------------------------------
   ShelleyLedgerExamples
 -------------------------------------------------------------------------------}
@@ -114,11 +124,12 @@ data LedgerExamples era = LedgerExamples
   }
 
 -- ============================================================
-
-class PredicateFailure (Core.EraRule "DELEGS" era) ~ DelegsPredicateFailure era => Delegate era where
-
-
-defaultLedgerExamples :: forall era. Reflect era =>
+
+defaultLedgerExamples :: forall era.
+  ( Reflect era,
+    Default (StashedAVVMAddresses era),
+    Default (State (Core.EraRule "PPUP" era))
+  ) =>
   Proof era -> 
   (Core.TxBody era -> KeyPairWits era -> Core.Witnesses era) ->
   (ShelleyTx era -> Core.Tx era) ->
@@ -130,9 +141,9 @@ defaultLedgerExamples :: forall era. Reflect era =>
 defaultLedgerExamples proof mkWitnesses mkAlonzoTx value txBody auxData translationContext =
   LedgerExamples
     { sleProof = proof,
-      sleBlock = exampleLedgerBlock proof (mkAlonzoTx tx),
+      sleBlock = exampleLedgerBlock proof tx, -- (mkAlonzoTx tx),
       sleHashHeader = exampleHashHeader proof,
-      sleTx = mkAlonzoTx tx,
+      sleTx = tx,
       sleApplyTxError =
         ApplyTxError
           [ case proof of
@@ -152,14 +163,15 @@ defaultLedgerExamples proof mkWitnesses mkAlonzoTx value txBody auxData translat
       sleResultExamples = resultExamples,
       sleNewEpochState =
         exampleNewEpochState
+          proof
           value
-          emptyPParams
-          (emptyPParams {_minUTxOValue = Coin 1}),
+          undefined -- (emptyPP proof)
+          undefined, -- ((emptyPP proof) {_minUTxOValue = Coin 1}),
       sleChainDepState = exampleLedgerChainDepState 1,
       sleTranslationContext = translationContext
     }
   where
-    tx = exampleTx mkWitnesses txBody auxData
+    tx = exampleTx proof mkWitnesses txBody auxData
 
     resultExamples =
       ResultExamples
@@ -313,15 +325,179 @@ exampleProposedPParamsUpdates proof@(Conway _) =
       ((emptyPPUpdate proof) {ConwayPP._maxBHSize = SJust 4000})      
 
 
--- ==========================================
+exampleNonMyopicRewards ::
+  forall c.
+  CC.Crypto c =>
+  Map
+    (Either Coin (Credential 'Staking c))
+    (Map (KeyHash 'StakePool c) Coin)
+exampleNonMyopicRewards =
+  Map.fromList
+    [ (Left (Coin 100), Map.singleton (mkKeyHash 2) (Coin 3)),
+      (Right (ScriptHashObj (mkScriptHash 1)), Map.empty),
+      (Right (KeyHashObj (mkKeyHash 2)), Map.singleton (mkKeyHash 3) (Coin 9))
+    ]
+
+-- =====================================================================
+-- | The EpochState has a field which is (PParams era). We need these
+--     fields, a subset of the fields in PParams, in: startStep and createRUpd.
+type UsesPP era =
+  ( HasField "_d" (Core.PParams era) UnitInterval,
+    HasField "_tau" (Core.PParams era) UnitInterval,
+    HasField "_a0" (Core.PParams era) NonNegativeInterval,
+    HasField "_rho" (Core.PParams era) UnitInterval,
+    HasField "_nOpt" (Core.PParams era) Natural,
+    HasField "_protocolVersion" (Core.PParams era) ProtVer
+  )
+
+-- | This is probably not a valid ledger. We don't care, we are only
+-- interested in serialisation, not validation.
+exampleNewEpochState ::
+  forall era.
+  ( Reflect era,
+    Default (StashedAVVMAddresses era),
+    Default (State (Core.EraRule "PPUP" era)),
+    Core.EraTxOut era
+  ) =>
+  Proof era ->
+  Core.Value era ->
+  Core.PParams era ->
+  Core.PParams era ->
+  NewEpochState era
+exampleNewEpochState proof value ppp pp =
+  NewEpochState
+    { nesEL = EpochNo 0,
+      nesBprev = BlocksMade (Map.singleton (mkKeyHash 1) 10),
+      nesBcur = BlocksMade (Map.singleton (mkKeyHash 2) 3),
+      nesEs = epochState,
+      nesRu = SJust rewardUpdate,
+      nesPd = examplePoolDistr,
+      stashedAVVMAddresses = def
+    }
+  where
+    epochState :: EpochState era
+    epochState =
+      EpochState
+        { esAccountState =
+            AccountState
+              { _treasury = Coin 10000,
+                _reserves = Coin 1000
+              },
+          esSnapshots = emptySnapShots,
+          esLState =
+            LedgerState
+              { lsUTxOState =
+                  UTxOState
+                    { _utxo =
+                        UTxO $
+                          Map.fromList
+                            [ ( TxIn (TxId (mkDummySafeHash Proxy 1)) minBound,
+                                Core.mkBasicTxOut addr value
+                              )
+                            ],
+                      _deposited = Coin 1000,
+                      _fees = Coin 1,
+                      _ppups = def,
+                      _stakeDistro = mempty
+                    },
+                lsDPState = def
+              },
+          esPrevPp = ppp,
+          esPp = pp,
+          esNonMyopic = def
+        }
+      where
+        addr :: Addr (Cardano.Ledger.Era.Crypto era)
+        addr =
+          Addr
+            Testnet
+            (keyToCredential examplePayKey)
+            (StakeRefBase (keyToCredential exampleStakeKey))
+
+    rewardUpdate :: PulsingRewUpdate (Era.Crypto era)
+    rewardUpdate = case proof of
+       Shelley _ -> step
+       Allegra _ -> step
+       Mary _ -> step
+       Alonzo _ -> step
+       Babbage _ -> step
+       Conway _ -> step
+    step :: UsesPP era =>  PulsingRewUpdate (Era.Crypto era)
+    step = (startStep @era
+         (EpochSize 432000)
+         (BlocksMade (Map.singleton (mkKeyHash 1) 10))
+         epochState
+         (Coin 45)
+         (activeSlotCoeff testGlobals)
+         10)
+
+keyToCredential :: CC.Crypto c => KeyPair r c -> Credential r c
+keyToCredential = KeyHashObj . hashKey . vKey
+
+examplePayKey :: CC.Crypto c => KeyPair 'Payment c
+examplePayKey = mkDSIGNKeyPair 0
+
+exampleStakeKey :: CC.Crypto c => KeyPair 'Staking c
+exampleStakeKey = mkDSIGNKeyPair 1
+
+examplePoolDistr :: forall c. PraosCrypto c => PoolDistr c
+examplePoolDistr =
+  PoolDistr $
+    Map.fromList
+      [ ( mkKeyHash 1,
+          IndividualPoolStake
+            1
+            (hashVerKeyVRF (snd (vrf (exampleKeys @c))))
+        )
+      ]
+
+
+exampleLedgerChainDepState :: forall c. CC.Crypto c => Word64 -> ChainDepState c
+exampleLedgerChainDepState seed =
+  ChainDepState
+    { csProtocol =
+        PrtclState
+          ( Map.fromList
+              [ (mkKeyHash 1, 1),
+                (mkKeyHash 2, 2)
+              ]
+          )
+          (mkNonceFromNumber seed)
+          (mkNonceFromNumber seed),
+      csTickn =
+        TicknState
+          NeutralNonce
+          (mkNonceFromNumber seed),
+      csLabNonce =
+        mkNonceFromNumber seed
+    }
 
+-- | This is not a valid transaction. We don't care, we are only interested in
+-- serialisation, not validation.
+exampleTx ::
+  forall era.
+  ( Reflect era,
+    Core.EraTx era
+  ) =>
+  Proof era -> 
+  (Core.TxBody era -> KeyPairWits era -> Core.Witnesses era) ->
+  Core.TxBody era ->
+  Core.AuxiliaryData era ->
+  Core.Tx era
+exampleTx proof mkWitnesses txBody auxData =
+  -- ShelleyTx txBody (mkWitnesses txBody keyPairWits) (SJust auxData)
+  Core.mkBasicTx txBody
+  where
+    keyPairWits :: KeyPairWits era
+    keyPairWits =
+      [ asWitness examplePayKey,
+        asWitness exampleStakeKey,
+        asWitness $ cold (exampleKeys @(Cardano.Ledger.Era.Crypto era) @'StakePool)
+      ]
+
+-- ==========================================
 
-exampleNonMyopicRewards = undefined
-exampleNewEpochState = undefined
 
-exampleLedgerChainDepState = undefined
-exampleTx = undefined
-examplePoolDistr = undefined
 testShelleyGenesis = undefined
 
 

libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Proof.hs

@@ -74,6 +74,7 @@ import qualified Cardano.Ledger.BaseTypes as Base(Seed)
 import Cardano.Crypto.VRF as VRF
 import Cardano.Protocol.TPraos.BHeader (BHBody)
 import Cardano.Crypto.KES.Class(ContextKES)
+import Cardano.Protocol.TPraos.API(PraosCrypto)
 
 -- =================================================
 -- GADTs for witnessing Crypto and Era
@@ -127,7 +128,8 @@ type GoodCrypto crypto =
     KES.Signable (KES crypto) (BHBody crypto),
     ContextKES (KES crypto) ~ (),
     ContextVRF (VRF crypto) ~ (),
-    CH.HashAlgorithm (CC.HASH crypto)
+    CH.HashAlgorithm (CC.HASH crypto),
+    PraosCrypto crypto
   )
 
 class (GoodCrypto c) => ReflectC c where