{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}

module Cardano.Slotting.EpochInfo.API (
  EpochInfo (..),
  epochInfoSize,
  epochInfoFirst,
  epochInfoEpoch,
  epochInfoRange,
  epochInfoSlotToRelativeTime,
  epochInfoSlotToUTCTime,
  epochInfoSlotLength,

  -- * Utility
  hoistEpochInfo,
  generalizeEpochInfo,
)
where

import Cardano.Slotting.Slot (EpochNo (..), EpochSize (..), SlotNo (..))
import Cardano.Slotting.Time (RelativeTime, SlotLength, SystemStart, fromRelativeTime)
import Control.Monad.Morph (generalize)
import Data.Functor.Identity
import Data.Time.Clock (UTCTime)
import GHC.Stack (HasCallStack)
import NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..))

-- | Information about epochs
--
-- Different epochs may have different sizes and different slot lengths. This
-- information is encapsulated by 'EpochInfo'. It is parameterized over a monad
-- @m@ because the information about how long each epoch is may depend on
-- information derived from the blockchain itself. It ultimately requires acess
-- to state, and so either uses the monad for that or uses the monad to reify
-- failure due to cached state information being too stale for the current
-- query.
data EpochInfo m
  = EpochInfo
  { forall (m :: * -> *).
EpochInfo m -> HasCallStack => EpochNo -> m EpochSize
epochInfoSize_ :: HasCallStack => EpochNo -> m EpochSize
  -- ^ Return the size of the given epoch as a number of slots
  --
  -- Note that the number of slots does /not/ bound the number of blocks,
  -- since the EBB and a regular block share a slot number.
  , forall (m :: * -> *).
EpochInfo m -> HasCallStack => EpochNo -> m SlotNo
epochInfoFirst_ :: HasCallStack => EpochNo -> m SlotNo
  -- ^ First slot in the specified epoch
  --
  -- See also 'epochInfoRange'
  , forall (m :: * -> *).
EpochInfo m -> HasCallStack => SlotNo -> m EpochNo
epochInfoEpoch_ :: HasCallStack => SlotNo -> m EpochNo
  -- ^ Epoch containing the given slot
  --
  -- We should have the property that
  --
  -- > s `inRange` epochInfoRange (epochInfoEpoch s)
  , forall (m :: * -> *).
EpochInfo m -> HasCallStack => SlotNo -> m RelativeTime
epochInfoSlotToRelativeTime_ ::
      HasCallStack =>
      SlotNo -> m RelativeTime
  -- ^ The 'RelativeTime' of the start of the given slot
  --
  -- This calculation depends on the varying slot lengths of the relevant
  -- epochs.
  --
  -- See also 'epochInfoSlotToUTCTime'.
  , forall (m :: * -> *).
EpochInfo m -> HasCallStack => SlotNo -> m SlotLength
epochInfoSlotLength_ ::
      HasCallStack =>
      SlotNo -> m SlotLength
  -- ^ Return the length of the specified slot.
  }
  deriving (Context -> EpochInfo m -> IO (Maybe ThunkInfo)
Proxy (EpochInfo m) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall (m :: * -> *).
Context -> EpochInfo m -> IO (Maybe ThunkInfo)
forall (m :: * -> *). Proxy (EpochInfo m) -> String
showTypeOf :: Proxy (EpochInfo m) -> String
$cshowTypeOf :: forall (m :: * -> *). Proxy (EpochInfo m) -> String
wNoThunks :: Context -> EpochInfo m -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (m :: * -> *).
Context -> EpochInfo m -> IO (Maybe ThunkInfo)
noThunks :: Context -> EpochInfo m -> IO (Maybe ThunkInfo)
$cnoThunks :: forall (m :: * -> *).
Context -> EpochInfo m -> IO (Maybe ThunkInfo)
NoThunks) via OnlyCheckWhnfNamed "EpochInfo" (EpochInfo m)

-- | Unhelpful instance, but this type occurs in records (eg @Shelley.Globals@)
-- that we want to be able to 'show'
instance Show (EpochInfo f) where
  showsPrec :: Int -> EpochInfo f -> ShowS
showsPrec Int
_ EpochInfo f
_ = String -> ShowS
showString String
"EpochInfoHasNoUsefulShowInstance"

epochInfoRange :: Monad m => EpochInfo m -> EpochNo -> m (SlotNo, SlotNo)
epochInfoRange :: forall (m :: * -> *).
Monad m =>
EpochInfo m -> EpochNo -> m (SlotNo, SlotNo)
epochInfoRange EpochInfo m
epochInfo EpochNo
epochNo =
  SlotNo -> EpochSize -> (SlotNo, SlotNo)
aux
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
HasCallStack =>
EpochInfo m -> EpochNo -> m SlotNo
epochInfoFirst EpochInfo m
epochInfo EpochNo
epochNo
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *).
HasCallStack =>
EpochInfo m -> EpochNo -> m EpochSize
epochInfoSize EpochInfo m
epochInfo EpochNo
epochNo
  where
    aux :: SlotNo -> EpochSize -> (SlotNo, SlotNo)
    aux :: SlotNo -> EpochSize -> (SlotNo, SlotNo)
aux (SlotNo Word64
s) (EpochSize Word64
sz) = (Word64 -> SlotNo
SlotNo Word64
s, Word64 -> SlotNo
SlotNo (Word64
s forall a. Num a => a -> a -> a
+ Word64
sz forall a. Num a => a -> a -> a
- Word64
1))

