Merge pull request #342 from input-output-hk/newhoggy/delete-Consensu…

…sMode-type

Delete `ConsensusMode` type

cardano-api/cardano-api.cabal

@@ -29,6 +29,9 @@ common project-config
                         -Wredundant-constraints
                         -Wunused-packages
 
+  if impl(ghc < 9)
+    ghc-options:        -Wno-incomplete-patterns
+
 common maybe-unix
   if !os(windows)
      build-depends:    unix

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

@@ -33,8 +33,6 @@ module Cardano.Api.Block (
     toConsensusPoint,
     fromConsensusPoint,
     fromConsensusPointHF,
-    toConsensusPointInMode,
-    fromConsensusPointInMode,
     toConsensusPointHF,
 
     -- * Tip of the chain
@@ -66,21 +64,17 @@ import qualified Cardano.Chain.Block as Byron
 import qualified Cardano.Chain.UTxO as Byron
 import qualified Cardano.Crypto.Hash.Class as Crypto
 import qualified Cardano.Crypto.Hashing
+import qualified Cardano.Ledger.Api as L
 import qualified Cardano.Ledger.Block as Ledger
 import qualified Cardano.Ledger.Era as Ledger
 import           Cardano.Slotting.Block (BlockNo)
 import           Cardano.Slotting.Slot (EpochNo, SlotNo, WithOrigin (..))
 import qualified Ouroboros.Consensus.Block as Consensus
 import qualified Ouroboros.Consensus.Byron.Ledger as Consensus
 import qualified Ouroboros.Consensus.Cardano.Block as Consensus
-import qualified Ouroboros.Consensus.Cardano.ByronHFC as Consensus
 import qualified Ouroboros.Consensus.HardFork.Combinator as Consensus
-import qualified Ouroboros.Consensus.HardFork.Combinator.Degenerate as Consensus
-import qualified Ouroboros.Consensus.Ledger.SupportsProtocol as Consensus
-import qualified Ouroboros.Consensus.Protocol.TPraos as Consensus
 import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus
 import qualified Ouroboros.Consensus.Shelley.Protocol.Abstract as Consensus
-import qualified Ouroboros.Consensus.Shelley.ShelleyHFC as Consensus
 import qualified Ouroboros.Network.Block as Consensus
 
 import           Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object, withObject, (.:), (.=))
@@ -194,89 +188,41 @@ getShelleyBlockTxs era (Ledger.Block _header txs) =
 -- Block in a consensus mode
 --
 
--- | A 'Block' in one of the eras supported by a given protocol mode.
---
--- For multi-era modes such as the 'CardanoMode' this type is a sum of the
--- different block types for all the eras. It is used in the ChainSync protocol.
---
-data BlockInMode mode where
+-- | A 'Block' in one of the eras.
+-- TODO Rename this to BlockInEra
+data BlockInMode where
   BlockInMode
     :: CardanoEra era
     -> Block era
