{-# LANGUAGE GADTs               #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Ouroboros.Consensus.HardFork.Combinator.Node.InitStorage () where

import           Data.Functor.Contravariant (contramap)
import           Data.SOP.Strict

import           Ouroboros.Consensus.Node.InitStorage

import           Ouroboros.Consensus.HardFork.Combinator.Abstract
import           Ouroboros.Consensus.HardFork.Combinator.AcrossEras
import           Ouroboros.Consensus.HardFork.Combinator.Basics

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 (xs :: [*]) (proxy :: [*] -> *).
IsNonEmpty xs =>
proxy xs -> ProofNonEmpty xs
isNonEmpty (Proxy xs
forall k (t :: k). Proxy t
Proxy @xs) of
        ProofNonEmpty {} ->
          StorageConfig x -> ChunkInfo
forall blk. NodeInitStorage blk => StorageConfig blk -> ChunkInfo
nodeImmutableDbChunkInfo
            (NP StorageConfig (x : xs) -> StorageConfig x
forall k (f :: k -> *) (x :: k) (xs :: [k]). NP f (x : xs) -> f x
hd NP StorageConfig xs
NP StorageConfig (x : xs)
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 (xs :: [*]) (proxy :: [*] -> *).
IsNonEmpty xs =>
proxy xs -> ProofNonEmpty xs
isNonEmpty (Proxy xs
forall k (t :: k). Proxy t
Proxy @xs) of
        ProofNonEmpty {} ->
          NS (K Bool) xs -> CollapseTo NS Bool
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 (Proxy SingleEraBlock
forall k (t :: k). Proxy t
Proxy @SingleEraBlock) 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 :: 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'

  -- Let the first era initialise the ChainDB
  nodeInitChainDB :: StorageConfig (HardForkBlock xs)
-> InitChainDB m (HardForkBlock xs) -> m ()
nodeInitChainDB StorageConfig (HardForkBlock xs)
cfg InitChainDB m (HardForkBlock xs)
initChainDB =
      case Proxy xs -> ProofNonEmpty xs
forall (xs :: [*]) (proxy :: [*] -> *).
IsNonEmpty xs =>
proxy xs -> ProofNonEmpty xs
isNonEmpty (Proxy xs
forall k (t :: k). Proxy t
Proxy @xs) of
        ProofNonEmpty {} ->
          StorageConfig x -> InitChainDB m x -> m ()
forall blk (m :: * -> *).
(NodeInitStorage blk, IOLike m) =>
StorageConfig blk -> InitChainDB m blk -> m ()
nodeInitChainDB
            (NP StorageConfig (x : xs) -> StorageConfig x
forall k (f :: k -> *) (x :: k) (xs :: [k]). NP f (x : xs) -> f x
hd NP StorageConfig xs
NP StorageConfig (x : xs)
cfgs)
            ((x -> HardForkBlock (x : xs))
-> InitChainDB m (HardForkBlock (x : xs)) -> InitChainDB m x
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (OneEraBlock (x : xs) -> HardForkBlock (x : xs)
forall (xs :: [*]). OneEraBlock xs -> HardForkBlock xs
HardForkBlock (OneEraBlock (x : xs) -> HardForkBlock (x : xs))
-> (x -> OneEraBlock (x : xs)) -> x -> HardForkBlock (x : xs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NS I (x : xs) -> OneEraBlock (x : xs)
forall (xs :: [*]). NS I xs -> OneEraBlock xs
OneEraBlock (NS I (x : xs) -> OneEraBlock (x : xs))
-> (x -> NS I (x : xs)) -> x -> OneEraBlock (x : xs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. I x -> NS I (x : xs)
forall a (f :: a -> *) (x :: a) (xs :: [a]). f x -> NS f (x : xs)
Z (I x -> NS I (x : xs)) -> (x -> I x) -> x -> NS I (x : xs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> I x
forall a. a -> I a
I) InitChainDB m (HardForkBlock xs)
InitChainDB m (HardForkBlock (x : xs))
initChainDB)
    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)