{-# 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
            }