Merge pull request #414 from IntersectMBO/jordan/era-handling-refactor-2

Expose CurrentEra and UpcomingEra pattern synonyms

cardano-api/internal/Cardano/Api/Protocol/Version.hs

@@ -2,21 +2,25 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilyDependencies #-}
-{-# LANGUAGE TypeOperators #-}
+-- UndecidableInstances needed for 9.2.7 and 8.10.7
+{-# LANGUAGE UndecidableInstances #-}
+
+-- Only for UninhabitableType
+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
 
 -- | This module defines the protocol versions corresponding to the eras in the Cardano blockchain.
 module Cardano.Api.Protocol.Version
   ( BabbageEra
   , ConwayEra
+  , pattern CurrentEra
+  , pattern UpcomingEra
   , Era (..)
-  , MaxSupportedVersion
-  , MinSupportedVersion
-  , SupportedProtocolVersionRange
   , UseEra
   , VersionToSbe
-  , getProtocolVersion
+  , useEra
   , protocolVersionToSbe
   ) where
 
@@ -28,75 +32,132 @@ import           GHC.TypeLits
 -- | Users typically interact with the latest features on the mainnet or experiment with features
 -- from the upcoming era. Hence, the protocol versions are limited to the current mainnet era
 -- and the next era (upcoming era).
---
--- - 'MinSupportedVersion': Represents the minimum protocol version, aligning with the current
---   era on mainnet (Babbage era).
--- - 'MaxSupportedVersion': Represents the maximum protocol version, corresponding to the next
---   era planned for Cardano's mainnet (Conway era).
-
--- | The minimum supported protocol version, corresponding to the Babbage era on Cardano's mainnet.
-type MinSupportedVersion = 8 :: Nat
-
--- | The maximum supported protocol version, representing the upcoming Conway era.
-type MaxSupportedVersion = 9 :: Nat
-
-type BabbageEra = 8 :: Nat
-type ConwayEra = 9 :: Nat
-
-type SupportedProtocolVersionRange (version :: Nat) =
-    ( MinSupportedVersion <= version
-    , version <= MaxSupportedVersion
-    )
+data BabbageEra
+data ConwayEra
 
 -- Allows us to gradually change the api without breaking things.
 -- This will eventually be removed.
-type family VersionToSbe (version :: Nat) where
+type family VersionToSbe version where
   VersionToSbe BabbageEra = Api.BabbageEra
   VersionToSbe ConwayEra = Api.ConwayEra
 
--- | Represents the eras in Cardano's blockchain history.
---
--- Instead of enumerating every possible era, we use two constructors:
--- 'CurrentEra' and 'UpcomingEra'. This design simplifies the handling
--- of eras, especially for 'cardano-api' consumers who are primarily concerned
--- with the current mainnet era and the next era for an upcoming hardfork.
---
--- Usage:
--- - 'CurrentEra': Reflects the era currently active on mainnet.
--- - 'UpcomingEra': Represents the era planned for the next hardfork.
---
--- After a hardfork, 'cardano-api' should be updated promptly to reflect
--- the new mainnet era in 'CurrentEra'.
---
--- Each era is associated with a specific protocol version:
--- - 'BabbageEra' for 'CurrentEra'
--- - 'ConwayEra' for 'UpcomingEra'
-data Era (version :: Nat) where
+{- | Represents the eras in Cardano's blockchain.
+
+Instead of enumerating every possible era, we use two constructors:
+'CurrentEra' and 'UpcomingEra'. This design simplifies the handling
+of eras, especially for 'cardano-api' consumers who are primarily concerned
+with the current mainnet era and the next era for an upcoming hardfork.
+
+Usage:
+- 'CurrentEra': Reflects the era currently active on mainnet.
+- 'UpcomingEra': Represents the era planned for the next hardfork.
+
+After a hardfork, 'cardano-api' should be updated promptly to reflect
+the new mainnet era in 'CurrentEra'.
+
+-}
+data Era version where
   -- | The era currently active on Cardano's mainnet.
-  CurrentEra
-    :: SupportedProtocolVersionRange BabbageEra
-    => Era BabbageEra
+  CurrentEraInternal :: Era BabbageEra
   -- | The era planned for the next hardfork on Cardano's mainnet.
-  UpcomingEra
-    :: SupportedProtocolVersionRange ConwayEra
-    => Era ConwayEra
+  UpcomingEraInternal :: Era ConwayEra
+
+{- | How to deprecate an era
+
+  1. Add DEPRECATED pragma to the era type tag.
+@
+{-# DEPRECATED BabbageEra "BabbageEra no longer supported, use ConwayEra" #-}
+data BabbageEra
+@
+
+  2. Add a new era type tag.
+@
+data Era version where
+  -- | The era currently active on Cardano's mainnet.
+  CurrentEraInternal :: Era ConwayEra
+  -- | The era planned for the next hardfork on Cardano's mainnet.
+  UpcomingEraInternal :: Era (UninhabitableType EraCurrentlyNonExistent)
+@
+
+  3. Update pattern synonyms.
+@
+pattern CurrentEra :: Era ConwayEra
+pattern CurrentEra = CurrentEraInternal
+
+pattern UpcomingEra :: Era (UninhabitableType EraCurrentlyNonExistent)
+pattern UpcomingEra = UpcomingEraInternal
+@
+
+  4. Add new 'UseEra' instance and keep the deprecated era's instance.
+@
+instance UseEra BabbageEra where
+  useEra = error "useEra: BabbageEra no longer supported, use ConwayEra"
 
+instance UseEra ConwayEra where
+  useEra = CurrentEra
+@
 
+  5. Update 'protocolVersionToSbe' as follows:
+@
 protocolVersionToSbe
   :: Era version
-  -> ShelleyBasedEra (VersionToSbe version)
-protocolVersionToSbe CurrentEra = ShelleyBasedEraBabbage
-protocolVersionToSbe UpcomingEra = ShelleyBasedEraConway
+  -> Maybe (ShelleyBasedEra (VersionToSbe version))
+protocolVersionToSbe CurrentEraInternal = Just ShelleyBasedEraBabbage
+protocolVersionToSbe UpcomingEraInternal = Nothing
+@
+-}
+
+
+{- | 'CurrentEraInternal' and 'UpcomingEraInternal' are for internal use only.
+The above restriction combined with the following pattern synonyms
+prevents a user from pattern matching on 'Era era' and
+avoids the following situation:
+
+@
+doThing :: Era era -> ()
+doThing = \case
+  CurrentEraInternal -> enableFeature
+  UpcomingEraInternal -> disableFeature
+@
+
+Consumers of this library must pick one of the two eras while
+this library is responsibile for what happens at the boundary of the eras.
+-}
+
+pattern CurrentEra :: Era BabbageEra
+pattern CurrentEra = CurrentEraInternal
+
+pattern UpcomingEra :: Era ConwayEra
+pattern UpcomingEra = UpcomingEraInternal
+
+{-# COMPLETE CurrentEra, UpcomingEra #-}
+
+protocolVersionToSbe
+  :: Era version
+  -> Maybe (ShelleyBasedEra (VersionToSbe version))
+protocolVersionToSbe CurrentEraInternal = Just ShelleyBasedEraBabbage
+protocolVersionToSbe UpcomingEraInternal = Nothing
 
 -------------------------------------------------------------------------
 
 -- | Type class interface for the 'Era' type.
 
-class UseEra (version :: Nat) where
-  getProtocolVersion :: Era version
+class UseEra version where
+  useEra :: Era version
 
 instance UseEra BabbageEra where
-  getProtocolVersion = CurrentEra
+  useEra = CurrentEra
 
 instance UseEra ConwayEra where
-  getProtocolVersion = UpcomingEra
+  useEra = UpcomingEra
+
+
+-- | After a hardfork there is usually no planned upcoming era
+-- that we are able to experiment with. We force a type era
+-- in this instance. See docs above.
+data EraCurrentlyNonExistent
+
+type family UninhabitableType a  where
+  UninhabitableType EraCurrentlyNonExistent = TypeError ('Text "There is currently no planned upcoming era. Use CurrentEra instead.")
+
+

cardano-api/src/Cardano/Api/Experimental.hs

@@ -1,14 +1,15 @@
+{-# LANGUAGE PatternSynonyms #-}
+
 module Cardano.Api.Experimental
   ( -- * New Era interface
     BabbageEra
   , ConwayEra
   , Era
-  , MaxSupportedVersion
-  , MinSupportedVersion
-  , SupportedProtocolVersionRange
+  , pattern CurrentEra
+  , pattern UpcomingEra
   , UseEra
   , VersionToSbe
-  , getProtocolVersion
+  , useEra
   , protocolVersionToSbe
   ) where