{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Ouroboros.Consensus.HardFork.Combinator.Node.InitStorage () where

import           Data.Proxy
import           Data.SOP.BasicFunctors
import           Data.SOP.Functors
import           Data.SOP.Index
import           Data.SOP.Strict
import           Ouroboros.Consensus.HardFork.Combinator.Abstract
import           Ouroboros.Consensus.HardFork.Combinator.AcrossEras
import           Ouroboros.Consensus.HardFork.Combinator.Basics
import qualified Ouroboros.Consensus.HardFork.Combinator.State as State
import           Ouroboros.Consensus.Ledger.Abstract (EmptyMK)
import           Ouroboros.Consensus.Node.InitStorage
import           Ouroboros.Consensus.Storage.ChainDB.Init (InitChainDB (..))

instance CanHardFork xs => NodeInitStorage (HardForkBlock xs) where
  -- We use the chunk info from the first era
  nodeImmutableDbChunkInfo :: StorageConfig (HardForkBlock xs) -> ChunkInfo
nodeImmutableDbChunkInfo StorageConfig (HardForkBlock xs)
cfg =
      case Proxy xs -> ProofNonEmpty xs
forall {a} (xs :: [a]) (proxy :: [a] -> *).
IsNonEmpty xs =>
proxy xs -> ProofNonEmpty xs
forall (proxy :: [*] -> *). proxy xs -> ProofNonEmpty xs
isNonEmpty (forall (t :: [*]). Proxy t
forall {k} (t :: k). Proxy t
Proxy @xs) of
        ProofNonEmpty {} ->
          StorageConfig x -> ChunkInfo
forall blk. NodeInitStorage blk => StorageConfig blk -> ChunkInfo
nodeImmutableDbChunkInfo
            (NP StorageConfig (x : xs1) -> StorageConfig x
forall {k} (f :: k -> *) (x :: k) (xs :: [k]). NP f (x : xs) -> f x
hd NP StorageConfig xs
NP StorageConfig (x : xs1)
cfgs)
    where
      cfgs :: NP StorageConfig xs
cfgs = PerEraStorageConfig xs -> NP StorageConfig xs
forall (xs :: [*]). PerEraStorageConfig xs -> NP StorageConfig xs
getPerEraStorageConfig (StorageConfig (HardForkBlock xs) -> PerEraStorageConfig xs
forall (xs :: [*]).
StorageConfig (HardForkBlock xs) -> PerEraStorageConfig xs
hardForkStorageConfigPerEra StorageConfig (HardForkBlock xs)
cfg)

  -- Dispatch based on the era
  nodeCheckIntegrity :: StorageConfig (HardForkBlock xs) -> HardForkBlock xs -> Bool
nodeCheckIntegrity StorageConfig (HardForkBlock xs)
cfg (HardForkBlock (OneEraBlock NS I xs
blk)) =
      case Proxy xs -> ProofNonEmpty xs
forall {a} (xs :: [a]) (proxy :: [a] -> *).
IsNonEmpty xs =>
proxy xs -> ProofNonEmpty xs
forall (proxy :: [*] -> *). proxy xs -> ProofNonEmpty xs
isNonEmpty (forall (t :: [*]). Proxy t
forall {k} (t :: k). Proxy t
Proxy @xs) of
        ProofNonEmpty {} ->
          NS (K Bool) xs -> CollapseTo NS Bool
forall (xs :: [*]) a.
SListIN NS xs =>
NS (K a) xs -> CollapseTo NS a
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (NS (K Bool) xs -> CollapseTo NS Bool)
-> NS (K Bool) xs -> CollapseTo NS Bool
forall a b. (a -> b) -> a -> b
$
            Proxy SingleEraBlock
-> (forall a.
    SingleEraBlock a =>
    StorageConfig a -> I a -> K Bool a)
-> Prod NS StorageConfig xs
-> NS I xs
-> NS (K Bool) xs
forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *) (f'' :: k -> *).
(AllN (Prod h) c xs, HAp h, HAp (Prod h)) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a -> f'' a)
-> Prod h f xs
-> h f' xs
-> h f'' xs
hczipWith (forall {k} (t :: k). Proxy t
forall (t :: * -> Constraint). Proxy t
Proxy @SingleEraBlock) StorageConfig a -> I a -> K Bool a
forall blk.
NodeInitStorage blk =>
StorageConfig blk -> I blk -> K Bool blk
forall a. SingleEraBlock a => StorageConfig a -> I a -> K Bool a
aux Prod NS StorageConfig xs
NP StorageConfig xs
cfgs NS I xs
blk
    where
      cfgs :: NP StorageConfig xs
cfgs = PerEraStorageConfig xs -> NP StorageConfig xs
forall (xs :: [*]). PerEraStorageConfig xs -> NP StorageConfig xs
getPerEraStorageConfig (StorageConfig (HardForkBlock xs) -> PerEraStorageConfig xs
forall (xs :: [*]).
StorageConfig (HardForkBlock xs) -> PerEraStorageConfig xs
hardForkStorageConfigPerEra StorageConfig (HardForkBlock xs)
cfg)

      aux :: NodeInitStorage blk => StorageConfig blk -> I blk -> K Bool blk
      aux :: forall blk.
