{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}

-- | This module defines the protocol versions corresponding to the eras in the Cardano blockchain.
module Cardano.Api.Experimental.Eras
  ( BabbageEra
  , ConwayEra
  , Era (..)
  , IsEra (..)
  , Some (..)
  , Inject (..)
  , LedgerEra
  , DeprecatedEra (..)
  , EraCommonConstraints
  , obtainCommonConstraints
  , eraToSbe
  , babbageEraOnwardsToEra
  , eraToBabbageEraOnwards
  , sbeToEra
  )
where

import           Cardano.Api.Eon.BabbageEraOnwards
import           Cardano.Api.Eon.Convert
import           Cardano.Api.Eon.ShelleyBasedEra (ShelleyBasedEra (..), ShelleyLedgerEra)
import qualified Cardano.Api.Eras as Api
import           Cardano.Api.Eras.Core (BabbageEra, ConwayEra, Eon (..))
import qualified Cardano.Api.ReexposeLedger as L
import           Cardano.Api.Via.ShowOf

import qualified Cardano.Ledger.Api as L
import qualified Cardano.Ledger.Babbage as Ledger
import           Cardano.Ledger.BaseTypes (Inject (..))
import qualified Cardano.Ledger.Conway as Ledger
import qualified Cardano.Ledger.Core as Ledger
import           Cardano.Ledger.Hashes
import qualified Cardano.Ledger.SafeHash as L
import qualified Cardano.Ledger.UTxO as L

import           Control.Monad.Error.Class
import           Data.Aeson (FromJSON (..), ToJSON, withText)
import           Data.Aeson.Types (ToJSON (..))
import           Data.Kind
import           Data.Maybe (isJust)
import qualified Data.Text as Text
import           Data.Type.Equality
import           Data.Typeable
import           GHC.Exts (IsString)
import           Prettyprinter

-- | 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).
type family LedgerEra era = (r :: Type) | r -> era where
  LedgerEra BabbageEra = Ledger.Babbage
  LedgerEra ConwayEra = Ledger.Conway

-- | An existential wrapper for types of kind @k -> Types@. Use it to hold any era e.g. @Some Era@. One can
-- then bring the era witness back into scope for example using this pattern:
-- @
-- anyEra = Some ConwayEra
-- -- then later in the code
-- Some era <- pure anyEra
-- obtainCommonConstraints era foo
-- @
data Some (f :: k -> Type) where
  Some
    :: forall f a
     . (Typeable a, Typeable (f a))
    => f a
    -> Some f

-- | Represents the eras in Cardano's blockchain.
-- This type represents eras currently on mainnet and new eras which are
-- in development.
--
-- After a hardfork, the era from which we hardfork from gets deprecated and
-- after deprecation period, gets removed. During deprecation period,
-- consumers of cardano-api should update their codebase to the mainnet era.
data Era era where
  -- | The era currently active on Cardano's mainnet.
  BabbageEra :: Era BabbageEra
  -- | The upcoming era in development.
  ConwayEra :: Era ConwayEra

deriving instance Show (Era era)

deriving instance Eq (Era era)

instance Pretty (Era era) where
  pretty :: forall ann. Era era -> Doc ann
pretty = Era era -> Doc ann
forall a era. IsString a => Era era -> a
eraToStringLike

instance TestEquality Era where
  testEquality :: forall a b. Era a -> Era b -> Maybe (a :~: b)
