{-# 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.Util.IOLike

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

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

-- | Stateful abstraction to execute queries
data RunWithCachedSummary (xs :: [Type]) m = RunWithCachedSummary {
      -- | 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.
      --
      RunWithCachedSummary xs m
-> forall a. Qry a -> STM m (Either PastHorizonException a)
cachedRunQuery :: forall a. Qry a
                     -> STM m (Either PastHorizonException a)
    }

-- | 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 :: STM m (Summary xs) -> m (RunWithCachedSummary xs m)
runWithCachedSummary STM m (Summary xs)
getLatestSummary = do
    Summary xs
initSummary <- STM m (Summary xs) -> m (Summary xs)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m (Summary xs)
getLatestSummary
    StrictTVar m (Summary xs)
var <- Summary xs -> m (StrictTVar m (Summary xs))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO Summary xs
initSummary
    RunWithCachedSummary xs m -> m (RunWithCachedSummary xs m)
forall (m :: * -> *) a. Monad m => a -> m a
return (RunWithCachedSummary xs m -> m (RunWithCachedSummary xs m))
-> RunWithCachedSummary xs m -> m (RunWithCachedSummary xs m)
forall a b. (a -> b) -> a -> b
$ RunWithCachedSummary :: forall (xs :: [*]) (m :: * -> *).
(forall a. Qry a -> STM m (Either PastHorizonException a))
-> RunWithCachedSummary xs m
RunWithCachedSummary { cachedRunQuery :: forall a. Qry a -> STM m (Either PastHorizonException a)
cachedRunQuery = StrictTVar m (Summary xs)
-> Qry a -> STM m (Either PastHorizonException a)
forall a.
StrictTVar m (Summary xs)
-> Qry a -> STM m (Either PastHorizonException a)
go StrictTVar m (Summary xs)
var }
  where
    go :: StrictTVar m (Summary xs)
       -> Qry a -> STM m (Either PastHorizonException a)
    go :: StrictTVar m (Summary xs)
-> Qry a -> STM m (Either PastHorizonException a)
go StrictTVar m (Summary xs)
var Qry a
q = do
        Summary xs
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 Qry a -> Summary xs -> Either PastHorizonException a
forall a (xs :: [*]).
HasCallStack =>
Qry a -> Summary xs -> Either PastHorizonException a
runQuery Qry a
q Summary xs
summary of
          Right a
a             -> Either PastHorizonException a
-> STM m (Either PastHorizonException 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 xs
summary' <- STM m (Summary xs)
getLatestSummary
            StrictTVar m (Summary xs) -> Summary xs -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (Summary xs)
var Summary xs
summary'
            Either PastHorizonException a
-> STM m (Either PastHorizonException a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PastHorizonException a
 -> STM m (Either PastHorizonException a))
-> Either PastHorizonException a
-> STM m (Either PastHorizonException a)
forall a b. (a -> b) -> a -> b
$ Qry a -> Summary xs -> Either PastHorizonException a
forall a (xs :: [*]).
HasCallStack =>
Qry a -> Summary xs -> Either PastHorizonException a
runQuery Qry a
q Summary xs
summary'