NodeInitStorage blk =>
StorageConfig blk -> I blk -> K Bool blk
aux StorageConfig blk
cfg' (I blk
blk') = Bool -> K Bool blk
forall k a (b :: k). a -> K a b
K (Bool -> K Bool blk) -> Bool -> K Bool blk
forall a b. (a -> b) -> a -> b
$ StorageConfig blk -> blk -> Bool
forall blk. NodeInitStorage blk => StorageConfig blk -> blk -> Bool
nodeCheckIntegrity StorageConfig blk
cfg' blk
blk'

  -- Call the 'nodeInitChainDB' of the era in which the current ledger is.
  --
  -- In most cases, this will be the first era, except when one or more hard
  -- forks are statically scheduled at the first slot.
  nodeInitChainDB :: forall (m :: * -> *).
IOLike m =>
StorageConfig (HardForkBlock xs)
-> InitChainDB m (HardForkBlock xs) -> m ()
nodeInitChainDB StorageConfig (HardForkBlock xs)
cfg (InitChainDB m (HardForkBlock xs)
initChainDB :: InitChainDB m (HardForkBlock xs)) =
      case Proxy xs -> ProofNonEmpty xs
forall {a} (xs :: [a]) (proxy :: [a] -> *).
IsNonEmpty xs =>
proxy xs -> ProofNonEmpty xs
forall (proxy :: [*] -> *). proxy xs -> ProofNonEmpty xs
isNonEmpty (forall (t :: [*]). Proxy t
forall {k} (t :: k). Proxy t
Proxy @xs) of
        ProofNonEmpty {} -> do
          currentLedger <- InitChainDB m (HardForkBlock xs)
-> m (LedgerState (HardForkBlock xs) EmptyMK)
forall (m :: * -> *) blk.
InitChainDB m blk -> m (LedgerState blk EmptyMK)
getCurrentLedger InitChainDB m (HardForkBlock xs)
initChainDB
          hcollapse $
            hcizipWith
              proxySingle
              aux
              cfgs
              (State.tip (hardForkLedgerStatePerEra currentLedger))
    where
      cfgs :: NP StorageConfig xs
cfgs = PerEraStorageConfig xs -> NP StorageConfig xs
forall (xs :: [*]). PerEraStorageConfig xs -> NP StorageConfig xs
getPerEraStorageConfig (StorageConfig (HardForkBlock xs) -> PerEraStorageConfig xs
forall (xs :: [*]).
StorageConfig (HardForkBlock xs) -> PerEraStorageConfig xs
hardForkStorageConfigPerEra StorageConfig (HardForkBlock xs)
cfg)

      aux ::
           SingleEraBlock blk
        => Index xs blk
        -> StorageConfig blk
        -> Flip LedgerState EmptyMK blk
        -> K (m ()) blk
      aux :: forall a.
SingleEraBlock a =>
Index xs a
-> StorageConfig a -> Flip LedgerState EmptyMK a -> K (m ()) a
aux Index xs blk
index StorageConfig blk
cfg' (Flip LedgerState blk EmptyMK
currentLedger) = m () -> K (m ()) blk
forall k a (b :: k). a -> K a b
K (m () -> K (m ()) blk) -> m () -> K (m ()) blk
forall a b. (a -> b) -> a -> b
$
          StorageConfig blk -> InitChainDB m blk -> m ()
forall blk (m :: * -> *).
(NodeInitStorage blk, IOLike m) =>
StorageConfig blk -> InitChainDB m blk -> m ()
forall (m :: * -> *).
IOLike m =>
StorageConfig blk -> InitChainDB m blk -> m ()
nodeInitChainDB StorageConfig blk
cfg' InitChainDB {
              addBlock :: blk -> m ()
addBlock         = InitChainDB m (HardForkBlock xs) -> HardForkBlock xs -> m ()
forall (m :: * -> *) blk. InitChainDB m blk -> blk -> m ()
addBlock InitChainDB m (HardForkBlock xs)
initChainDB
                               (HardForkBlock xs -> m ())
-> (blk -> HardForkBlock xs) -> blk -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy I -> Index xs blk -> blk -> HardForkBlock xs
forall {k} (f :: k -> *) a b (x :: k) (xs :: [k]).
(All Top xs, Coercible a (f x), Coercible b (NS f xs)) =>
Proxy f -> Index xs x -> a -> b
injectNS' (forall {k} (t :: k). Proxy t
forall (t :: * -> *). Proxy t
Proxy @I) Index xs blk
index
            , getCurrentLedger :: m (LedgerState blk EmptyMK)
getCurrentLedger = LedgerState blk EmptyMK -> m (LedgerState blk EmptyMK)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return LedgerState blk EmptyMK
currentLedger
            }