testEquality Era a
BabbageEra Era b
BabbageEra = (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
  testEquality Era a
BabbageEra Era b
_ = Maybe (a :~: b)
forall a. Maybe a
Nothing
  testEquality Era a
ConwayEra Era b
ConwayEra = (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
  testEquality Era a
ConwayEra Era b
_ = Maybe (a :~: b)
forall a. Maybe a
Nothing

instance ToJSON (Era era) where
  toJSON :: Era era -> Value
toJSON = Era era -> Value
forall a era. IsString a => Era era -> a
eraToStringLike

instance Show (Some Era) where
  showsPrec :: Int -> Some Era -> ShowS
showsPrec Int
_ (Some Era a
era) = Era a -> ShowS
forall a. Show a => a -> ShowS
shows Era a
era

instance Eq (Some Era) where
  Some Era a
era1 == :: Some Era -> Some Era -> Bool
== Some Era a
era2 = Maybe (a :~: a) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (a :~: a) -> Bool) -> Maybe (a :~: a) -> Bool
forall a b. (a -> b) -> a -> b
$ Era a -> Era a -> Maybe (a :~: a)
forall a b. Era a -> Era b -> Maybe (a :~: b)
forall {k} (f :: k -> *) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality Era a
era1 Era a
era2

instance Bounded (Some Era) where
  minBound :: Some Era
minBound = Era BabbageEra -> Some Era
forall {k} (f :: k -> *) (a :: k).
(Typeable a, Typeable (f a)) =>
f a -> Some f
Some Era BabbageEra
BabbageEra
  maxBound :: Some Era
maxBound = Era ConwayEra -> Some Era
forall {k} (f :: k -> *) (a :: k).
(Typeable a, Typeable (f a)) =>
f a -> Some f
Some Era ConwayEra
ConwayEra

instance Enum (Some Era) where
  toEnum :: Int -> Some Era
toEnum Int
0 = Era BabbageEra -> Some Era
forall {k} (f :: k -> *) (a :: k).
(Typeable a, Typeable (f a)) =>
f a -> Some f
Some Era BabbageEra
BabbageEra
  toEnum Int
1 = Era ConwayEra -> Some Era
forall {k} (f :: k -> *) (a :: k).
(Typeable a, Typeable (f a)) =>
f a -> Some f
Some Era ConwayEra
ConwayEra
  toEnum Int
i = String -> Some Era
forall a. HasCallStack => String -> a
error (String -> Some Era) -> String -> Some Era
forall a b. (a -> b) -> a -> b
$ String
"Enum.toEnum: invalid argument " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" - does not correspond to any era"
  fromEnum :: Some Era -> Int
fromEnum (Some Era a
BabbageEra) = Int
0
  fromEnum (Some Era a
ConwayEra) = Int
1

instance Ord (Some Era) where
  compare :: Some Era -> Some Era -> Ordering
compare Some Era
e1 Some Era
e2 = Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Some Era -> Int
forall a. Enum a => a -> Int
fromEnum Some Era
e1) (Some Era -> Int
forall a. Enum a => a -> Int
fromEnum Some Era
e2)

instance Pretty (Some Era) where
  pretty :: forall ann. Some Era -> Doc ann
pretty (Some Era a
era) = Era a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Era a -> Doc ann
pretty Era a
era

instance ToJSON (Some Era) where
  toJSON :: Some Era -> Value
toJSON (Some Era a
era) = Era a -> Value
forall a. ToJSON a => a -> Value
toJSON Era a
era

instance FromJSON (Some Era) where
  parseJSON :: Value -> Parser (Some Era)
parseJSON =
    String -> (Text -> Parser (Some Era)) -> Value -> Parser (Some Era)
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Some Era" ((Text -> Parser (Some Era)) -> Value -> Parser (Some Era))
-> (Text -> Parser (Some Era)) -> Value -> Parser (Some Era)
forall a b. (a -> b) -> a -> b
$
      ( \case
          Right Some Era
era -> Some Era -> Parser (Some Era)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Some Era
era
          Left Text
era -> String -> Parser (Some Era)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (Some Era)) -> String -> Parser (Some Era)
forall a b. (a -> b) -> a -> b
$ String
"Failed to parse unknown era: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
era
      )
        (Either Text (Some Era) -> Parser (Some Era))
