Pattern synonyms for degenerate

Closes #2407.
IntersectMBO · Jul 15, 2020 · 690129d · 690129d
1 parent ea2fbcd
commit 690129d
Show file tree

Hide file tree

Showing 2 changed files with 240 additions and 10 deletions.
diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Degenerate.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Degenerate.hs
@@ -3,31 +3,55 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ViewPatterns #-}
 
-{-# OPTIONS_GHC -Wno-orphans #-}
+{-# OPTIONS_GHC -Wno-orphans -Wwarn #-}
 
 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)
+ , LedgerState (DegenLedgerState)
  ) where
 
 import Control.Tracer
 import Data.SOP.Strict
 
 import Ouroboros.Consensus.Block.Abstract
 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.Serialisation.Common
 import Ouroboros.Consensus.HardFork.Combinator.Serialisation.SerialiseDisk
@@ -53,14 +77,199 @@ instance ( SupportedNetworkProtocolVersion (HardForkBlock '[b])
  nodeInitChainDB cfg = nodeInitChainDB (project cfg) . contramap DegenBlock
 
 {-------------------------------------------------------------------------------
- Patterns
+ Simple patterns
 -------------------------------------------------------------------------------}
 
-{-# COMPLETE DegenBlock #-}
-{-# COMPLETE DegenHeader #-}
+{-# COMPLETE DegenBlock #-}
+{-# COMPLETE DegenHeader #-}
+{-# COMPLETE DegenGenTx #-}
+{-# COMPLETE DegenGenTxId #-}
+{-# COMPLETE DegenApplyTxErr #-}
+{-# COMPLETE DegenOtherHeaderEnvelopeError #-}
+{-# COMPLETE DegenTipInfo #-}
+{-# COMPLETE DegenQuery #-}
+{-# COMPLETE DegenQueryResult #-}
+{-# COMPLETE DegenCodecConfig #-}
+{-# COMPLETE DegenBlockConfig #-}
+{-# COMPLETE DegenLedgerState #-}
 
-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
+
+-- TODO: Ledger error
+
+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
+
+-- consensus config?
+-- ledger config?
+
+pattern DegenLedgerState
+ :: NoHardForks b
+ => LedgerState b
+ -> LedgerState (HardForkBlock '[b])
+pattern DegenLedgerState x <- (project -> x)
+ where
+ DegenLedgerState x = inject x
+
+
+
+{-
+type CardanoConsensusConfig sc =
+ ConsensusConfig (HardForkProtocol '[b])
+
+pattern CardanoConsensusConfig
+ :: PartialConsensusConfig (BlockProtocol b)
+ -> PartialConsensusConfig (BlockProtocol (ShelleyBlock sc))
+ -> CardanoConsensusConfig sc
+pattern CardanoConsensusConfig cfgByron cfgShelley <-
+ HardForkConsensusConfig {
+ hardForkConsensusConfigPerEra = PerEraConsensusConfig
+ ( WrapPartialConsensusConfig cfgByron
+ :* WrapPartialConsensusConfig cfgShelley
+ :* Nil
+ )
+ }
+
+{-# COMPLETE CardanoConsensusConfig #-}
+-- | The 'LedgerConfig' for 'CardanoBlock'.
+--
+-- Thanks to the pattern synonyms, you can treat this as the product of the
+-- Byron and Shelley 'PartialLedgerConfig'.
+--
+-- NOTE: not 'LedgerConfig', but 'PartialLedgerConfig'.
+type CardanoLedgerConfig sc = HardForkLedgerConfig '[b]
+
+pattern CardanoLedgerConfig
+ :: PartialLedgerConfig b
+ -> PartialLedgerConfig (ShelleyBlock sc)
+ -> CardanoLedgerConfig sc
+pattern CardanoLedgerConfig cfgByron cfgShelley <-
+ HardForkLedgerConfig {
+ hardForkLedgerConfigPerEra = PerEraLedgerConfig
+ ( WrapPartialLedgerConfig cfgByron
+ :* WrapPartialLedgerConfig cfgShelley
+ :* Nil
+ )
+ }
+
+{-# COMPLETE CardanoLedgerConfig #-}
+
+
+-}
+
+{-
+-- | 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 #-}
+-}
diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Unary.hs b/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
@@ -553,13 +558,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