Pattern synonyms for degenerate

Closes #2407.

ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Degenerate.hs

@@ -3,32 +3,59 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ViewPatterns #-}
 
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Ouroboros.Consensus.HardFork.Combinator.Degenerate (
+ -- * Pattern synonyms
+ HardForkBlock (DegenBlock)
+ , Header (DegenHeader)
+ , GenTx (DegenGenTx)
+ , TxId (DegenGenTxId)
+ , HardForkApplyTxErr (DegenApplyTxErr)
+ , HardForkLedgerError (DegenLedgerError)
+ , HardForkEnvelopeErr (DegenOtherHeaderEnvelopeError)
+ , OneEraTipInfo (DegenTipInfo)
+ , Query (DegenQuery)
+ , Either (DegenQueryResult)
+ , CodecConfig (DegenCodecConfig)
+ , BlockConfig (DegenBlockConfig)
+ , ConsensusConfig (DegenConsensusConfig)
+ , HardForkLedgerConfig (DegenLedgerConfig)
+ , TopLevelConfig (DegenTopLevelConfig)
+ , LedgerState (DegenLedgerState)
  ) where
 
 import Control.Tracer
 import Data.SOP.Strict
 
 import Ouroboros.Consensus.Block.Abstract
+import Ouroboros.Consensus.Config
 import Ouroboros.Consensus.Config.SupportsNode
+import Ouroboros.Consensus.HeaderValidation
+import Ouroboros.Consensus.Ledger.Abstract
+import Ouroboros.Consensus.Ledger.SupportsMempool
 import Ouroboros.Consensus.Node.NetworkProtocolVersion
 import Ouroboros.Consensus.Node.Run
+import Ouroboros.Consensus.TypeFamilyWrappers
 
 import Ouroboros.Consensus.HardFork.Combinator.Abstract.NoHardForks
 import Ouroboros.Consensus.HardFork.Combinator.AcrossEras
 import Ouroboros.Consensus.HardFork.Combinator.Basics
-import Ouroboros.Consensus.HardFork.Combinator.Block
 import Ouroboros.Consensus.HardFork.Combinator.Forge ()
-import Ouroboros.Consensus.HardFork.Combinator.Ledger ()
+import Ouroboros.Consensus.HardFork.Combinator.Ledger
 import Ouroboros.Consensus.HardFork.Combinator.Ledger.CommonProtocolParams
  ()
 import Ouroboros.Consensus.HardFork.Combinator.Ledger.Query ()
+import Ouroboros.Consensus.HardFork.Combinator.Ledger.Query
 import Ouroboros.Consensus.HardFork.Combinator.Mempool ()
+import Ouroboros.Consensus.HardFork.Combinator.Mempool
 import Ouroboros.Consensus.HardFork.Combinator.Node ()
+import Ouroboros.Consensus.HardFork.Combinator.PartialConfig
 import Ouroboros.Consensus.HardFork.Combinator.Serialisation.Common
 import Ouroboros.Consensus.HardFork.Combinator.Serialisation.SerialiseDisk
  ()
