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

module Ouroboros.Consensus.HardFork.History.Caching
  ( RunWithCachedSummary (..)
  , runWithCachedSummary
  ) where

import Data.Kind (Type)
import Ouroboros.Consensus.HardFork.History.Qry
import Ouroboros.Consensus.HardFork.History.Summary
import Ouroboros.Consensus.Util.IOLike

{-------------------------------------------------------------------------------
  Caching the summary
-------------------------------------------------------------------------------}

-- | Stateful abstraction to execute queries
data RunWithCachedSummary (xs :: [Type]) m = RunWithCachedSummary
  { forall (xs :: [*]) (m :: * -> *).
RunWithCachedSummary xs m
-> forall a. Qry a -> STM m (Either PastHorizonException a)
cachedRunQuery ::
      forall a.
      Qry a ->
      STM m (Either PastHorizonException a)
  -- ^ Run the specified query
  --
  -- If the query fails with a 'PastHorizonException', it will update its
  -- internal state (compute a new summary) and try again. If that /still/
  -- fails, the 'PastHorizonException' is returned.
  }

-- | Construct 'RunWithCachedSummary' given action that computes the summary
--
-- Most use cases will probably construct this action from an action that reads
-- the ledger state and then computes the summary from that.
runWithCachedSummary ::
  forall m xs.
  MonadSTM m =>
  STM m (Summary xs) ->
  m (RunWithCachedSummary xs m)
runWithCachedSummary :: forall (m :: * -> *) (xs :: [*]).
MonadSTM m =>
STM m (Summary xs) -> m (RunWithCachedSummary xs m)
runWithCachedSummary STM m (Summary xs)
getLatestSummary = do
  initSummary <- STM m (Summary xs) -> m (Summary xs)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m (Summary xs)
getLatestSummary
  var <- newTVarIO initSummary
  return $ RunWithCachedSummary{cachedRunQuery = go var}
 where
  go ::
    StrictTVar m (Summary xs) ->
    Qry a ->
    STM m (Either PastHorizonException a)
  go :: forall a.
StrictTVar m (Summary xs)
-> Qry a -> STM m (Either PastHorizonException a)
go StrictTVar m (Summary xs)
var Qry a
q = do
    summary <- StrictTVar m (Summary xs) -> STM m (Summary xs)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Summary xs)
var
    case runQuery q summary of
      Right a
a -> Either PastHorizonException a
-> STM m (Either PastHorizonException a)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either PastHorizonException a
forall a b. b -> Either a b
Right a
a)
      Left PastHorizon{} -> do
        summary' <- STM m (Summary xs)
getLatestSummary
        writeTVar var summary'
        return $ runQuery q summary'