{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Derive 'EpochInfo'
module Ouroboros.Consensus.HardFork.History.EpochInfo (
    summaryToEpochInfo
  , snapshotEpochInfo
  , dummyEpochInfo
  ) where

import           Data.Functor.Identity
import           GHC.Stack

import           Cardano.Slotting.EpochInfo.API

import           Ouroboros.Consensus.Util.IOLike

import           Ouroboros.Consensus.HardFork.History.Caching
import           Ouroboros.Consensus.HardFork.History.Qry
import           Ouroboros.Consensus.HardFork.History.Summary

{-------------------------------------------------------------------------------
  Translation to EpochInfo
-------------------------------------------------------------------------------}

-- | Construct 'EpochInfo' from a function that returns the hard fork summary
--
-- When a particular request fails with a 'PastHorizon' error, we ask for an
-- updated summary, in the hope that the ledger state has advanced. If the query
-- /still/ fails with that updated summary, the error is thrown as an exception.
summaryToEpochInfo :: forall m xs. (MonadSTM m, MonadThrow (STM m))
                   => STM m (Summary xs) -> m (EpochInfo (STM m))
summaryToEpochInfo :: STM m (Summary xs) -> m (EpochInfo (STM m))
summaryToEpochInfo =
    (RunWithCachedSummary xs m -> EpochInfo (STM m))
-> m (RunWithCachedSummary xs m) -> m (EpochInfo (STM m))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RunWithCachedSummary xs m -> EpochInfo (STM m)
go (m (RunWithCachedSummary xs m) -> m (EpochInfo (STM m)))
-> (STM m (Summary xs) -> m (RunWithCachedSummary xs m))
-> STM m (Summary xs)
-> m (EpochInfo (STM m))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM m (Summary xs) -> m (RunWithCachedSummary xs m)
forall (m :: * -> *) (xs :: [*]).
MonadSTM m =>
STM m (Summary xs) -> m (RunWithCachedSummary xs m)
runWithCachedSummary
  where
    go :: RunWithCachedSummary xs m -> EpochInfo (STM m)
    go :: RunWithCachedSummary xs m -> EpochInfo (STM m)
go RunWithCachedSummary xs m
run = EpochInfo :: forall (m :: * -> *).
(HasCallStack => EpochNo -> m EpochSize)
-> (HasCallStack => EpochNo -> m SlotNo)
-> (HasCallStack => SlotNo -> m EpochNo)
-> EpochInfo m
EpochInfo {
          epochInfoSize_ :: HasCallStack => EpochNo -> STM m EpochSize
epochInfoSize_  = \EpochNo
e -> RunWithCachedSummary xs m -> Qry EpochSize -> STM m EpochSize
forall (m :: * -> *) (xs :: [*]) a.
(MonadSTM m, MonadThrow (STM m)) =>
RunWithCachedSummary xs m -> Qry a -> STM m a
cachedRunQueryThrow RunWithCachedSummary xs m
run (EpochNo -> Qry EpochSize
epochToSize  EpochNo
e)
        , epochInfoFirst_ :: HasCallStack => EpochNo -> STM m SlotNo
epochInfoFirst_ = \EpochNo
e -> RunWithCachedSummary xs m -> Qry SlotNo -> STM m SlotNo
forall (m :: * -> *) (xs :: [*]) a.
(MonadSTM m, MonadThrow (STM m)) =>
RunWithCachedSummary xs m -> Qry a -> STM m a
cachedRunQueryThrow RunWithCachedSummary xs m
run (EpochNo -> Qry SlotNo
epochToSlot' EpochNo
e)
        , epochInfoEpoch_ :: HasCallStack => SlotNo -> STM m EpochNo
epochInfoEpoch_ = \SlotNo
s -> RunWithCachedSummary xs m -> Qry EpochNo -> STM m EpochNo
forall (m :: * -> *) (xs :: [*]) a.
(MonadSTM m, MonadThrow (STM m)) =>
RunWithCachedSummary xs m -> Qry a -> STM m a
cachedRunQueryThrow RunWithCachedSummary xs m
run ((EpochNo, Word64) -> EpochNo
forall a b. (a, b) -> a
fst ((EpochNo, Word64) -> EpochNo)
-> Qry (EpochNo, Word64) -> Qry EpochNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SlotNo -> Qry (EpochNo, Word64)
slotToEpoch' SlotNo
s)
        }

-- | Construct an 'EpochInfo' for a /snapshot/ of the ledger state
--
-- When a particular request fails with a 'PastHorizon' error, we throw the
-- error as a /pure/ exception. Such an exception would indicate a bug.
snapshotEpochInfo :: forall xs. Summary xs -> EpochInfo Identity
snapshotEpochInfo :: Summary xs -> EpochInfo Identity
snapshotEpochInfo Summary xs
summary = EpochInfo :: forall (m :: * -> *).
(HasCallStack => EpochNo -> m EpochSize)
-> (HasCallStack => EpochNo -> m SlotNo)
-> (HasCallStack => SlotNo -> m EpochNo)
-> EpochInfo m
EpochInfo {
      epochInfoSize_ :: HasCallStack => EpochNo -> Identity EpochSize
epochInfoSize_  = \EpochNo
e -> Qry EpochSize -> Identity EpochSize
forall a. HasCallStack => Qry a -> Identity a
runQueryPure' (EpochNo -> Qry EpochSize
epochToSize  EpochNo
e)
    , epochInfoFirst_ :: HasCallStack => EpochNo -> Identity SlotNo
epochInfoFirst_ = \EpochNo
e -> Qry SlotNo -> Identity SlotNo
forall a. HasCallStack => Qry a -> Identity a
runQueryPure' (EpochNo -> Qry SlotNo
epochToSlot' EpochNo
e)
    , epochInfoEpoch_ :: HasCallStack => SlotNo -> Identity EpochNo
