Merge pull request #728 from IntersectMBO/smelc/remove-patterns

Deprecate some patterns, remove their internal use

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))
 

cardano-api/internal/Cardano/Api/Governance/Poll.hs

@@ -7,7 +7,6 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ViewPatterns #-}
 
 -- | An API for driving on-chain poll for SPOs.
 --
@@ -341,12 +340,13 @@ verifyPollAnswer
   :: GovernancePoll
   -> InAnyShelleyBasedEra Tx
   -> Either GovernancePollError [Hash PaymentKey]
-verifyPollAnswer poll (InAnyShelleyBasedEra _era (getTxBody -> TxBody body)) = do
+verifyPollAnswer poll (InAnyShelleyBasedEra _era tx) = do
   answer <- extractPollAnswer (txMetadata body)
   answer `hasMatchingHash` hashGovernancePoll poll
   answer `isAmongAcceptableChoices` govPollAnswers poll
   extraKeyWitnesses (txExtraKeyWits body)
  where
+  body = getTxBodyContent $ getTxBody tx
   extractPollAnswer = \case
     TxMetadataNone ->
       Left ErrGovernancePollNoAnswer

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

cardano-api/internal/Cardano/Api/Tx/Body.hs

@@ -2147,6 +2147,7 @@ createAndValidateTransactionBody
   -> Either TxBodyError (TxBody era)
 createAndValidateTransactionBody = makeShelleyTransactionBody
 
+{-# DEPRECATED TxBody "Use getTxBodyContent $ getTxBody instead" #-}
 pattern TxBody :: TxBodyContent ViewTx era -> TxBody era
 pattern TxBody txbodycontent <- (getTxBodyContent -> txbodycontent)
 

cardano-api/internal/Cardano/Api/Tx/Sign.hs

@@ -52,8 +52,6 @@ module Cardano.Api.Tx.Sign
     -- * Data family instances
   , AsType
     ( AsTx
-    , AsByronTx
-    , AsShelleyTx
     , AsMaryTx
     , AsAllegraTx
     , AsAlonzoTx
@@ -185,18 +183,6 @@ instance HasTypeProxy era => HasTypeProxy (Tx era) where
   data AsType (Tx era) = AsTx (AsType era)
   proxyToAsType _ = AsTx (proxyToAsType (Proxy :: Proxy era))
 
-{-# DEPRECATED AsByronTx "Use AsTx AsByronEra instead." #-}
-pattern AsByronTx :: AsType (Tx ByronEra)
-pattern AsByronTx = AsTx AsByronEra
-
-{-# COMPLETE AsByronTx #-}
-
-{-# DEPRECATED AsShelleyTx "Use AsTx AsShelleyEra instead." #-}
-pattern AsShelleyTx :: AsType (Tx ShelleyEra)
-pattern AsShelleyTx = AsTx AsShelleyEra
-
-{-# COMPLETE AsShelleyTx #-}
-
 pattern AsMaryTx :: AsType (Tx MaryEra)
 pattern AsMaryTx = AsTx AsMaryEra
 

cardano-api/internal/Cardano/Api/TxMetadata.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ViewPatterns #-}
 
 -- | Metadata embedded in transactions
 module Cardano.Api.TxMetadata
@@ -461,12 +460,14 @@ metadataFromJson schema =
     return (k', v')
 
   convTopLevelKey :: Aeson.Key -> Either TxMetadataJsonError Word64
-  convTopLevelKey (Aeson.toText -> k) =
+  convTopLevelKey key =
     case parseAll (pUnsigned <* Atto.endOfInput) k of
       Just n
         | n <= fromIntegral (maxBound :: Word64) ->
             Right (fromIntegral n)
       _ -> Left (TxMetadataJsonToplevelBadKey k)
+   where
+    k = Aeson.toText key
 
   validateMetadataValue :: TxMetadataValue -> Either TxMetadataRangeError ()
   validateMetadataValue v =

cardano-api/internal/Cardano/Api/Value.hs

@@ -5,7 +5,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ViewPatterns #-}
 
 -- | Currency values
 module Cardano.Api.Value
@@ -387,13 +386,15 @@ instance FromJSON ValueNestedRep where
    where
     parsePid :: (Aeson.Key, Aeson.Value) -> Parser ValueNestedBundle
     parsePid ("lovelace", q) = ValueNestedBundleAda <$> parseJSON q
-    parsePid (Aeson.toText -> pid, quantityBundleJson) = do
+    parsePid (key, quantityBundleJson) = do
       sHash <-
         failEitherWith
           (\e -> "Failure when deserialising PolicyId: " ++ displayError e)
           $ deserialiseFromRawBytesHex AsScriptHash
           $ Text.encodeUtf8 pid
       ValueNestedBundle (PolicyId sHash) <$> parseJSON quantityBundleJson
+     where
+      pid = Aeson.toText key
 
 -- ----------------------------------------------------------------------------
 -- Printing and pretty-printing

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'