@@ -53,14 +80,200 @@ instance ( SupportedNetworkProtocolVersion (HardForkBlock '[b])
  nodeInitChainDB cfg = nodeInitChainDB (project cfg) . contramap DegenBlock
 
 {-------------------------------------------------------------------------------
- Patterns
+ Simple patterns
 -------------------------------------------------------------------------------}
 
-{-# COMPLETE DegenBlock #-}
-{-# COMPLETE DegenHeader #-}
+{-# COMPLETE DegenApplyTxErr #-}
+{-# COMPLETE DegenBlock #-}
+{-# COMPLETE DegenBlockConfig #-}
+{-# COMPLETE DegenCodecConfig #-}
+{-# COMPLETE DegenGenTx #-}
+{-# COMPLETE DegenGenTxId #-}
+{-# COMPLETE DegenHeader #-}
+{-# COMPLETE DegenLedgerError #-}
+{-# COMPLETE DegenLedgerState #-}
+{-# COMPLETE DegenOtherHeaderEnvelopeError #-}
+{-# COMPLETE DegenQuery #-}
+{-# COMPLETE DegenQueryResult #-}
+{-# COMPLETE DegenTipInfo #-}
 
-pattern DegenBlock :: b -> HardForkBlock '[b]
-pattern DegenBlock b = HardForkBlock (OneEraBlock (Z (I b)))
+pattern DegenBlock ::
+ forall b. NoHardForks b
+ => b
+ -> HardForkBlock '[b]
+pattern DegenBlock x <- (project' (Proxy @(I b)) -> x)
+ where
+ DegenBlock x = inject' (Proxy @(I b)) x
 
-pattern DegenHeader :: Header b -> Header (HardForkBlock '[b])
-pattern DegenHeader h = HardForkHeader (OneEraHeader (Z h))
+pattern DegenHeader ::
+ NoHardForks b
+ => Header b
+ -> Header (HardForkBlock '[b])
+pattern DegenHeader x <- (project -> x)
+ where
+ DegenHeader x = inject x
+
+pattern DegenGenTx ::
+ NoHardForks b
+ => GenTx b
+ -> GenTx (HardForkBlock '[b])
+pattern DegenGenTx x <- (project -> x)
+ where
+ DegenGenTx x = inject x
+
+pattern DegenGenTxId ::
+ forall b. NoHardForks b
+ => GenTxId b
+ -> GenTxId (HardForkBlock '[b])
+pattern DegenGenTxId x <- (project' (Proxy @(WrapGenTxId b)) -> x)
+ where
+ DegenGenTxId x = inject' (Proxy @(WrapGenTxId b)) x
+
+pattern DegenApplyTxErr ::
+ forall b. NoHardForks b
+ => ApplyTxErr b
+ -> HardForkApplyTxErr '[b] -- ApplyTxErr (HardForkBlock '[b])
+pattern DegenApplyTxErr x <- (project' (Proxy @(WrapApplyTxErr b)) -> x)
+ where
+ DegenApplyTxErr x = inject' (Proxy @(WrapApplyTxErr b)) x
+
+pattern DegenLedgerError ::
+ forall b. NoHardForks b
+ => LedgerError b
+ -> HardForkLedgerError '[b] -- LedgerError (HardForkBlock '[b])
+pattern DegenLedgerError x <- (project' (Proxy @(WrapLedgerErr b)) -> x)
+ where
+ DegenLedgerError x = inject' (Proxy @(WrapLedgerErr b)) x
+
+pattern DegenOtherHeaderEnvelopeError ::
+ forall b. NoHardForks b
+ => OtherHeaderEnvelopeError b
+ -> HardForkEnvelopeErr '[b] -- OtherHeaderEnvelopeError (HardForkBlock '[b])
+pattern DegenOtherHeaderEnvelopeError x <- (project' (Proxy @(WrapEnvelopeErr b)) -> x)
+ where
+ DegenOtherHeaderEnvelopeError x = inject' (Proxy @(WrapEnvelopeErr b)) x
+
+pattern DegenTipInfo ::
+ forall b. NoHardForks b
+ => TipInfo b
+ -> OneEraTipInfo '[b] -- TipInfo (HardForkBlock '[b])
+pattern DegenTipInfo x <- (project' (Proxy @(WrapTipInfo b)) -> x)
+ where
+ DegenTipInfo x = inject' (Proxy @(WrapTipInfo b)) x
+
+pattern DegenQuery ::
+ ()
+ => HardForkQueryResult '[b] result ~ a
+ => Query b result
+ -> Query (HardForkBlock '[b]) a
+pattern DegenQuery x <- (projQuery' -> ProjHardForkQuery x)
+ where
+ DegenQuery x = injQuery x
+
+pattern DegenQueryResult ::
+ result
+ -> HardForkQueryResult '[b] result
+pattern DegenQueryResult x <- (projQueryResult -> x)
+ where
+ DegenQueryResult x = injQueryResult x
+
+pattern DegenCodecConfig ::
+ NoHardForks b
+ => CodecConfig b
+ -> CodecConfig (HardForkBlock '[b])
+pattern DegenCodecConfig x <- (project -> x)
+ where
+ DegenCodecConfig x = inject x
+
+pattern DegenBlockConfig ::
+ NoHardForks b
+ => BlockConfig b
+ -> BlockConfig (HardForkBlock '[b])
+pattern DegenBlockConfig x <- (project -> x)
+ where
+ DegenBlockConfig x = inject x
+
+pattern DegenLedgerState ::
+ NoHardForks b
+ => LedgerState b
+ -> LedgerState (HardForkBlock '[b])
+pattern DegenLedgerState x <- (project -> x)
+ where
+ DegenLedgerState x = inject x
+
+{-------------------------------------------------------------------------------
+ Dealing with the config
+
+ NOTE: The pattern synonyms for 'ConsensusConfig' and 'LedgerConfig'
+ give you a /partial/ config. The pattern synonym for the 'TopLevelConfig'
+ /does/ give you a full config.
+-------------------------------------------------------------------------------}
+
+{-# COMPLETE DegenConsensusConfig #-}
+{-# COMPLETE DegenLedgerConfig #-}
+{-# COMPLETE DegenTopLevelConfig #-}
+
+pattern DegenConsensusConfig ::
+ PartialConsensusConfig (BlockProtocol b)
+ -> ConsensusConfig (BlockProtocol (HardForkBlock '[b]))
+pattern DegenConsensusConfig x <-
+ HardForkConsensusConfig {
+ hardForkConsensusConfigPerEra = PerEraConsensusConfig
+ ( WrapPartialConsensusConfig x
+ :* Nil
+ )
+ }
+
+pattern DegenLedgerConfig ::
+ PartialLedgerConfig b
+ -> HardForkLedgerConfig '[b] -- LedgerConfig (HardForkBlock '[b])
+pattern DegenLedgerConfig x <-
+ HardForkLedgerConfig {
+ hardForkLedgerConfigPerEra = PerEraLedgerConfig
+ ( WrapPartialLedgerConfig x
+ :* Nil
+ )
+ }
+
+pattern DegenTopLevelConfig ::
+ NoHardForks b
+ => TopLevelConfig b
+ -> TopLevelConfig (HardForkBlock '[b])
+pattern DegenTopLevelConfig x <- (project -> x)
+ where
+ DegenTopLevelConfig x = inject x
+
+
+{-
+-- | An error resulting from applying a 'CardanoBlock' to the ledger.
+--
+-- Thanks to the pattern synonyms, you can treat this as a sum type with
+-- constructors 'LedgerErrorByron', 'LedgerErrorShelley', and
+-- 'LedgerErrorWrongEra'.
+--
+-- > toText :: CardanoLedgerError sc -> Text
+-- > toText (LedgerErrorByron b) = byronLedgerErrorToText b
+-- > toText (LedgerErrorShelley s) = shelleyLedgerErrorToText s
+-- > toText (LedgerErrorWrongEra eraMismatch) =
+-- > "Block from the " <> otherEraName eraMismatch <>
+-- > " era applied to a ledger from the " <>
+-- > ledgerEraName eraMismatch <> " era"
+--
+type CardanoLedgerError sc = HardForkLedgerError '[b]
+
+pattern LedgerErrorByron :: LedgerError b -> CardanoLedgerError sc
+pattern LedgerErrorByron err =
+ HardForkLedgerErrorFromEra (OneEraLedgerError (Z (WrapLedgerErr err)))
+
+pattern LedgerErrorShelley :: LedgerError (ShelleyBlock sc)
+ -> CardanoLedgerError sc
+pattern LedgerErrorShelley err =
+ HardForkLedgerErrorFromEra
+ (OneEraLedgerError (S (Z (WrapLedgerErr err))))
+
+pattern LedgerErrorWrongEra :: EraMismatch -> CardanoLedgerError sc
+pattern LedgerErrorWrongEra eraMismatch <-
+ HardForkLedgerErrorWrongEra (mkEraMismatch -> eraMismatch)
+
+{-# COMPLETE LedgerErrorByron, LedgerErrorShelley, LedgerErrorWrongEra #-}
+-}

ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Unary.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE QuantifiedConstraints #-}
 {-# LANGUAGE RankNTypes #-}
@@ -22,7 +23,11 @@ module Ouroboros.Consensus.HardFork.Combinator.Unary (
  , inject'
  -- * Dependent types
  , projQuery
+ , projQuery'
+ , ProjHardForkQuery(..)
  , injQuery
+ , projQueryResult
+ , injQueryResult
  , projNestedCtxt
  , injNestedCtxt
  -- * Convenience exports
@@ -512,6 +517,23 @@ instance Isomorphic (SomeBlock (NestedCtxt f)) where
  project (SomeBlock ctxt) = SomeBlock $ projNestedCtxt ctxt
  inject (SomeBlock ctxt) = SomeBlock $ injNestedCtxt ctxt
 
+instance Isomorphic WrapLedgerErr where
+ project = WrapLedgerErr . aux . unwrapLedgerErr
+ where
+ aux :: HardForkLedgerError '[blk] -> LedgerErr (LedgerState blk)
+ aux (HardForkLedgerErrorFromEra err) =
+ unwrapLedgerErr
+ . unZ
+ . getOneEraLedgerError
+ $ err
+ aux (HardForkLedgerErrorWrongEra err) =
+ absurd $ mismatchOneEra err
+
+ inject = WrapLedgerErr . aux . unwrapLedgerErr
+ where
+ aux :: LedgerErr (LedgerState blk) -> HardForkLedgerError '[blk]
+ aux = HardForkLedgerErrorFromEra . OneEraLedgerError . Z . WrapLedgerErr
+
 {-------------------------------------------------------------------------------
  Serialised
 -------------------------------------------------------------------------------}
@@ -553,13 +575,29 @@ projQuery qry k =
  aux (QZ q) = q
  aux (QS q) = case q of {}
 
+projQuery' :: Query (HardForkBlock '[b]) result
+ -> ProjHardForkQuery b result
+projQuery' qry = projQuery qry $ \Refl -> ProjHardForkQuery
+
+data ProjHardForkQuery b :: * -> * where
+ ProjHardForkQuery ::
+ Query b result'
+ -> ProjHardForkQuery b (HardForkQueryResult '[b] result')
+
 -- | Inject 'Query'
 --
 -- Not an instance of 'Isomorphic' because the types change.
 injQuery :: Query b result
  -> Query (HardForkBlock '[b]) (HardForkQueryResult '[b] result)
 injQuery = QueryIfCurrent . QZ
 
+projQueryResult :: HardForkQueryResult '[b] result -> result
+projQueryResult (Left err) = absurd $ mismatchOneEra err
+projQueryResult (Right result) = result
+
+injQueryResult :: result -> HardForkQueryResult '[b] result
+injQueryResult = Right
+
 projNestedCtxt :: NestedCtxt f (HardForkBlock '[blk]) a -> NestedCtxt f blk a
 projNestedCtxt = NestedCtxt . aux . flipNestedCtxt
  where