epochInfoEpoch_ = \SlotNo
s -> Qry EpochNo -> Identity EpochNo
forall a. HasCallStack => Qry a -> Identity a
runQueryPure' ((EpochNo, Word64) -> EpochNo
forall a b. (a, b) -> a
fst ((EpochNo, Word64) -> EpochNo)
-> Qry (EpochNo, Word64) -> Qry EpochNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SlotNo -> Qry (EpochNo, Word64)
slotToEpoch' SlotNo
s)
    }
  where
    runQueryPure' :: HasCallStack => Qry a -> Identity a
    runQueryPure' :: Qry a -> Identity a
runQueryPure' = a -> Identity a
forall a. a -> Identity a
Identity (a -> Identity a) -> (Qry a -> a) -> Qry a -> Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Qry a -> Summary xs -> a) -> Summary xs -> Qry a -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Qry a -> Summary xs -> a
forall a (xs :: [*]). HasCallStack => Qry a -> Summary xs -> a
runQueryPure Summary xs
summary

-- | A dummy 'EpochInfo' that always throws an 'error'.
--
-- To be used as a placeholder before a summary is available.
dummyEpochInfo :: EpochInfo Identity
dummyEpochInfo :: EpochInfo Identity
dummyEpochInfo = EpochInfo :: forall (m :: * -> *).
(HasCallStack => EpochNo -> m EpochSize)
-> (HasCallStack => EpochNo -> m SlotNo)
-> (HasCallStack => SlotNo -> m EpochNo)
-> EpochInfo m
EpochInfo {
      epochInfoSize_ :: HasCallStack => EpochNo -> Identity EpochSize
epochInfoSize_  = \EpochNo
_ -> [Char] -> Identity EpochSize
forall a. HasCallStack => [Char] -> a
error [Char]
"dummyEpochInfo used"
    , epochInfoFirst_ :: HasCallStack => EpochNo -> Identity SlotNo
epochInfoFirst_ = \EpochNo
_ -> [Char] -> Identity SlotNo
forall a. HasCallStack => [Char] -> a
error [Char]
"dummyEpochInfo used"
    , epochInfoEpoch_ :: HasCallStack => SlotNo -> Identity EpochNo
epochInfoEpoch_ = \SlotNo
_ -> [Char] -> Identity EpochNo
forall a. HasCallStack => [Char] -> a
error [Char]
"dummyEpochInfo used"
    }