{-# LANGUAGE FlexibleContexts #-}
-- | Intended for qualified import
--
-- > import Ouroboros.Consensus.Storage.ChainDB.Init (InitChainDB)
-- > import qualified Ouroboros.Consensus.Storage.ChainDB.Init as InitChainDB
module Ouroboros.Consensus.Storage.ChainDB.Init (
    InitChainDB (..)
  , fromFull
  , map
  ) where

import           Prelude hiding (map)

import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.Extended
import           Ouroboros.Consensus.Storage.ChainDB.API (ChainDB)
import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB
import qualified Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment as InvalidBlockPunishment
import           Ouroboros.Consensus.Util.IOLike

-- | Restricted interface to the 'ChainDB' used on node initialization
data InitChainDB m blk = InitChainDB {
      -- | Add a block to the DB
      InitChainDB m blk -> blk -> m ()
addBlock         :: blk -> m ()

      -- | Return the current ledger state
    , InitChainDB m blk -> m (LedgerState blk)
getCurrentLedger :: m (LedgerState blk)
    }

fromFull ::
     (IsLedger (LedgerState blk), IOLike m)
  => ChainDB m blk -> InitChainDB m blk
fromFull :: ChainDB m blk -> InitChainDB m blk
fromFull ChainDB m blk
db = InitChainDB :: forall (m :: * -> *) blk.
(blk -> m ()) -> m (LedgerState blk) -> InitChainDB m blk
InitChainDB {
      addBlock :: blk -> m ()
addBlock         =
        ChainDB m blk -> InvalidBlockPunishment m -> blk -> m ()
forall (m :: * -> *) blk.
IOLike m =>
ChainDB m blk -> InvalidBlockPunishment m -> blk -> m ()
ChainDB.addBlock_ ChainDB m blk
db InvalidBlockPunishment m
forall (m :: * -> *). Applicative m => InvalidBlockPunishment m
InvalidBlockPunishment.noPunishment
    , getCurrentLedger :: m (LedgerState blk)
getCurrentLedger =
        STM m (LedgerState blk) -> m (LedgerState blk)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (LedgerState blk) -> m (LedgerState blk))
-> STM m (LedgerState blk) -> m (LedgerState blk)
forall a b. (a -> b) -> a -> b
$ ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState (ExtLedgerState blk -> LedgerState blk)
-> STM m (ExtLedgerState blk) -> STM m (LedgerState blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainDB m blk -> STM m (ExtLedgerState blk)
forall (m :: * -> *) blk.
(Monad (STM m), IsLedger (LedgerState blk)) =>
ChainDB m blk -> STM m (ExtLedgerState blk)
ChainDB.getCurrentLedger ChainDB m blk
db
    }

map ::
     Functor m
  => (blk' -> blk)
  -> (LedgerState blk -> LedgerState blk')
  -> InitChainDB m blk -> InitChainDB m blk'
map :: (blk' -> blk)
-> (LedgerState blk -> LedgerState blk')
-> InitChainDB m blk
-> InitChainDB m blk'
map blk' -> blk
f LedgerState blk -> LedgerState blk'
g InitChainDB m blk
db = InitChainDB :: forall (m :: * -> *) blk.
(blk -> m ()) -> m (LedgerState blk) -> InitChainDB m blk
InitChainDB {
      addBlock :: blk' -> m ()
addBlock         = InitChainDB m blk -> blk -> m ()
forall (m :: * -> *) blk. InitChainDB m blk -> blk -> m ()
addBlock InitChainDB m blk
db (blk -> m ()) -> (blk' -> blk) -> blk' -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. blk' -> blk
f
    , getCurrentLedger :: m (LedgerState blk')
getCurrentLedger = LedgerState blk -> LedgerState blk'
g (LedgerState blk -> LedgerState blk')
-> m (LedgerState blk) -> m (LedgerState blk')
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InitChainDB m blk -> m (LedgerState blk)
forall (m :: * -> *) blk. InitChainDB m blk -> m (LedgerState blk)
getCurrentLedger InitChainDB m blk
db
    }