{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}

-- | Support for multiple (Shelley-based) eras in the ledger.
module Cardano.Ledger.Era
  ( Era,
    Crypto,
    PreviousEra,
    TranslationContext,
    TranslateEra (..),
    translateEra',
    translateEraMaybe,
  )
where

import qualified Cardano.Ledger.Crypto as CryptoClass
import Control.Monad.Except (Except, runExcept)
import Data.Coerce (Coercible, coerce)
import Data.Kind (Type)
import Data.Typeable (Typeable)
import Data.Void (Void, absurd)

--------------------------------------------------------------------------------
-- Era
--------------------------------------------------------------------------------

class
  ( CryptoClass.Crypto (Crypto e),
    Typeable e
  ) =>
  Era e
  where
  type Crypto e :: Type

--------------------------------------------------------------------------------
-- Era translation
--------------------------------------------------------------------------------

-- | Map an era to its predecessor.
--
-- For example:
--
-- > type instance PreviousEra (AllegraEra c) = ShelleyEra c
type family PreviousEra era :: Type

-- | Per-era context used for 'TranslateEra'.
--
-- This context will be passed to the translation instances of /all/ types of
-- that particular era. In practice, most instances won't need the context, but
-- this approach makes the translation composable (as opposed to having a
-- separate context per type).
type family TranslationContext era :: Type

-- | Translation of types between eras, e.g., from Shelley to Allegra.
--
-- When @era@ is just a phantom type parameter, an empty standalone deriving can be used:
--
-- > newtype Foo era = Foo Int
-- >
-- > instance TranslateEra (Allegra c) Foo
--
-- Note that one could use @DerivingAnyClass@ (@deriving (TranslateEra (Allegra
-- c))@), but this would introduce an undesired coupling between the
-- era-parametric type and (a) particular era(s). The intention is to have a
-- module with orphan instances per era.
--
-- In most cases, the @era@ parameter won't be phantom, and a manual instance
-- will have to be written:
--
-- > newtype Bar era = Bar (Addr era)
-- >
-- > instance CryptoClass.Crypto c => TranslateEra (Allegra c) Bar where
-- >     translateEra ctxt = Bar <$> translateEra ctxt
-- >
-- > -- With the following instance being in scope:
-- > instance CryptoClass.Crypto c => TranslatEra (Allegra c) Addr
--
-- Note: we use 'PreviousEra' instead of @NextEra@ as an era definitely knows
-- its predecessor, but not necessarily its successor. Moreover, one could argue
-- that it makes more sense to define the translation from era A to era B where
-- era B is defined, than where era A is defined.
class (Era era, Era (PreviousEra era)) => TranslateEra era f where
  -- | Most translations should be infallible (default instance), but we leave
  -- the door open for partial translations.
  --
  -- For a partial translation, override the default type to be '()' or a
  -- concrete error type.
  type TranslationError era f :: Type

  type TranslationError era f = Void

  -- | Translate a type @f@ parameterised by the era from an era to the era
  -- after it.
  --
  -- The translation is a given the translation context of @era@.
  --
  -- A default instance is provided for when the two types are 'Coercible'.
  translateEra :: TranslationContext era -> f (PreviousEra era) -> Except (TranslationError era f) (f era)
  default translateEra ::
    Coercible (f (PreviousEra era)) (f era) =>
    TranslationContext era ->
    f (PreviousEra era) ->
    Except (TranslationError era f) (f era)
  translateEra TranslationContext era
_ = f era -> Except (TranslationError era f) (f era)
forall (m :: * -> *) a. Monad m => a -> m a
return (f era -> Except (TranslationError era f) (f era))
-> (f (PreviousEra era) -> f era)
-> f (PreviousEra era)
-> Except (TranslationError era f) (f era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (PreviousEra era) -> f era
coerce

-- | Variant of 'translateEra' for when 'TranslationError' is 'Void' and the
-- translation thus cannot fail.
translateEra' ::
  (TranslateEra era f, TranslationError era f ~ Void) =>
  TranslationContext era ->
  f (PreviousEra era) ->
  f era
translateEra' :: TranslationContext era -> f (PreviousEra era) -> f era
translateEra' TranslationContext era
ctxt = (Void -> f era) -> (f era -> f era) -> Either Void (f era) -> f era
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Void -> f era
forall a. Void -> a
absurd f era -> f era
forall a. a -> a
id (Either Void (f era) -> f era)
-> (f (PreviousEra era) -> Either Void (f era))
-> f (PreviousEra era)
-> f era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Except Void (f era) -> Either Void (f era)
forall e a. Except e a -> Either e a
runExcept (Except Void (f era) -> Either Void (f era))
-> (f (PreviousEra era) -> Except Void (f era))
-> f (PreviousEra era)
-> Either Void (f era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TranslationContext era
-> f (PreviousEra era) -> Except (TranslationError era f) (f era)
forall era (f :: * -> *).
TranslateEra era f =>
TranslationContext era
-> f (PreviousEra era) -> Except (TranslationError era f) (f era)
translateEra TranslationContext era
ctxt

-- | Variant of 'translateEra' for when 'TranslationError' is '()', converting
-- the result to a 'Maybe'.
translateEraMaybe ::
  (TranslateEra era f, TranslationError era f ~ ()) =>
  TranslationContext era ->
  f (PreviousEra era) ->
  Maybe (f era)
translateEraMaybe :: TranslationContext era -> f (PreviousEra era) -> Maybe (f era)
translateEraMaybe TranslationContext era
ctxt =
  (() -> Maybe (f era))
-> (f era -> Maybe (f era)) -> Either () (f era) -> Maybe (f era)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe (f era) -> () -> Maybe (f era)
forall a b. a -> b -> a
const Maybe (f era)
forall a. Maybe a
Nothing) f era -> Maybe (f era)
forall a. a -> Maybe a
Just (Either () (f era) -> Maybe (f era))
-> (f (PreviousEra era) -> Either () (f era))
-> f (PreviousEra era)
-> Maybe (f era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Except () (f era) -> Either () (f era)
forall e a. Except e a -> Either e a
runExcept (Except () (f era) -> Either () (f era))
-> (f (PreviousEra era) -> Except () (f era))
-> f (PreviousEra era)
-> Either () (f era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TranslationContext era
-> f (PreviousEra era) -> Except (TranslationError era f) (f era)
forall era (f :: * -> *).
TranslateEra era f =>
TranslationContext era
-> f (PreviousEra era) -> Except (TranslationError era f) (f era)
translateEra TranslationContext era
ctxt