Block.hs: deprecate patterns and remove internal usage

IntersectMBO · Jan 20, 2025 · 7f8d417 · 7f8d417
1 parent 93da8ad
commit 7f8d417
Show file tree

Hide file tree

Showing 3 changed files with 15 additions and 10 deletions.
diff --git a/cardano-api/internal/Cardano/Api/Block.hs b/cardano-api/internal/Cardano/Api/Block.hs
@@ -19,6 +19,7 @@ module Cardano.Api.Block
   , pattern Block
   , BlockHeader (..)
   , getBlockHeader
+  , getBlockTxs
 
     -- ** Blocks in the context of a consensus mode
   , BlockInMode (..)
@@ -99,6 +100,7 @@ data Block era where
     -> Block era
 
 -- | A block consists of a header and a body containing transactions.
+{-# DEPRECATED Block "Use getBlockHeader instead " #-}
 pattern Block :: BlockHeader -> [Tx era] -> Block era
 pattern Block header txs <- (getBlockHeaderAndTxs -> (header, txs))
 

diff --git a/cardano-api/internal/Cardano/Api/LedgerState.hs b/cardano-api/internal/Cardano/Api/LedgerState.hs
@@ -540,7 +540,7 @@ foldBlocks nodeConfigFilePath socketPath validationMode state0 accumulate = hand
       -> CSP.ClientStNext n BlockInMode ChainPoint ChainTip IO ()
     clientNextN n knownLedgerStates =
       CSP.ClientStNext
-        { CSP.recvMsgRollForward = \blockInMode@(BlockInMode _ (Block (BlockHeader slotNo _ currBlockNo) _)) serverChainTip -> do
+        { CSP.recvMsgRollForward = \blockInMode@(BlockInMode _ block) serverChainTip -> do
             let newLedgerStateE =
                   applyBlock
                     env
@@ -554,7 +554,8 @@ foldBlocks nodeConfigFilePath socketPath validationMode state0 accumulate = hand
             case newLedgerStateE of
               Left err -> clientIdle_DoneNwithMaybeError n (Just err)
               Right newLedgerState -> do
-                let (knownLedgerStates', committedStates) = pushLedgerState env knownLedgerStates slotNo newLedgerState blockInMode
+                let BlockHeader slotNo _ currBlockNo = getBlockHeader block
+                    (knownLedgerStates', committedStates) = pushLedgerState env knownLedgerStates slotNo newLedgerState blockInMode
                     newClientTip = At currBlockNo
                     newServerTip = fromChainTip serverChainTip
 
@@ -729,9 +730,10 @@ chainSyncClientWithLedgerState env ledgerState0 validationMode (CS.ChainSyncClie
       )
   goClientStNext (Right history) (CS.ClientStNext recvMsgRollForward recvMsgRollBackward) =
     CS.ClientStNext
-      ( \blkInMode@(BlockInMode _ (Block (BlockHeader slotNo _ _) _)) tip ->
+      ( \blkInMode@(BlockInMode _ block) tip ->
           CS.ChainSyncClient $
             let
+              BlockHeader slotNo _ _ = getBlockHeader block
               newLedgerStateE = case Seq.lookup 0 history of
                 Nothing -> error "Impossible! History should always be non-empty"
                 Just (_, Left err, _) -> Left err
@@ -875,8 +877,9 @@ chainSyncClientPipelinedWithLedgerState env ledgerState0 validationMode (CSP.Cha
       )
   goClientStNext (Right history) n (CSP.ClientStNext recvMsgRollForward recvMsgRollBackward) =
     CSP.ClientStNext
-      ( \blkInMode@(BlockInMode _ (Block (BlockHeader slotNo _ _) _)) tip ->
+      ( \blkInMode@(BlockInMode _ block) tip ->
           let
+            BlockHeader slotNo _ _ = getBlockHeader block
             newLedgerStateE = case Seq.lookup 0 history of
               Nothing -> error "Impossible! History should always be non-empty"
               Just (_, Left err, _) -> Left err
@@ -2173,8 +2176,9 @@ foldEpochState nodeConfigFilePath socketPath validationMode terminationEpoch ini
       -> CSP.ClientStNext n BlockInMode ChainPoint ChainTip IO ()
     clientNextN n knownLedgerStates =
       CSP.ClientStNext
-        { CSP.recvMsgRollForward = \blockInMode@(BlockInMode era (Block (BlockHeader slotNo _ currBlockNo) _)) serverChainTip -> do
-            let newLedgerStateE =
+        { CSP.recvMsgRollForward = \blockInMode@(BlockInMode era block) serverChainTip -> do
+            let BlockHeader slotNo _ currBlockNo = getBlockHeader block
+                newLedgerStateE =
                   applyBlock
                     env
                     ( maybe

diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/TxBody.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/TxBody.hs
@@ -35,7 +35,7 @@ prop_roundtrip_txbodycontent_txouts era = H.property $ do
   (body, content :: TxBodyContent BuildTx era) <-
     shelleyBasedEraConstraints era $ H.forAll $ genValidTxBody era
   -- Convert ledger body back via 'getTxBodyContent' and 'fromLedgerTxBody'
-  let (TxBody content') = body
+  let content' = getTxBodyContent body
   matchTxOuts (txOuts content) (txOuts content')
  where
   matchTxOuts :: MonadTest m => [TxOut CtxTx era] -> [TxOut CtxTx era] -> m ()
@@ -84,9 +84,8 @@ prop_roundtrip_txbodycontent_conway_fields = H.property $ do
   let sbe = ShelleyBasedEraConway
   (body, content) <- H.forAll $ genValidTxBody sbe
   -- Convert ledger body back via 'getTxBodyContent' and 'fromLedgerTxBody'
-  let (TxBody content') = body
-
-  let proposals = getProposalProcedures . unFeatured <$> txProposalProcedures content
+  let content' = getTxBodyContent body
+      proposals = getProposalProcedures . unFeatured <$> txProposalProcedures content
       proposals' = getProposalProcedures . unFeatured <$> txProposalProcedures content'
       votes = getVotingProcedures . unFeatured <$> txVotingProcedures content
       votes' = getVotingProcedures . unFeatured <$> txVotingProcedures content'