Block.hs: remove ViewPattern and PatternSynonym

IntersectMBO · Jan 16, 2025 · c72b2c0 · c72b2c0
1 parent cd45792
commit c72b2c0
Show file tree

Hide file tree

Showing 4 changed files with 14 additions and 23 deletions.
diff --git a/cardano-api/internal/Cardano/Api/Block.hs b/cardano-api/internal/Cardano/Api/Block.hs
@@ -4,21 +4,19 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE ViewPatterns #-}
 
 -- | Blocks in the blockchain
 module Cardano.Api.Block
   ( -- * Blocks in the context of an era
     Block (..)
-  , pattern Block
   , BlockHeader (..)
   , getBlockHeader
+  , getBlockTxs
 
     -- ** Blocks in the context of a consensus mode
   , BlockInMode (..)
@@ -98,15 +96,6 @@ data Block era where
     -> Consensus.ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
     -> Block era
 
--- | A block consists of a header and a body containing transactions.
-pattern Block :: BlockHeader -> [Tx era] -> Block era
-pattern Block header txs <- (getBlockHeaderAndTxs -> (header, txs))
-
-{-# COMPLETE Block #-}
-
-getBlockHeaderAndTxs :: Block era -> (BlockHeader, [Tx era])
-getBlockHeaderAndTxs block = (getBlockHeader block, getBlockTxs block)
-
 -- The GADT in the ShelleyBlock case requires a custom instance
 instance Show (Block era) where
   showsPrec p (ByronBlock block) =

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/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs
@@ -267,7 +267,6 @@ module Cardano.Api
 
     -- ** Blocks in the context of an era
   , Block (..)
-  , pattern Block
   , BlockHeader (..)
   , getBlockHeader
 

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'