-- | 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
  , cast
  ) where

import           Data.Coerce
import           Data.Functor.Contravariant

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Storage.ChainDB.API (ChainDB)
import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB
import           Ouroboros.Consensus.Util.IOLike

-- | Restricted interface to the 'ChainDB' used on node initialization
newtype InitChainDB m blk = InitChainDB {
      -- | Add a block to the DB when the current chain is empty.
      --
      -- The given action is only called when the current chain is empty.
      InitChainDB m blk -> m blk -> m ()
addBlockIfEmpty :: m blk -> m ()
    }

instance Functor m => Contravariant (InitChainDB m) where
  contramap :: (a -> b) -> InitChainDB m b -> InitChainDB m a
contramap a -> b
f InitChainDB m b
db = InitChainDB :: forall (m :: * -> *) blk. (m blk -> m ()) -> InitChainDB m blk
InitChainDB {
        addBlockIfEmpty :: m a -> m ()
addBlockIfEmpty = InitChainDB m b -> m b -> m ()
forall (m :: * -> *) blk. InitChainDB m blk -> m blk -> m ()
addBlockIfEmpty InitChainDB m b
db (m b -> m ()) -> (m a -> m b) -> m a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b
f (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
      }

fromFull :: IOLike m => ChainDB m blk -> InitChainDB m blk
fromFull :: ChainDB m blk -> InitChainDB m blk
fromFull ChainDB m blk
db = InitChainDB :: forall (m :: * -> *) blk. (m blk -> m ()) -> InitChainDB m blk
InitChainDB {
      addBlockIfEmpty :: m blk -> m ()
addBlockIfEmpty = \m blk
mkBlk -> do
          Point blk
tip <- STM m (Point blk) -> m (Point blk)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Point blk) -> m (Point blk))
-> STM m (Point blk) -> m (Point blk)
forall a b. (a -> b) -> a -> b
$ ChainDB m blk -> STM m (Point blk)
forall (m :: * -> *) blk. ChainDB m blk -> STM m (Point blk)
ChainDB.getTipPoint ChainDB m blk
db
          case Point blk
tip of
            BlockPoint {} -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Point blk
GenesisPoint  -> do
              blk
blk <- m blk
mkBlk
              ChainDB m blk -> blk -> m ()
forall (m :: * -> *) blk. IOLike m => ChainDB m blk -> blk -> m ()
ChainDB.addBlock_ ChainDB m blk
db blk
blk
    }

cast :: (Functor m, Coercible blk blk') => InitChainDB m blk -> InitChainDB m blk'
cast :: InitChainDB m blk -> InitChainDB m blk'
cast = (blk' -> blk) -> InitChainDB m blk -> InitChainDB m blk'
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap blk' -> blk
coerce