-    -> EraInMode era mode
-    -> BlockInMode mode
-
-deriving instance Show (BlockInMode mode)
-
-fromConsensusBlock :: ConsensusBlockForMode mode ~ block
-                   => Consensus.LedgerSupportsProtocol
-                        (Consensus.ShelleyBlock
-                        (Consensus.TPraos Consensus.StandardCrypto)
-                        (Consensus.ShelleyEra Consensus.StandardCrypto))
-                   => ConsensusMode mode -> block -> BlockInMode mode
-fromConsensusBlock ByronMode =
-    \b -> case b of
-      Consensus.DegenBlock b' ->
-        BlockInMode cardanoEra (ByronBlock b') ByronEraInByronMode
-
-fromConsensusBlock ShelleyMode =
-  \b -> case b of
-    Consensus.DegenBlock b' ->
-      BlockInMode cardanoEra (ShelleyBlock ShelleyBasedEraShelley b')
-                   ShelleyEraInShelleyMode
-
-fromConsensusBlock CardanoMode =
-    \b -> case b of
-      Consensus.BlockByron b' ->
-        BlockInMode cardanoEra (ByronBlock b') ByronEraInCardanoMode
-
-      Consensus.BlockShelley b' ->
-        BlockInMode cardanoEra (ShelleyBlock ShelleyBasedEraShelley b')
-                     ShelleyEraInCardanoMode
-
-      Consensus.BlockAllegra b' ->
-        BlockInMode cardanoEra (ShelleyBlock ShelleyBasedEraAllegra b')
-                     AllegraEraInCardanoMode
-
-      Consensus.BlockMary b' ->
-        BlockInMode cardanoEra (ShelleyBlock ShelleyBasedEraMary b')
-                     MaryEraInCardanoMode
-
-      Consensus.BlockAlonzo b' ->
-        BlockInMode cardanoEra (ShelleyBlock ShelleyBasedEraAlonzo b')
-                     AlonzoEraInCardanoMode
-
-      Consensus.BlockBabbage b' ->
-        BlockInMode cardanoEra (ShelleyBlock ShelleyBasedEraBabbage b')
-                     BabbageEraInCardanoMode
-
-      Consensus.BlockConway b' ->
-        BlockInMode cardanoEra (ShelleyBlock ShelleyBasedEraConway b')
-                     ConwayEraInCardanoMode
-
-toConsensusBlock
-  :: ConsensusBlockForMode mode ~ block
-  => Consensus.LedgerSupportsProtocol
-       (Consensus.ShelleyBlock
-       (Consensus.TPraos Consensus.StandardCrypto)
-       (Consensus.ShelleyEra Consensus.StandardCrypto))
-  => BlockInMode mode -> block
-toConsensusBlock bInMode =
-  case bInMode of
-    -- Byron mode
-    BlockInMode _ (ByronBlock b') ByronEraInByronMode -> Consensus.DegenBlock b'
-
-    -- Shelley mode
-    BlockInMode _ (ShelleyBlock ShelleyBasedEraShelley b') ShelleyEraInShelleyMode -> Consensus.DegenBlock b'
-
-    -- Cardano mode
-    BlockInMode _ (ByronBlock b') ByronEraInCardanoMode -> Consensus.BlockByron b'
-    BlockInMode _ (ShelleyBlock ShelleyBasedEraShelley b') ShelleyEraInCardanoMode -> Consensus.BlockShelley b'
-    BlockInMode _ (ShelleyBlock ShelleyBasedEraAllegra b') AllegraEraInCardanoMode -> Consensus.BlockAllegra b'
-    BlockInMode _ (ShelleyBlock ShelleyBasedEraMary b') MaryEraInCardanoMode -> Consensus.BlockMary b'
-    BlockInMode _ (ShelleyBlock ShelleyBasedEraAlonzo b') AlonzoEraInCardanoMode -> Consensus.BlockAlonzo b'
-    BlockInMode _ (ShelleyBlock ShelleyBasedEraBabbage b') BabbageEraInCardanoMode -> Consensus.BlockBabbage b'
-    BlockInMode _ (ShelleyBlock ShelleyBasedEraConway b') ConwayEraInCardanoMode -> Consensus.BlockConway b'
+    -> BlockInMode
+
+deriving instance Show BlockInMode
+
+fromConsensusBlock :: ()
+  => Consensus.CardanoBlock L.StandardCrypto ~ block
+  => block
+  -> BlockInMode
+fromConsensusBlock = \case
+  Consensus.BlockByron    b' -> BlockInMode cardanoEra $ ByronBlock b'
+  Consensus.BlockShelley  b' -> BlockInMode cardanoEra $ ShelleyBlock ShelleyBasedEraShelley b'
+  Consensus.BlockAllegra  b' -> BlockInMode cardanoEra $ ShelleyBlock ShelleyBasedEraAllegra b'
+  Consensus.BlockMary     b' -> BlockInMode cardanoEra $ ShelleyBlock ShelleyBasedEraMary b'
+  Consensus.BlockAlonzo   b' -> BlockInMode cardanoEra $ ShelleyBlock ShelleyBasedEraAlonzo b'
+  Consensus.BlockBabbage  b' -> BlockInMode cardanoEra $ ShelleyBlock ShelleyBasedEraBabbage b'
+  Consensus.BlockConway   b' -> BlockInMode cardanoEra $ ShelleyBlock ShelleyBasedEraConway b'
+
+toConsensusBlock :: ()
+  => Consensus.CardanoBlock L.StandardCrypto ~ block
+  => BlockInMode
+  -> block
+toConsensusBlock = \case
+  BlockInMode _ (ByronBlock                           b') -> Consensus.BlockByron b'
+  BlockInMode _ (ShelleyBlock ShelleyBasedEraShelley  b') -> Consensus.BlockShelley b'
+  BlockInMode _ (ShelleyBlock ShelleyBasedEraAllegra  b') -> Consensus.BlockAllegra b'
+  BlockInMode _ (ShelleyBlock ShelleyBasedEraMary     b') -> Consensus.BlockMary b'
+  BlockInMode _ (ShelleyBlock ShelleyBasedEraAlonzo   b') -> Consensus.BlockAlonzo b'
+  BlockInMode _ (ShelleyBlock ShelleyBasedEraBabbage  b') -> Consensus.BlockBabbage b'
+  BlockInMode _ (ShelleyBlock ShelleyBasedEraConway   b') -> Consensus.BlockConway b'
 
 -- ----------------------------------------------------------------------------
 -- Block headers
@@ -365,24 +311,6 @@ instance FromJSON ChainPoint where
       "ChainPoint" -> ChainPoint <$> o .: "slot" <*> o .: "blockHash"
       _ -> fail "Expected tag to be ChainPointAtGenesis | ChainPoint"
 
-toConsensusPointInMode :: ConsensusMode mode
-                       -> ChainPoint
-                       -> Consensus.Point (ConsensusBlockForMode mode)
--- It's the same concrete impl in all cases, but we have to show
--- individually for each case that we satisfy the type equality constraint
--- HeaderHash block ~ OneEraHash xs
-toConsensusPointInMode ByronMode   = toConsensusPointHF
-toConsensusPointInMode ShelleyMode = toConsensusPointHF
-toConsensusPointInMode CardanoMode = toConsensusPointHF
-
-fromConsensusPointInMode :: ConsensusMode mode
-                         -> Consensus.Point (ConsensusBlockForMode mode)
-                         -> ChainPoint
-fromConsensusPointInMode ByronMode   = fromConsensusPointHF
-fromConsensusPointInMode ShelleyMode = fromConsensusPointHF
-fromConsensusPointInMode CardanoMode = fromConsensusPointHF
-
-
 -- | Convert a 'Consensus.Point' for multi-era block type
 --
 toConsensusPointHF :: Consensus.HeaderHash block ~ Consensus.OneEraHash xs
@@ -466,49 +394,14 @@ makeChainTip woBlockNo chainPoint = case woBlockNo of
     ChainPointAtGenesis -> ChainTipAtGenesis
     ChainPoint slotNo headerHash -> ChainTip slotNo headerHash blockNo
 
-fromConsensusTip  :: ConsensusBlockForMode mode ~ block
-                  => ConsensusMode mode
-                  -> Consensus.Tip block
-                  -> ChainTip
-fromConsensusTip ByronMode = conv
-  where
-    conv :: Consensus.Tip Consensus.ByronBlockHFC -> ChainTip
-    conv Consensus.TipGenesis = ChainTipAtGenesis
-    conv (Consensus.Tip slot (Consensus.OneEraHash h) block) =
-      ChainTip slot (HeaderHash h) block
-
-fromConsensusTip ShelleyMode = conv
-  where
-    conv :: Consensus.Tip (Consensus.ShelleyBlockHFC (Consensus.TPraos Consensus.StandardCrypto) Consensus.StandardShelley)
-         -> ChainTip
-    conv Consensus.TipGenesis = ChainTipAtGenesis
-    conv (Consensus.Tip slot (Consensus.OneEraHash hashSBS) block) =
-      ChainTip slot (HeaderHash hashSBS) block
-
-fromConsensusTip CardanoMode = conv
+fromConsensusTip :: ()
+  => Consensus.CardanoBlock L.StandardCrypto ~ block
+  => Consensus.Tip block
+  -> ChainTip
+fromConsensusTip = conv
   where
     conv :: Consensus.Tip (Consensus.CardanoBlock Consensus.StandardCrypto)
          -> ChainTip
     conv Consensus.TipGenesis = ChainTipAtGenesis
     conv (Consensus.Tip slot (Consensus.OneEraHash h) block) =
       ChainTip slot (HeaderHash h) block
-
-{-
-TODO: In principle we should be able to use this common implementation rather
-      than repeating it for each mode above. It does actually type-check. The
-      problem is that (at least with ghc-8.10.x) ghc's pattern match warning
-      mechanism cannot see that the OneEraHash is a complete pattern match.
-      I'm guessing that while the type checker can use the type equality to
-      see that OneEraHash is a valid pattern, the exhaustiveness checker is for
-      some reason not able to use it to see that it is indeed the only pattern.
-fromConsensusTip =
-    \mode -> case mode of
-      ByronMode   -> conv
-      ShelleyMode -> conv
-      CardanoMode -> conv
-  where
-    conv :: HeaderHash block ~ OneEraHash xs
-         => Tip block -> ChainTip
-    conv TipGenesis                      = ChainTipAtGenesis
-    conv (Tip slot (OneEraHash h) block) = ChainTip slot (HeaderHash h) block
--}

cardano-api/internal/Cardano/Api/Convenience/Query.hs

@@ -24,7 +24,6 @@ import           Cardano.Api.Eras
 import           Cardano.Api.IO
 import           Cardano.Api.IPC
 import           Cardano.Api.IPC.Monad
-import           Cardano.Api.Modes
 import           Cardano.Api.NetworkId
 import           Cardano.Api.ProtocolParameters
 import           Cardano.Api.Query
@@ -54,7 +53,6 @@ data QueryConvenienceError
   = AcqFailure AcquiringFailure
   | QueryEraMismatch EraMismatch
   | ByronEraNotSupported
-  | EraConsensusModeMismatch !AnyConsensusMode !AnyCardanoEra
   | QceUnsupportedNtcVersion !UnsupportedNtcVersionError
   deriving Show
 
@@ -67,9 +65,6 @@ renderQueryConvenienceError (QueryEraMismatch (EraMismatch ledgerEraName' otherE
   " era, but the transaction is for the " <> otherEraName' <> " era."
 renderQueryConvenienceError ByronEraNotSupported =
   "Byron era not supported"
-renderQueryConvenienceError (EraConsensusModeMismatch cMode anyCEra) =
-  "Consensus mode and era mismatch. Consensus mode: " <> textShow cMode <>
-  " Era: " <> textShow anyCEra
 renderQueryConvenienceError (QceUnsupportedNtcVersion (UnsupportedNtcVersionError minNtcVersion ntcVersion)) =
   "Unsupported feature for the node-to-client protocol version.\n" <>
   "This query requires at least " <> textShow minNtcVersion <> " but the node negotiated " <> textShow ntcVersion <> ".\n" <>
@@ -81,12 +76,12 @@ queryStateForBalancedTx :: ()
   => CardanoEra era
   -> [TxIn]
   -> [Certificate era]
-  -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO
+  -> LocalStateQueryExpr block point QueryInMode r IO
       ( Either
           QueryConvenienceError
           ( UTxO era
           , LedgerProtocolParameters era
-          , EraHistory CardanoMode
+          , EraHistory
           , SystemStart
           , Set PoolId
           , Map StakeCredential Lovelace
@@ -95,18 +90,15 @@ queryStateForBalancedTx era allTxIns certs = runExceptT $ do
   sbe <- requireShelleyBasedEra era
     & onNothing (left ByronEraNotSupported)
 
-  qeInMode <- pure (toEraInMode era CardanoMode)
-    & onNothing (left (EraConsensusModeMismatch (AnyConsensusMode CardanoMode) (anyCardanoEra era)))
-
   let stakeCreds = Set.fromList $ mapMaybe filterUnRegCreds certs
       drepCreds  = Set.fromList $ mapMaybe filterUnRegDRepCreds certs
 
   -- Query execution
-  utxo <- lift (queryUtxo qeInMode sbe (QueryUTxOByTxIn (Set.fromList allTxIns)))
+  utxo <- lift (queryUtxo sbe (QueryUTxOByTxIn (Set.fromList allTxIns)))
     & onLeft (left . QceUnsupportedNtcVersion)
     & onLeft (left . QueryEraMismatch)
 
-  pparams <- lift (queryProtocolParameters qeInMode sbe)
+  pparams <- lift (queryProtocolParameters sbe)
     & onLeft (left . QceUnsupportedNtcVersion)
     & onLeft (left . QueryEraMismatch)
 
@@ -116,70 +108,54 @@ queryStateForBalancedTx era allTxIns certs = runExceptT $ do
   systemStart <- lift querySystemStart
     & onLeft (left . QceUnsupportedNtcVersion)
 
-  stakePools <- lift (queryStakePools qeInMode sbe)
+  stakePools <- lift (queryStakePools sbe)
     & onLeft (left . QceUnsupportedNtcVersion)
     & onLeft (left . QueryEraMismatch)
 
   stakeDelegDeposits <-
-    lift (queryStakeDelegDeposits qeInMode sbe stakeCreds)
+    lift (queryStakeDelegDeposits sbe stakeCreds)
       & onLeft (left . QceUnsupportedNtcVersion)
       & onLeft (left . QueryEraMismatch)
 
   drepDelegDeposits <-
     forEraInEon @ConwayEraOnwards era (pure mempty) $ \_ ->
       Map.map (fromShelleyLovelace . drepDeposit) <$>
-      (lift (queryDRepState qeInMode sbe drepCreds)
+      (lift (queryDRepState sbe drepCreds)
           & onLeft (left . QceUnsupportedNtcVersion)
           & onLeft (left . QueryEraMismatch))
 
   pure (utxo, LedgerProtocolParameters pparams, eraHistory, systemStart, stakePools, stakeDelegDeposits, drepDelegDeposits)
 
 -- | Query the node to determine which era it is in.
-determineEra
-  :: ConsensusModeParams mode
-  -> LocalNodeConnectInfo mode
+determineEra :: ()
+  => LocalNodeConnectInfo
   -> IO (Either AcquiringFailure AnyCardanoEra)
-determineEra cModeParams localNodeConnInfo =
-  case consensusModeOnly cModeParams of
-    ByronMode -> return . Right $ AnyCardanoEra ByronEra
-    ShelleyMode -> return . Right $ AnyCardanoEra ShelleyEra
-    CardanoMode ->
-      queryNodeLocalState localNodeConnInfo Nothing
-        $ QueryCurrentEra CardanoModeIsMultiEra
+determineEra localNodeConnInfo =
+  queryNodeLocalState localNodeConnInfo Nothing QueryCurrentEra
 
 -- | Execute a query against the local node. The local
 -- node must be in CardanoMode.
-executeQueryCardanoMode
-  :: SocketPath
-  -> CardanoEra era
+executeQueryCardanoMode :: ()
+  => SocketPath
   -> NetworkId
-  -> QueryInMode CardanoMode (Either EraMismatch result)
+  -> QueryInMode (Either EraMismatch result)
   -> IO (Either QueryConvenienceError result)
-executeQueryCardanoMode socketPath era nid q = runExceptT $ do
+executeQueryCardanoMode socketPath nid q = runExceptT $ do
   let localNodeConnInfo =
         LocalNodeConnectInfo
           { localConsensusModeParams = CardanoModeParams (EpochSlots 21600)
           , localNodeNetworkId = nid
           , localNodeSocketPath = socketPath
           }
 
-  ExceptT $ executeQueryAnyMode era localNodeConnInfo q
+  ExceptT $ executeQueryAnyMode localNodeConnInfo q
 
 -- | Execute a query against the local node in any mode.
-executeQueryAnyMode
-  :: forall result era mode. CardanoEra era
-  -> LocalNodeConnectInfo mode
-  -> QueryInMode mode (Either EraMismatch result)
+executeQueryAnyMode :: forall result. ()
+  => LocalNodeConnectInfo
+  -> QueryInMode (Either EraMismatch result)
   -> IO (Either QueryConvenienceError result)
-executeQueryAnyMode era localNodeConnInfo q = runExceptT $ do
-  let cMode = consensusModeOnly $ localConsensusModeParams localNodeConnInfo
-
-  eraInMode <- pure (toEraInMode era cMode)
-    & onNothing (left $ EraConsensusModeMismatch (AnyConsensusMode CardanoMode) (anyCardanoEra era))
-
-  case eraInMode of
-    ByronEraInByronMode -> left ByronEraNotSupported
-    _ ->
-      lift (queryNodeLocalState localNodeConnInfo Nothing q)
-        & onLeft (left . AcqFailure)
-        & onLeft (left . QueryEraMismatch)
+executeQueryAnyMode localNodeConnInfo q = runExceptT $ do
+  lift (queryNodeLocalState localNodeConnInfo Nothing q)
+    & onLeft (left . AcqFailure)
+    & onLeft (left . QueryEraMismatch)