-- | The start of the given slot
epochInfoSlotToUTCTime ::
  (HasCallStack, Monad m) =>
  EpochInfo m ->
  SystemStart ->
  SlotNo ->
  m UTCTime
epochInfoSlotToUTCTime :: forall (m :: * -> *).
(HasCallStack, Monad m) =>
EpochInfo m -> SystemStart -> SlotNo -> m UTCTime
epochInfoSlotToUTCTime EpochInfo m
ei SystemStart
start SlotNo
sl =
  SystemStart -> RelativeTime -> UTCTime
fromRelativeTime SystemStart
start forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
HasCallStack =>
EpochInfo m -> SlotNo -> m RelativeTime
epochInfoSlotToRelativeTime EpochInfo m
ei SlotNo
sl

{-------------------------------------------------------------------------------
  Extraction functions that preserve the HasCallStack constraint

  (Ideally, ghc would just do this..)
-------------------------------------------------------------------------------}

epochInfoSize :: HasCallStack => EpochInfo m -> EpochNo -> m EpochSize
epochInfoSize :: forall (m :: * -> *).
HasCallStack =>
EpochInfo m -> EpochNo -> m EpochSize
epochInfoSize = forall (m :: * -> *).
EpochInfo m -> HasCallStack => EpochNo -> m EpochSize
epochInfoSize_

epochInfoFirst :: HasCallStack => EpochInfo m -> EpochNo -> m SlotNo
epochInfoFirst :: forall (m :: * -> *).
HasCallStack =>
EpochInfo m -> EpochNo -> m SlotNo
epochInfoFirst = forall (m :: * -> *).
EpochInfo m -> HasCallStack => EpochNo -> m SlotNo
epochInfoFirst_

epochInfoEpoch :: HasCallStack => EpochInfo m -> SlotNo -> m EpochNo
epochInfoEpoch :: forall (m :: * -> *).
HasCallStack =>
EpochInfo m -> SlotNo -> m EpochNo
epochInfoEpoch = forall (m :: * -> *).
EpochInfo m -> HasCallStack => SlotNo -> m EpochNo
epochInfoEpoch_

epochInfoSlotToRelativeTime ::
  HasCallStack => EpochInfo m -> SlotNo -> m RelativeTime
epochInfoSlotToRelativeTime :: forall (m :: * -> *).
HasCallStack =>
EpochInfo m -> SlotNo -> m RelativeTime
epochInfoSlotToRelativeTime = forall (m :: * -> *).
EpochInfo m -> HasCallStack => SlotNo -> m RelativeTime
epochInfoSlotToRelativeTime_

epochInfoSlotLength ::
  HasCallStack => EpochInfo m -> SlotNo -> m SlotLength
epochInfoSlotLength :: forall (m :: * -> *).
HasCallStack =>
EpochInfo m -> SlotNo -> m SlotLength
epochInfoSlotLength = forall (m :: * -> *).
EpochInfo m -> HasCallStack => SlotNo -> m SlotLength
epochInfoSlotLength_

{-------------------------------------------------------------------------------
  Utility
-------------------------------------------------------------------------------}

hoistEpochInfo :: (forall a. m a -> n a) -> EpochInfo m -> EpochInfo n
hoistEpochInfo :: forall (m :: * -> *) (n :: * -> *).
(forall a. m a -> n a) -> EpochInfo m -> EpochInfo n
hoistEpochInfo forall a. m a -> n a
f EpochInfo m
ei =
  EpochInfo
    { epochInfoSize_ :: HasCallStack => EpochNo -> n EpochSize
epochInfoSize_ = forall a. m a -> n a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
HasCallStack =>
EpochInfo m -> EpochNo -> m EpochSize
epochInfoSize EpochInfo m
ei
    , epochInfoFirst_ :: HasCallStack => EpochNo -> n SlotNo
epochInfoFirst_ = forall a. m a -> n a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
HasCallStack =>
EpochInfo m -> EpochNo -> m SlotNo
epochInfoFirst EpochInfo m
ei
    , epochInfoEpoch_ :: HasCallStack => SlotNo -> n EpochNo
epochInfoEpoch_ = forall a. m a -> n a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
HasCallStack =>
EpochInfo m -> SlotNo -> m EpochNo
epochInfoEpoch EpochInfo m
ei
    , epochInfoSlotToRelativeTime_ :: HasCallStack => SlotNo -> n RelativeTime
epochInfoSlotToRelativeTime_ = forall a. m a -> n a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
HasCallStack =>
EpochInfo m -> SlotNo -> m RelativeTime
epochInfoSlotToRelativeTime EpochInfo m
ei
    , epochInfoSlotLength_ :: HasCallStack => SlotNo -> n SlotLength
epochInfoSlotLength_ = forall a. m a -> n a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
HasCallStack =>
EpochInfo m -> SlotNo -> m SlotLength
epochInfoSlotLength EpochInfo m
ei
    }

generalizeEpochInfo :: Monad m => EpochInfo Identity -> EpochInfo m
generalizeEpochInfo :: forall (m :: * -> *). Monad m => EpochInfo Identity -> EpochInfo m
generalizeEpochInfo = forall (m :: * -> *) (n :: * -> *).
(forall a. m a -> n a) -> EpochInfo m -> EpochInfo n
hoistEpochInfo forall (m :: * -> *) a. Monad m => Identity a -> m a
generalize