EraBlockHeader: fix shelley-test and ledger-test

Author: aniketd

eras/shelley/test-suite/bench/BenchValidation.hs

@@ -8,7 +8,6 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
-{-# OPTIONS_GHC -Wno-unused-binds #-}
 
 module BenchValidation (
   ValidateInput (..),
@@ -23,7 +22,7 @@ module BenchValidation (
 ) where
 
 import Cardano.Ledger.BaseTypes (Globals (..), unBlocksMade)
-import Cardano.Ledger.Block (Block (..))
+import Cardano.Ledger.Block (Block (..), EraBlockHeader)
 import qualified Cardano.Ledger.Shelley.API as API
 import Cardano.Ledger.Shelley.Bench.Gen (genBlock, genChainState)
 import Cardano.Ledger.Shelley.BlockBody (slotToNonce)
@@ -44,7 +43,10 @@ import Cardano.Protocol.TPraos.API (
   tickChainDepState,
   updateChainDepState,
  )
-import Cardano.Protocol.TPraos.BHeader (BHeader (..), LastAppliedBlock (..), makeHeaderView)
+import Cardano.Protocol.TPraos.BHeader (
+  BHeader (..),
+  LastAppliedBlock (..),
+ )
 import Cardano.Protocol.TPraos.Rules.Prtcl (PrtclState (..))
 import Cardano.Protocol.TPraos.Rules.Tickn (TicknState (..))
 import Cardano.Slotting.Slot (withOriginToMaybe)
@@ -53,6 +55,7 @@ import Control.Monad.Except ()
 import Control.State.Transition
 import qualified Data.Map.Strict as Map
 import Data.Proxy
+import Test.Cardano.Ledger.BlockHeader (TestBlockHeader (..), mkTestBlockHeaderNoNonce)
 import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (MockCrypto)
 import Test.Cardano.Ledger.Shelley.Constants (defaultConstants)
 import Test.Cardano.Ledger.Shelley.Generator.Core (GenEnv)
@@ -76,9 +79,10 @@ validateInput ::
   , EraStake era
   , EraRule "LEDGERS" era ~ API.ShelleyLEDGERS era
   , QC.HasTrace (API.ShelleyLEDGERS era) (GenEnv MockCrypto era)
-  , API.ApplyBlock era
+  , API.ApplyBlock TestBlockHeader era
   , GetLedgerView era
   , MinLEDGER_STS era
+  , EraBlockHeader (BHeader MockCrypto) era
   ) =>
   Int ->
   IO (ValidateInput era)
@@ -89,39 +93,41 @@ validateInput n = do
   pure (ValidateInput testGlobals (chainNes chainstate) block)
 
 benchValidate ::
-  (API.ApplyBlock era, Show (PredicateFailure (EraRule "BBODY" era))) =>
+  ( API.ApplyBlock TestBlockHeader era
+  , Show (PredicateFailure (EraRule "BBODY" era))
+  , EraBlockHeader (BHeader MockCrypto) era
+  ) =>
   ValidateInput era ->
   IO (NewEpochState era)
-benchValidate (ValidateInput globals state (Block bh txs)) =
-  let block = Block (makeHeaderView bh Nothing) txs
-   in case API.applyBlockEitherNoEvents ValidateAll globals state block of
-        Right x -> pure x
-        Left x -> error (show x)
+benchValidate (ValidateInput globals state blk@(Block _ txs)) =
+  case API.applyBlockEitherNoEvents ValidateAll globals state (Block (mkTestBlockHeaderNoNonce blk) txs) of
+    Right x -> pure x
+    Left x -> error (show x)
 
 applyBlock ::
   forall era.
-  ( API.ApplyBlock era
+  ( API.ApplyBlock TestBlockHeader era
   , NFData (StashedAVVMAddresses era)
   , NFData (InstantStake era)
   , GovState era ~ ShelleyGovState era
   , EraCertState era
   , Show (PredicateFailure (EraRule "BBODY" era))
+  , EraBlockHeader (BHeader MockCrypto) era
   ) =>
   ValidateInput era ->
   Int ->
   Int
-applyBlock (ValidateInput globals state (Block bh txs)) n =
-  let block = Block (makeHeaderView bh Nothing) txs
-   in case API.applyBlockEitherNoEvents ValidateAll globals state block of
-        Right x -> seq (rnf x) (n + 1)
-        Left x -> error (show x)
+applyBlock (ValidateInput globals state blk@(Block _ txs)) n =
+  case API.applyBlockEitherNoEvents ValidateAll globals state (Block (mkTestBlockHeaderNoNonce blk) txs) of
+    Right x -> seq (rnf x) (n + 1)
+    Left x -> error (show x)
 
 benchreValidate ::
-  API.ApplyBlock era =>
+  (API.ApplyBlock TestBlockHeader era, EraBlockHeader (BHeader MockCrypto) era) =>
   ValidateInput era ->
   NewEpochState era
-benchreValidate (ValidateInput globals state (Block bh txs)) =
-  API.applyBlockNoValidaton globals state (Block (makeHeaderView bh Nothing) txs)
+benchreValidate (ValidateInput globals state blk@(Block _ txs)) =
+  API.applyBlockNoValidaton globals state (Block (mkTestBlockHeaderNoNonce blk) txs)
 
 -- ==============================================================
 
@@ -161,7 +167,8 @@ genUpdateInputs ::
   , GetLedgerView era
   , EraRule "LEDGERS" era ~ API.ShelleyLEDGERS era
   , QC.HasTrace (API.ShelleyLEDGERS era) (GenEnv MockCrypto era)
-  , API.ApplyBlock era
+  , API.ApplyBlock TestBlockHeader era
+  , EraBlockHeader (BHeader MockCrypto) era
   ) =>
   Int ->
   IO UpdateInputs

eras/shelley/test-suite/bench/Cardano/Ledger/Shelley/Bench/Gen.hs

@@ -10,6 +10,7 @@ module Cardano.Ledger.Shelley.Bench.Gen (
   genChainState,
 ) where
 
+import Cardano.Ledger.Block (EraBlockHeader)
 import Cardano.Ledger.Coin
 import Cardano.Ledger.Shelley.API (
   ApplyBlock,
@@ -29,6 +30,7 @@ import Control.State.Transition.Extended
 import Data.Either (fromRight)
 import qualified Data.Map.Strict as Map
 import Data.Proxy
+import Test.Cardano.Ledger.BlockHeader (TestBlockHeader)
 import Test.Cardano.Ledger.Shelley.BenchmarkFunctions (ledgerEnv)
 import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (MockCrypto)
 import Test.Cardano.Ledger.Shelley.Constants (
@@ -51,8 +53,6 @@ import Test.Cardano.Ledger.Shelley.Serialisation.Generators ()
 import qualified Test.Control.State.Transition.Trace.Generator.QuickCheck as QC
 import Test.QuickCheck (generate)
 
--- ===============================================================
-
 -- | Generate a genesis chain state given a UTxO size
 genChainState ::
   ( EraGen era
@@ -83,7 +83,8 @@ genBlock ::
   , GetLedgerView era
   , EraRule "LEDGERS" era ~ ShelleyLEDGERS era
   , QC.HasTrace (ShelleyLEDGERS era) (GenEnv MockCrypto era)
-  , ApplyBlock era
+  , ApplyBlock TestBlockHeader era
+  , EraBlockHeader (BHeader MockCrypto) era
   ) =>
   GenEnv MockCrypto era ->
   ChainState era ->

eras/shelley/test-suite/cardano-ledger-shelley-test.cabal

@@ -198,7 +198,7 @@ benchmark mainbench
     QuickCheck,
     base,
     cardano-data,
-    cardano-ledger-core,
+    cardano-ledger-core:{cardano-ledger-core, testlib},
     cardano-ledger-shelley:{cardano-ledger-shelley, testlib},
     cardano-ledger-shelley-test,
     cardano-protocol-tpraos,

eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Block.hs

@@ -14,8 +14,8 @@ module Test.Cardano.Ledger.Shelley.Generator.Block (
 ) where
 
 import qualified Cardano.Crypto.VRF as VRF
-import Cardano.Ledger.BHeaderView (bhviewBSize, bhviewHSize)
 import Cardano.Ledger.BaseTypes (UnitInterval)
+import Cardano.Ledger.Block (EraBlockHeader (..))
 import Cardano.Ledger.Shelley.API
 import Cardano.Ledger.Shelley.Core
 import Cardano.Ledger.Shelley.LedgerState (curPParamsEpochStateL, dsGenDelegsL)
@@ -26,7 +26,6 @@ import Cardano.Protocol.TPraos.BHeader (
   BHeader (..),
   LastAppliedBlock (..),
   hashHeaderToNonce,
-  makeHeaderView,
   mkSeed,
   seedL,
  )
@@ -36,6 +35,7 @@ import Cardano.Protocol.TPraos.Rules.Prtcl (PrtclState (..))
 import Cardano.Protocol.TPraos.Rules.Tickn (TicknState (..))
 import Cardano.Slotting.Slot (WithOrigin (..))
 import Control.Monad (unless)
+import Control.State.Transition.Extended (SingEP (EPDiscard))
 import Data.Coerce (coerce)
 import Data.Foldable (toList)
 import qualified Data.List as List (find)
@@ -46,6 +46,7 @@ import Data.Sequence (Seq)
 import qualified Data.Set as Set
 import Lens.Micro ((^.))
 import Lens.Micro.Extras (view)
+import Test.Cardano.Ledger.BlockHeader (TestBlockHeader)
 import Test.Cardano.Ledger.Common (tracedDiscard)
 import Test.Cardano.Ledger.Core.KeyPair (vKey)
 import Test.Cardano.Ledger.Shelley.Generator.Core (
@@ -86,11 +87,12 @@ type TxGen era =
 genBlock ::
   forall era c.
   ( MinLEDGER_STS era
-  , ApplyBlock era
+  , ApplyBlock TestBlockHeader era
   , GetLedgerView era
   , QC.HasTrace (EraRule "LEDGERS" era) (GenEnv c era)
   , EraGen era
   , PraosCrypto c
+  , EraBlockHeader (BHeader c) era
   ) =>
   GenEnv c era ->
   ChainState era ->
@@ -106,9 +108,10 @@ genBlock ge = genBlockWithTxGen genTxs ge
 genBlockWithTxGen ::
   forall era c.
   ( GetLedgerView era
-  , ApplyBlock era
+  , ApplyBlock TestBlockHeader era
   , EraGen era
   , PraosCrypto c
+  , EraBlockHeader (BHeader c) era
   ) =>
   TxGen era ->
   GenEnv c era ->
@@ -173,17 +176,18 @@ genBlockWithTxGen
         -- e.g. the KES period in which this key starts to be valid.
         <*> pure (fromIntegral (m * fromIntegral maxKESIterations))
         <*> pure oCert
-    let hView = makeHeaderView (blockHeader theBlock) Nothing
-    unless (bhviewBSize hView <= pp ^. ppMaxBBSizeL) $
+    let bSize = theBlock ^. blockHeaderBSizeL
+    unless (bSize <= pp ^. ppMaxBBSizeL) $
       tracedDiscard $
-        "genBlockWithTxGen: bhviewBSize too large"
-          <> show (bhviewBSize hView)
+        "genBlockWithTxGen: bsize too large"
+          <> show bSize
           <> " vs "
           <> show (pp ^. ppMaxBBSizeL)
-    unless (bhviewHSize hView <= fromIntegral (pp ^. ppMaxBHSizeL)) $
+    let hSize = theBlock ^. blockHeaderHSizeL
+    unless (hSize <= fromIntegral (pp ^. ppMaxBHSizeL)) $
       tracedDiscard $
-        "genBlockWithTxGen: bhviewHSize too large"
-          <> show (bhviewHSize hView)
+        "genBlockWithTxGen: header size too large"
+          <> show hSize
           <> " vs "
           <> show (pp ^. ppMaxBHSizeL)
     pure theBlock
@@ -198,7 +202,7 @@ selectNextSlotWithLeader ::
   forall era c.
   ( EraGen era
   , GetLedgerView era
-  , ApplyBlock era
+  , ApplyBlock TestBlockHeader era
   , PraosCrypto c
   ) =>
   GenEnv c era ->
@@ -274,7 +278,7 @@ selectNextSlotWithLeader
 -- | The chain state is a composite of the new epoch state and the chain dep
 -- state. We tick both.
 tickChainState ::
-  (GetLedgerView era, ApplyBlock era) =>
+  (GetLedgerView era, ApplyBlock TestBlockHeader era) =>
   SlotNo ->
   ChainState era ->
   ChainState era
@@ -302,7 +306,7 @@ tickChainState
         ChainDepState {csProtocol, csTickn} =
           tickChainDepState testGlobals lv isNewEpoch cds
         PrtclState ocertIssue evNonce candNonce = csProtocol
-        nes' = applyTickNoEvents testGlobals chainNes slotNo
+        nes' = fst $ applyTick @TestBlockHeader EPDiscard testGlobals chainNes slotNo
      in ChainState
           { chainNes = nes'
           , chainOCertIssue = ocertIssue

eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Trace/Chain.hs

@@ -3,7 +3,6 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
@@ -15,7 +14,7 @@
 
 module Test.Cardano.Ledger.Shelley.Generator.Trace.Chain where
 
-import Cardano.Ledger.BHeaderView (BHeaderView (..))
+import Cardano.Ledger.Block (BbodySignal, EraBlockHeader)
 import Cardano.Ledger.Shelley.API
 import Cardano.Ledger.Shelley.Core
 import Cardano.Ledger.Shelley.Rules (
@@ -36,6 +35,7 @@ import Cardano.Ledger.Slot (
 import Cardano.Ledger.Val ((<->))
 import Cardano.Protocol.TPraos.API
 import Cardano.Protocol.TPraos.BHeader (
+  BHeader,
   LastAppliedBlock (..),
   hashHeaderToNonce,
  )
@@ -51,6 +51,7 @@ import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import Data.Proxy (Proxy (..))
 import Numeric.Natural (Natural)
+import Test.Cardano.Ledger.BlockHeader (TestBlockHeader)
 import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (MockCrypto)
 import Test.Cardano.Ledger.Shelley.Generator.Block (genBlock)
 import Test.Cardano.Ledger.Shelley.Generator.Core (GenEnv (..))
@@ -85,14 +86,15 @@ import Test.QuickCheck (Gen)
 instance
   ( EraGen era
   , EraBlockBody era
-  , ApplyBlock era
+  , EraBlockHeader (BHeader MockCrypto) era
+  , ApplyBlock TestBlockHeader era
   , GetLedgerView era
   , MinLEDGER_STS era
   , MinCHAIN_STS era
   , Embed (EraRule "BBODY" era) (CHAIN era)
   , Environment (EraRule "BBODY" era) ~ BbodyEnv era
   , State (EraRule "BBODY" era) ~ ShelleyBbodyState era
-  , Signal (EraRule "BBODY" era) ~ Block BHeaderView era
+  , Signal (EraRule "BBODY" era) ~ BbodySignal era
   , Embed (EraRule "TICKN" era) (CHAIN era)
   , Environment (EraRule "TICKN" era) ~ TicknEnv
   , State (EraRule "TICKN" era) ~ TicknState
@@ -109,7 +111,7 @@ instance
 
   sigGen ge _env st = genBlock ge st
 
-  shrinkSignal = (\_x -> []) -- shrinkBlock -- TO DO FIX ME
+  shrinkSignal _x = [] -- shrinkBlock -- TO DO FIX ME
 
   type BaseEnv (CHAIN era) = Globals
   interpretSTS globals act = runIdentity $ runReaderT act globals

eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/PropertyTests.hs

@@ -12,9 +12,8 @@ module Test.Cardano.Ledger.Shelley.PropertyTests (
   commonTests,
 ) where
 
-import Cardano.Ledger.BHeaderView (BHeaderView)
 import Cardano.Ledger.BaseTypes (Globals, ShelleyBase, SlotNo)
-import Cardano.Ledger.Block (Block)
+import Cardano.Ledger.Block (BbodySignal, EraBlockHeader)
 import Cardano.Ledger.Core
 import Cardano.Ledger.Shelley.API (ApplyBlock, ShelleyPOOL)
 import Cardano.Ledger.Shelley.Core
@@ -29,9 +28,11 @@ import Cardano.Ledger.Shelley.Rules (
  )
 import Cardano.Ledger.Shelley.State
 import Cardano.Protocol.TPraos.API (GetLedgerView)
+import Cardano.Protocol.TPraos.BHeader (BHeader)
 import Cardano.Protocol.TPraos.Rules.Tickn (TicknEnv, TicknState)
 import Control.State.Transition
 import Data.Sequence (Seq)
+import Test.Cardano.Ledger.BlockHeader (TestBlockHeader)
 import qualified Test.Cardano.Ledger.Shelley.ByronTranslation as ByronTranslation (
   testGroupByronTranslation,
  )
@@ -66,7 +67,7 @@ commonTests ::
   ( EraGen era
   , EraStake era
   , ShelleyEraAccounts era
-  , ApplyBlock era
+  , ApplyBlock TestBlockHeader era
   , GetLedgerView era
   , Embed (EraRule "BBODY" era) (CHAIN era)
   , Embed (EraRule "TICK" era) (CHAIN era)
@@ -93,10 +94,11 @@ commonTests ::
   , State (EraRule "LEDGERS" era) ~ LedgerState era
   , Environment (EraRule "BBODY" era) ~ BbodyEnv era
   , Signal (EraRule "TICK" era) ~ SlotNo
-  , Signal (EraRule "BBODY" era) ~ Block BHeaderView era
+  , Signal (EraRule "BBODY" era) ~ BbodySignal era
   , EraRule "POOL" era ~ ShelleyPOOL era
   , InjectRuleFailure "POOL" ShelleyPoolPredFailure era
   , InjectRuleEvent "POOL" PoolEvent era
+  , EraBlockHeader (BHeader MockCrypto) era
   ) =>
   [TestTree]
 commonTests =