{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE EmptyDataDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
#if __GLASGOW_HASKELL__ >= 908
{-# OPTIONS_GHC -Wno-x-unsafe-ledger-internal #-}
#endif

module Cardano.Ledger.Core.Era (
  -- * Era
  Era (..),
  ByronEra,

  -- ** Rules
  EraRule,
  EraRuleFailure,
  EraRuleEvent,
  VoidEraRule,
  absurdEraRule,
  InjectRuleFailure (..),
  InjectRuleEvent (..),

  -- ** Protocol Version
  AtMostEra,
  AtLeastEra,
  ExactEra,
  ProtVerAtMost,
  ProtVerAtLeast,
  ProtVerInBounds,
  atLeastEra,
  atMostEra,
  notSupportedInThisEra,
  notSupportedInThisEraL,
  eraProtVerLow,
  eraProtVerHigh,
  eraProtVersions,
  toEraCBOR,
  fromEraCBOR,
  fromEraShareCBOR,
  eraDecoder,
  eraDecoderWithBytes,
) where

import Cardano.Ledger.Binary
import qualified Cardano.Ledger.Binary.Plain as Plain
import Cardano.Ledger.Internal.Era (ByronEra, Era (..), EraFromName)
import Control.DeepSeq (NFData (..))
import Control.State.Transition.Extended (PredicateFailure, STS (..))
import qualified Data.ByteString.Lazy as BSL
import Data.Kind (Constraint, Type)
import GHC.Stack (HasCallStack)
import GHC.TypeLits
import Lens.Micro

-----------------------------
-- Rules --------------------
-----------------------------

-- | Era STS map
type family EraRule (rule :: Symbol) era = (r :: Type) | r -> rule

-- | `EraRuleFailure` type family is needed for injectivity, which STS' `PredicateFailure`
-- does not provide for us unfortunately.
type family EraRuleFailure (rule :: Symbol) era = (r :: Type) | r -> rule era

type family EraRuleEvent (rule :: Symbol) era = (r :: Type) | r -> rule era

-- | This is a type with no inhabitans for the rules. It is used to indicate that a rule
-- does not have a predicate failure as well as marking rules that have been disabled when
-- comparing to prior eras.
data VoidEraRule (rule :: Symbol) era
  deriving (Int -> VoidEraRule rule era -> ShowS
[VoidEraRule rule era] -> ShowS
VoidEraRule rule era -> String
(Int -> VoidEraRule rule era -> ShowS)
-> (VoidEraRule rule era -> String)
-> ([VoidEraRule rule era] -> ShowS)
-> Show (VoidEraRule rule era)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (rule :: Symbol) era. Int -> VoidEraRule rule era -> ShowS
forall (rule :: Symbol) era. [VoidEraRule rule era] -> ShowS
forall (rule :: Symbol) era. VoidEraRule rule era -> String
$cshowsPrec :: forall (rule :: Symbol) era. Int -> VoidEraRule rule era -> ShowS
showsPrec :: Int -> VoidEraRule rule era -> ShowS
$cshow :: forall (rule :: Symbol) era. VoidEraRule rule era -> String
show :: VoidEraRule rule era -> String
$cshowList :: forall (rule :: Symbol) era. [VoidEraRule rule era] -> ShowS
showList :: [VoidEraRule rule era] -> ShowS
Show, VoidEraRule rule era -> VoidEraRule rule era -> Bool
(VoidEraRule rule era -> VoidEraRule rule era -> Bool)
-> (VoidEraRule rule era -> VoidEraRule rule era -> Bool)
-> Eq (VoidEraRule rule era)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (rule :: Symbol) era.
VoidEraRule rule era -> VoidEraRule rule era -> Bool
$c== :: forall (rule :: Symbol) era.
VoidEraRule rule era -> VoidEraRule rule era -> Bool
== :: VoidEraRule rule era -> VoidEraRule rule era -> Bool
$c/= :: forall (rule :: Symbol) era.
VoidEraRule rule era -> VoidEraRule rule era -> Bool
/= :: VoidEraRule rule era -> VoidEraRule rule era -> Bool
Eq, Eq (VoidEraRule rule era)
Eq (VoidEraRule rule era) =>
(VoidEraRule rule era -> VoidEraRule rule era -> Ordering)
-> (VoidEraRule rule era -> VoidEraRule rule era -> Bool)
-> (VoidEraRule rule era -> VoidEraRule rule era -> Bool)
-> (VoidEraRule rule era -> VoidEraRule rule era -> Bool)
-> (VoidEraRule rule era -> VoidEraRule rule era -> Bool)
-> (VoidEraRule rule era
    -> VoidEraRule rule era -> VoidEraRule rule era)
-> (VoidEraRule rule era
    -> VoidEraRule rule era -> VoidEraRule rule era)
-> Ord (VoidEraRule rule era)
VoidEraRule rule era -> VoidEraRule rule era -> Bool
VoidEraRule rule era -> VoidEraRule rule era -> Ordering
VoidEraRule rule era
-> VoidEraRule rule era -> VoidEraRule rule era
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall (rule :: Symbol) era. Eq (VoidEraRule rule era)
forall (rule :: Symbol) era.
VoidEraRule rule era -> VoidEraRule rule era -> Bool
forall (rule :: Symbol) era.
VoidEraRule rule era -> VoidEraRule rule era -> Ordering
forall (rule :: Symbol) era.
VoidEraRule rule era
-> VoidEraRule rule era -> VoidEraRule rule era
$ccompare :: forall (rule :: Symbol) era.
VoidEraRule rule era -> VoidEraRule rule era -> Ordering
compare :: VoidEraRule rule era -> VoidEraRule rule era -> Ordering
$c< :: forall (rule :: Symbol) era.
VoidEraRule rule era -> VoidEraRule rule era -> Bool
< :: VoidEraRule rule era -> VoidEraRule rule era -> Bool
$c<= :: forall (rule :: Symbol) era.
VoidEraRule rule era -> VoidEraRule rule era -> Bool
<= :: VoidEraRule rule era -> VoidEraRule rule era -> Bool
$c> :: forall (rule :: Symbol) era.
VoidEraRule rule era -> VoidEraRule rule era -> Bool
> :: VoidEraRule rule era -> VoidEraRule rule era -> Bool
$c>= :: forall (rule :: Symbol) era.
VoidEraRule rule era -> VoidEraRule rule era -> Bool
>= :: VoidEraRule rule era -> VoidEraRule rule era -> Bool
$cmax :: forall (rule :: Symbol) era.
VoidEraRule rule era
-> VoidEraRule rule era -> VoidEraRule rule era
max :: VoidEraRule rule era
-> VoidEraRule rule era -> VoidEraRule rule era
$cmin :: forall (rule :: Symbol) era.
VoidEraRule rule era
-> VoidEraRule rule era -> VoidEraRule rule era
min :: VoidEraRule rule era
-> VoidEraRule rule era -> VoidEraRule rule era
Ord)

instance NFData (VoidEraRule (rule :: Symbol) era) where
  rnf :: VoidEraRule rule era -> ()
rnf = VoidEraRule rule era -> ()
forall (rule :: Symbol) era a. VoidEraRule rule era -> a
absurdEraRule

instance (KnownSymbol rule, Era era) => ToCBOR (VoidEraRule (rule :: Symbol) era) where
  toCBOR :: VoidEraRule rule era -> Encoding
toCBOR = VoidEraRule rule era -> Encoding
forall (rule :: Symbol) era a. VoidEraRule rule era -> a
absurdEraRule

instance (KnownSymbol rule, Era era) => EncCBOR (VoidEraRule (rule :: Symbol) era)

instance (KnownSymbol rule, Era era) => FromCBOR (VoidEraRule (rule :: Symbol) era) where
  fromCBOR :: forall s. Decoder s (VoidEraRule rule era)
fromCBOR = DecoderError -> Decoder s (VoidEraRule rule era)
forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError DecoderError
DecoderErrorVoid

instance (KnownSymbol rule, Era era) => DecCBOR (VoidEraRule (rule :: Symbol) era)

absurdEraRule :: VoidEraRule rule era -> a
absurdEraRule :: forall (rule :: Symbol) era a. VoidEraRule rule era -> a
absurdEraRule VoidEraRule rule era
a = case VoidEraRule rule era
a of {}

-- Rules that must never have a predicate failures
type instance EraRuleFailure "EPOCH" era = VoidEraRule "EPOCH" era

type instance EraRuleFailure "NEWEPOCH" era = VoidEraRule "NEWEPOCH" era

type instance EraRuleFailure "MIR" era = VoidEraRule "MIR" era

type instance EraRuleFailure "NEWPP" era = VoidEraRule "NEWPP" era

type instance EraRuleFailure "SNAP" era = VoidEraRule "SNAP" era

type instance EraRuleFailure "TICK" era = VoidEraRule "TICK" era

type instance EraRuleFailure "TICKF" era = VoidEraRule "TICKF" era

type instance EraRuleFailure "UPEC" era = VoidEraRule "UPEC" era

type instance EraRuleFailure "RUPD" era = VoidEraRule "RUPD" era

type instance EraRuleFailure "POOLREAP" era = VoidEraRule "POOLREAP" era

class
  EraRuleFailure rule era ~ PredicateFailure (EraRule rule era) =>
  InjectRuleFailure (rule :: Symbol) t era
  where
  injectFailure :: t era -> EraRuleFailure rule era
  default injectFailure :: t era ~ EraRuleFailure rule era => t era -> EraRuleFailure rule era
  injectFailure = t era -> t era
t era -> EraRuleFailure rule era
forall a. a -> a
id

class
  EraRuleEvent rule era ~ Event (EraRule rule era) =>
  InjectRuleEvent (rule :: Symbol) t era
  where
  injectEvent :: t era -> EraRuleEvent rule era
  default injectEvent :: t era ~ EraRuleEvent rule era => t era -> EraRuleEvent rule era
  injectEvent = t era -> t era
t era -> EraRuleEvent rule era
forall a. a -> a
id

-----------------------------
-- Protocol version bounds --
-----------------------------

type family ProtVerIsInBounds (check :: Symbol) era (v :: Nat) (b :: Bool) :: Constraint where
  ProtVerIsInBounds check era v 'True = ()
  ProtVerIsInBounds check era v 'False =
    TypeError
      ( 'ShowType era
          ':<>: 'Text " protocol version bounds are: ["
          ':<>: 'ShowType (ProtVerLow era)
          ':<>: 'Text ", "
          ':<>: 'ShowType (ProtVerHigh era)
          ':<>: 'Text "], but required is "
          ':<>: 'Text check
          ':<>: 'Text " "
          ':<>: 'ShowType v
      )

-- | Requirement for the era's highest protocol version to be higher or equal to
-- the supplied value
type family ProtVerAtLeast era (l :: Nat) :: Constraint where
  ProtVerAtLeast era l = ProtVerIsInBounds "at least" era l (l <=? ProtVerHigh era)

-- | Requirement for the era's lowest protocol version to be lower or equal to
-- the supplied value
type family ProtVerAtMost era (h :: Nat) :: Constraint where
  ProtVerAtMost era h = ProtVerIsInBounds "at most" era h (ProtVerLow era <=? h)

-- | Restrict a lower and upper bounds of the protocol version for the particular era
type ProtVerInBounds era l h = (ProtVerAtLeast era l, ProtVerAtMost era h)

-- | Restrict an era to the specific era through the protocol version. This is
-- equivalent to @(inEra (Crypto era) ~ era)@
type ExactEra inEra era =
  ProtVerInBounds era (ProtVerLow inEra) (ProtVerHigh inEra)

-- | Restrict the @era@ to equal to @atLeastEra@ or come after it
type AtLeastEra (atLeastEra :: Symbol) era =
  ProtVerAtLeast era (ProtVerLow (EraFromName atLeastEra))

-- | Restrict the @era@ to equal to @eraName@ or come before it.
type AtMostEra (eraMostEra :: Symbol) era =
  ProtVerAtMost era (ProtVerHigh (EraFromName eraMostEra))

-- | Get the value level `Version` of the lowest major protocol version for the supplied @era@.
eraProtVerLow :: forall era. Era era => Version
eraProtVerLow :: forall era. Era era => Version
eraProtVerLow = forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @(ProtVerLow era)

-- | Get the value level `Version` of the highest major protocol version for the supplied @era@.
eraProtVerHigh :: forall era. Era era => Version
eraProtVerHigh :: forall era. Era era => Version
eraProtVerHigh = forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @(ProtVerHigh era)

-- | List with all major versions that are used in the particular era.
eraProtVersions :: forall era. Era era => [Version]
eraProtVersions :: forall era. Era era => [Version]
eraProtVersions = [forall era. Era era => Version
eraProtVerLow @era .. forall era. Era era => Version
eraProtVerHigh @era]

-- | Enforce era to be at least the specified era at the type level. In other words
-- compiler will produce type error when applied to eras prior to the specified era.
-- This function should be used in order to avoid redundant constraints warning.
--
-- For example these will type check
--
-- > atLeastEra @"Babbage" @ConwayEra
-- > atLeastEra @"Babbage" @BabbageEra
--
-- However this will result in a type error
--
-- > atLeastEra @"Babbage" @AlonzoEra
atLeastEra :: AtLeastEra eraName era => ()
atLeastEra :: forall (eraName :: Symbol) era. AtLeastEra eraName era => ()
atLeastEra = ()

-- | Enforce era to be at most the specified era at the type level. In other words
-- compiler will produce type error when applied to eras prior to the specified era.
-- This function should be used in order to avoid redundant constraints warning.
--
-- For example these will type check
--
-- > atMostEra @BabbageEra @ShelleyEra
-- > atMostEra @AlonzoEra @MaryEra
--
-- However this will result in a type error
--
-- > atMostEra @BabbageEra @ConwayEra
atMostEra :: AtMostEra eraName era => ()
atMostEra :: forall (eraName :: Symbol) era. AtMostEra eraName era => ()
atMostEra = ()

notSupportedInThisEra :: HasCallStack => a
notSupportedInThisEra :: forall a. HasCallStack => a
notSupportedInThisEra = String -> a
forall a. HasCallStack => String -> a
error String
"Impossible: Function is not supported in this era"

-- Without using `lens` we hit a ghc bug, which results in a redundant constraint warning
notSupportedInThisEraL :: HasCallStack => Lens' a b
notSupportedInThisEraL :: forall a b. HasCallStack => Lens' a b
notSupportedInThisEraL = (a -> b) -> (a -> b -> a) -> Lens a a b b
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens a -> b
forall a. HasCallStack => a
notSupportedInThisEra a -> b -> a
forall a. HasCallStack => a
notSupportedInThisEra

-- | Convert a type that implements `EncCBOR` to plain `Plain.Encoding` using the lowest
-- protocol version for the supplied @era@.
toEraCBOR :: forall era t. (Era era, EncCBOR t) => t -> Plain.Encoding
toEraCBOR :: forall era t. (Era era, EncCBOR t) => t -> Encoding
toEraCBOR = Version -> Encoding -> Encoding
toPlainEncoding (forall era. Era era => Version
eraProtVerLow @era) (Encoding -> Encoding) -> (t -> Encoding) -> t -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR
{-# INLINE toEraCBOR #-}

-- | Convert a type that implements `DecCBOR` to plain `Plain.Decoder` using the lowest
-- protocol version for the supplied @era@
--
-- This action should not be used for decoders that require access to original bytes, use
-- `toPlainDecoder` instead.
fromEraCBOR :: forall era t s. (Era era, DecCBOR t) => Plain.Decoder s t
fromEraCBOR :: forall era t s. (Era era, DecCBOR t) => Decoder s t
fromEraCBOR = forall era t s. Era era => Decoder s t -> Decoder s t
eraDecoder @era Decoder s t
forall s. Decoder s t
forall a s. DecCBOR a => Decoder s a
decCBOR
{-# INLINE fromEraCBOR #-}

-- | Convert a type that implements `DecShareCBOR` to plain `Plain.Decoder` using the lowest
-- protocol version for the supplied @era@
--
-- This action should not be used for decoders that require access to original bytes, use
-- `toPlainDecoder` instead.
fromEraShareCBOR :: forall era t s. (Era era, DecShareCBOR t) => Plain.Decoder s t
fromEraShareCBOR :: forall era t s. (Era era, DecShareCBOR t) => Decoder s t
fromEraShareCBOR = forall era t s. Era era => Decoder s t -> Decoder s t
eraDecoder @era Decoder s t
forall a s. DecShareCBOR a => Decoder s a
decNoShareCBOR
{-# INLINE fromEraShareCBOR #-}

-- | Convert a versioned `Decoder` to plain a `Plain.Decoder` using the lowest protocol
-- version for the supplied @era@
--
-- This action should not be used for decoders that require access to original bytes, use
-- `eraDecoderWithBytes` instead.
eraDecoder :: forall era t s. Era era => Decoder s t -> Plain.Decoder s t
eraDecoder :: forall era t s. Era era => Decoder s t -> Decoder s t
eraDecoder = Maybe ByteString -> Version -> Decoder s t -> Decoder s t
forall s a.
Maybe ByteString -> Version -> Decoder s a -> Decoder s a
toPlainDecoder Maybe ByteString
forall a. Maybe a
Nothing (forall era. Era era => Version
eraProtVerLow @era)
{-# INLINE eraDecoder #-}

-- | Just like `eraDecoder`, but for decoders that rely on access for underlying bytes
eraDecoderWithBytes :: forall era t s. Era era => BSL.ByteString -> Decoder s t -> Plain.Decoder s t
eraDecoderWithBytes :: forall era t s. Era era => ByteString -> Decoder s t -> Decoder s t
eraDecoderWithBytes ByteString
bsl = Maybe ByteString -> Version -> Decoder s t -> Decoder s t
forall s a.
Maybe ByteString -> Version -> Decoder s a -> Decoder s a
toPlainDecoder (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
bsl) (forall era. Era era => Version
eraProtVerLow @era)
{-# INLINE eraDecoderWithBytes #-}