-> (Text -> Either Text (Some Era)) -> Text -> Parser (Some Era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text (Some Era)
forall a. (IsString a, Eq a) => a -> Either a (Some Era)
eraFromStringLike

eraToStringLike :: IsString a => Era era -> a
{-# INLINE eraToStringLike #-}
eraToStringLike :: forall a era. IsString a => Era era -> a
eraToStringLike = \case
  Era era
BabbageEra -> a
"Babbage"
  Era era
ConwayEra -> a
"Conway"

eraFromStringLike :: (IsString a, Eq a) => a -> Either a (Some Era)
{-# INLINE eraFromStringLike #-}
eraFromStringLike :: forall a. (IsString a, Eq a) => a -> Either a (Some Era)
eraFromStringLike = \case
  a
"Babbage" -> Some Era -> Either a (Some Era)
forall a. a -> Either a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Some Era -> Either a (Some Era))
-> Some Era -> Either a (Some Era)
forall a b. (a -> b) -> a -> b
$ Era BabbageEra -> Some Era
forall {k} (f :: k -> *) (a :: k).
(Typeable a, Typeable (f a)) =>
f a -> Some f
Some Era BabbageEra
BabbageEra
  a
"Conway" -> Some Era -> Either a (Some Era)
forall a. a -> Either a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Some Era -> Either a (Some Era))
-> Some Era -> Either a (Some Era)
forall a b. (a -> b) -> a -> b
$ Era ConwayEra -> Some Era
forall {k} (f :: k -> *) (a :: k).
(Typeable a, Typeable (f a)) =>
f a -> Some f
Some Era ConwayEra
ConwayEra
  a
wrong -> a -> Either a (Some Era)
forall a b. a -> Either a b
Left a
wrong

-- | How to deprecate an era
--
--   1. Add DEPRECATED pragma to the era type tag and the era constructor at the same time:
-- @
-- {-# DEPRECATED BabbageEra "BabbageEra no longer supported, use ConwayEra" #-}
-- data BabbageEra
-- @
--
--   2. Update haddock for the constructor of the deprecated era, mentioning deprecation.
--
-- @
-- data Era era where
--   {-# DEPRECATED BabbageEra "BabbageEra no longer supported, use ConwayEra" #-}
--   BabbageEra :: Era BabbageEra
--   -- | The era currently active on Cardano's mainnet.
--   ConwayEra :: Era ConwayEra
-- @
--
--   3. Add new 'IsEra' instance and update the deprecated era instance to produce a compile-time error:
-- @
-- instance TypeError ('Text "IsEra BabbageEra: Deprecated. Update to ConwayEra") => IsEra BabbageEra where
--   useEra = error "unreachable"
--
-- instance IsEra ConwayEra where
--   useEra = ConwayEra
-- @
{-# DEPRECATED eraToSbe "Use 'convert' instead." #-}
eraToSbe
  :: Era era
  -> ShelleyBasedEra era
eraToSbe :: forall era. Era era -> ShelleyBasedEra era
eraToSbe = Era era -> ShelleyBasedEra era
forall era. Era era -> ShelleyBasedEra era
forall a (f :: a -> *) (g :: a -> *) (era :: a).
Convert f g =>
f era -> g era
convert

instance Convert Era Api.CardanoEra where
  convert :: forall era. Era era -> CardanoEra era
convert = \case
    Era era
BabbageEra -> CardanoEra era
CardanoEra BabbageEra
Api.BabbageEra
    Era era
ConwayEra -> CardanoEra era
CardanoEra ConwayEra
Api.ConwayEra

instance Convert Era ShelleyBasedEra where
  convert :: forall era. Era era -> ShelleyBasedEra era
convert = \case
    Era era
BabbageEra -> ShelleyBasedEra era
ShelleyBasedEra BabbageEra
ShelleyBasedEraBabbage
    Era era
ConwayEra -> ShelleyBasedEra era
ShelleyBasedEra ConwayEra
ShelleyBasedEraConway

instance Convert Era BabbageEraOnwards where
  convert :: forall era. Era era -> BabbageEraOnwards era
convert = \case
    Era era
BabbageEra -> BabbageEraOnwards era
BabbageEraOnwards BabbageEra
BabbageEraOnwardsBabbage
    Era era
ConwayEra -> BabbageEraOnwards era
BabbageEraOnwards ConwayEra
BabbageEraOnwardsConway

instance Convert BabbageEraOnwards Era where
  convert :: forall era. BabbageEraOnwards era -> Era era
convert = \case
    BabbageEraOnwards era
BabbageEraOnwardsBabbage -> Era era
Era BabbageEra
BabbageEra
    BabbageEraOnwards era
BabbageEraOnwardsConway -> Era era
Era ConwayEra
ConwayEra

newtype DeprecatedEra era
  = DeprecatedEra (ShelleyBasedEra era)
  deriving Int -> DeprecatedEra era -> ShowS
[DeprecatedEra era] -> ShowS
DeprecatedEra era -> String
(Int -> DeprecatedEra era -> ShowS)
-> (DeprecatedEra era -> String)
-> ([DeprecatedEra era] -> ShowS)
-> Show (DeprecatedEra era)
forall era. Int -> DeprecatedEra era -> ShowS
forall era. [DeprecatedEra era] -> ShowS
forall era. DeprecatedEra era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall era. Int -> DeprecatedEra era -> ShowS
showsPrec :: Int -> DeprecatedEra era -> ShowS
$cshow :: forall era. DeprecatedEra era -> String
show :: DeprecatedEra era -> String
$cshowList :: forall era. [DeprecatedEra era] -> ShowS
showList :: [DeprecatedEra era] -> ShowS
Show

deriving via (ShowOf (DeprecatedEra era)) instance Pretty (DeprecatedEra era)

sbeToEra
  :: MonadError (DeprecatedEra era) m
  => ShelleyBasedEra era
  -> m (Era era)
sbeToEra :: forall era (m :: * -> *).
MonadError (DeprecatedEra era) m =>
ShelleyBasedEra era -> m (Era era)
sbeToEra ShelleyBasedEra era
ShelleyBasedEraConway = Era era -> m (Era era)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Era era
Era ConwayEra
ConwayEra
sbeToEra ShelleyBasedEra era
ShelleyBasedEraBabbage = Era era -> m (Era era)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Era era
Era BabbageEra
BabbageEra
sbeToEra e :: ShelleyBasedEra era
e@ShelleyBasedEra era
ShelleyBasedEraAlonzo = DeprecatedEra era -> m (Era era)
forall a. DeprecatedEra era -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (DeprecatedEra era -> m (Era era))
-> DeprecatedEra era -> m (Era era)
forall a b. (a -> b) -> a -> b
$ ShelleyBasedEra era -> DeprecatedEra era
forall era. ShelleyBasedEra era -> DeprecatedEra era
DeprecatedEra ShelleyBasedEra era
e
sbeToEra e :: ShelleyBasedEra era
e@ShelleyBasedEra era
ShelleyBasedEraMary = DeprecatedEra era -> m (Era era)
forall a. DeprecatedEra era -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (DeprecatedEra era -> m (Era era))
-> DeprecatedEra era -> m (Era era)
forall a b. (a -> b) -> a -> b
$ ShelleyBasedEra era -> DeprecatedEra era
forall era. ShelleyBasedEra era -> DeprecatedEra era
DeprecatedEra ShelleyBasedEra era
e
sbeToEra e :: ShelleyBasedEra era
e@ShelleyBasedEra era
ShelleyBasedEraAllegra = DeprecatedEra era -> m (Era era)
forall a. DeprecatedEra era -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (DeprecatedEra era -> m (Era era))
-> DeprecatedEra era -> m (Era era)
forall a b. (a -> b) -> a -> b
$ ShelleyBasedEra era -> DeprecatedEra era
forall era. ShelleyBasedEra era -> DeprecatedEra era
DeprecatedEra ShelleyBasedEra era
e
sbeToEra e :: ShelleyBasedEra era
e@ShelleyBasedEra era
ShelleyBasedEraShelley = DeprecatedEra era -> m (Era era)
forall a. DeprecatedEra era -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (DeprecatedEra era -> m (Era era))
-> DeprecatedEra era -> m (Era era)
forall a b. (a -> b) -> a -> b
$ ShelleyBasedEra era -> DeprecatedEra era
forall era. ShelleyBasedEra era -> DeprecatedEra era
DeprecatedEra ShelleyBasedEra era
e

{-# DEPRECATED babbageEraOnwardsToEra "Use 'convert' instead." #-}
babbageEraOnwardsToEra :: BabbageEraOnwards era -> Era era
babbageEraOnwardsToEra :: forall era. BabbageEraOnwards era -> Era era
babbageEraOnwardsToEra = BabbageEraOnwards era -> Era era
forall era. BabbageEraOnwards era -> Era era
forall a (f :: a -> *) (g :: a -> *) (era :: a).
Convert f g =>
f era -> g era
convert

{-# DEPRECATED eraToBabbageEraOnwards "Use 'convert' instead." #-}
eraToBabbageEraOnwards :: Era era -> BabbageEraOnwards era
eraToBabbageEraOnwards :: forall era. Era era -> BabbageEraOnwards era
eraToBabbageEraOnwards = Era era -> BabbageEraOnwards era
forall era. Era era -> BabbageEraOnwards era
forall a (f :: a -> *) (g :: a -> *) (era :: a).
Convert f g =>
f era -> g era
convert

-------------------------------------------------------------------------

-- | Type class interface for the 'Era' type.
class IsEra era where
  useEra :: Era era

instance IsEra BabbageEra where
  useEra :: Era BabbageEra
useEra = Era BabbageEra
BabbageEra

instance IsEra ConwayEra where
  useEra :: Era ConwayEra
useEra = Era ConwayEra
ConwayEra

-- | A temporary compatibility instance, for easier conversion between experimental and old API.
instance Eon Era where
  inEonForEra :: forall a era. a -> (Era era -> a) -> CardanoEra era -> a
inEonForEra a
v Era era -> a
f = \case
    CardanoEra era
Api.ConwayEra -> Era era -> a
f Era era
Era ConwayEra
ConwayEra
    CardanoEra era
Api.BabbageEra -> Era era -> a
f Era era
Era BabbageEra
BabbageEra
    CardanoEra era
_ -> a
v

obtainCommonConstraints
  :: Era era
  -> (EraCommonConstraints era => a)
  -> a
obtainCommonConstraints :: forall era a. Era era -> (EraCommonConstraints era => a) -> a
obtainCommonConstraints Era era
BabbageEra EraCommonConstraints era => a
x = a
EraCommonConstraints era => a
x
obtainCommonConstraints Era era
ConwayEra EraCommonConstraints era => a
x = a
EraCommonConstraints era => a
x

type EraCommonConstraints era =
  ( L.AlonzoEraTx (LedgerEra era)
  , L.BabbageEraTxBody (LedgerEra era)
  , L.EraTx (LedgerEra era)
  , L.EraUTxO (LedgerEra era)
  , Ledger.EraCrypto (LedgerEra era) ~ L.StandardCrypto
  , ShelleyLedgerEra era ~ LedgerEra era
  , L.HashAnnotated (Ledger.TxBody (LedgerEra era)) EraIndependentTxBody L.StandardCrypto
  , IsEra era
  )