{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE EmptyCase             #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE KindSignatures        #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE StandaloneDeriving    #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Ouroboros.Consensus.HardFork.Combinator.Ledger.Query (
    BlockQuery (..)
  , HardForkQueryResult
  , QueryAnytime (..)
  , QueryHardFork (..)
  , QueryIfCurrent (..)
  , decodeQueryAnytimeResult
  , decodeQueryHardForkResult
  , encodeQueryAnytimeResult
  , encodeQueryHardForkResult
  , getHardForkQuery
  , hardForkQueryInfo
  ) where

import           Codec.CBOR.Decoding (Decoder)
import qualified Codec.CBOR.Decoding as Dec
import           Codec.CBOR.Encoding (Encoding)
import qualified Codec.CBOR.Encoding as Enc
import           Codec.Serialise (Serialise (..))
import           Data.Bifunctor
import           Data.Functor.Product
import           Data.Kind (Type)
import           Data.Proxy
import           Data.SOP.Strict
import           Data.Type.Equality
import           Data.Typeable (Typeable)

import           Cardano.Binary (enforceSize)

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.HardFork.Abstract (hardForkSummary)
import           Ouroboros.Consensus.HardFork.History (Bound (..), EraParams,
                     Shape (..))
import qualified Ouroboros.Consensus.HardFork.History as History
import           Ouroboros.Consensus.HeaderValidation
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.Extended
import           Ouroboros.Consensus.Ledger.Query
import           Ouroboros.Consensus.Node.Serialisation (Some (..))
import           Ouroboros.Consensus.TypeFamilyWrappers (WrapChainDepState (..))
import           Ouroboros.Consensus.Util (ShowProxy)
import           Ouroboros.Consensus.Util.Counting (getExactly)

import           Ouroboros.Consensus.HardFork.Combinator.Abstract
import           Ouroboros.Consensus.HardFork.Combinator.AcrossEras
import           Ouroboros.Consensus.HardFork.Combinator.Basics
import           Ouroboros.Consensus.HardFork.Combinator.Block
import           Ouroboros.Consensus.HardFork.Combinator.Info
import           Ouroboros.Consensus.HardFork.Combinator.Ledger ()
import           Ouroboros.Consensus.HardFork.Combinator.PartialConfig
import           Ouroboros.Consensus.HardFork.Combinator.State (Current (..),
                     Past (..), Situated (..))
import qualified Ouroboros.Consensus.HardFork.Combinator.State as State
import           Ouroboros.Consensus.HardFork.Combinator.Util.Match
                     (Mismatch (..), mustMatchNS)

instance Typeable xs => ShowProxy (BlockQuery (HardForkBlock xs)) where

instance All SingleEraBlock xs => ShowQuery (BlockQuery (HardForkBlock xs)) where
  showResult :: BlockQuery (HardForkBlock xs) result -> result -> String
showResult (QueryAnytime   qry _) result
result = QueryAnytime result -> result -> String
forall (query :: * -> *) result.
ShowQuery query =>
query result -> result -> String
showResult QueryAnytime result
qry result
result
  showResult (QueryHardFork  qry)   result
result = QueryHardFork (x : xs) result -> result -> String
forall (query :: * -> *) result.
ShowQuery query =>
query result -> result -> String
showResult QueryHardFork (x : xs) result
qry result
result
  showResult (QueryIfCurrent qry)  result
mResult =
      case result
mResult of
        Left  err    -> MismatchEraInfo xs -> String
forall a. Show a => a -> String
show MismatchEraInfo xs
err
        Right result -> QueryIfCurrent xs result -> result -> String
forall (query :: * -> *) result.
ShowQuery query =>
query result -> result -> String
showResult QueryIfCurrent xs result
qry result
result

type HardForkQueryResult xs = Either (MismatchEraInfo xs)

data instance BlockQuery (HardForkBlock xs) :: Type -> Type where
  -- | Answer a query about an era if it is the current one.
  QueryIfCurrent ::
       QueryIfCurrent xs result
    -> BlockQuery (HardForkBlock xs) (HardForkQueryResult xs result)

  -- | Answer a query about an era from /any/ era.
  --
  -- NOTE: we don't allow this when there is only a single era, so that the
  -- HFC applied to a single era is still isomorphic to the single era.
  QueryAnytime ::
       IsNonEmpty xs
    => QueryAnytime result
    -> EraIndex (x ': xs)
    -> BlockQuery (HardForkBlock (x ': xs)) result

  -- | Answer a query about the hard fork combinator
  --
  -- NOTE: we don't allow this when there is only a single era, so that the
  -- HFC applied to a single era is still isomorphic to the single era.
  QueryHardFork ::
       IsNonEmpty xs
    => QueryHardFork (x ': xs) result
    -> BlockQuery (HardForkBlock (x ': xs)) result

instance All SingleEraBlock xs => QueryLedger (HardForkBlock xs) where
  answerBlockQuery :: ExtLedgerCfg (HardForkBlock xs)
-> BlockQuery (HardForkBlock xs) result
-> ExtLedgerState (HardForkBlock xs)
-> result
answerBlockQuery
    (ExtLedgerCfg TopLevelConfig (HardForkBlock xs)
cfg)
    BlockQuery (HardForkBlock xs) result
query
    ext :: ExtLedgerState (HardForkBlock xs)
ext@(ExtLedgerState st :: LedgerState (HardForkBlock xs)
st@(HardForkLedgerState hardForkState) HeaderState (HardForkBlock xs)
_) =
      case BlockQuery (HardForkBlock xs) result
query of
        QueryIfCurrent queryIfCurrent ->
          NP ExtLedgerCfg xs
-> QueryIfCurrent xs result
-> NS ExtLedgerState xs
-> HardForkQueryResult xs result
forall result (xs :: [*]).
All SingleEraBlock xs =>
NP ExtLedgerCfg xs
-> QueryIfCurrent xs result
-> NS ExtLedgerState xs
-> HardForkQueryResult xs result
interpretQueryIfCurrent
            NP ExtLedgerCfg xs
cfgs
            QueryIfCurrent xs result
queryIfCurrent
            (ExtLedgerState (HardForkBlock xs) -> NS ExtLedgerState xs
forall (xs :: [*]).
All SingleEraBlock xs =>
ExtLedgerState (HardForkBlock xs) -> NS ExtLedgerState xs
distribExtLedgerState ExtLedgerState (HardForkBlock xs)
ext)
        QueryAnytime queryAnytime (EraIndex era) ->
          HardForkLedgerConfig (x : xs)
-> QueryAnytime result
-> EraIndex (x : xs)
-> HardForkState LedgerState (x : xs)
-> result
forall result (xs :: [*]).
All SingleEraBlock xs =>
HardForkLedgerConfig xs
-> QueryAnytime result
-> EraIndex xs
-> HardForkState LedgerState xs
-> result
interpretQueryAnytime
            LedgerConfig (HardForkBlock xs)
HardForkLedgerConfig (x : xs)
lcfg
            QueryAnytime result
queryAnytime
            (NS (K ()) (x : xs) -> EraIndex (x : xs)
forall (xs :: [*]). NS (K ()) xs -> EraIndex xs
EraIndex NS (K ()) (x : xs)
era)
            HardForkState LedgerState xs
HardForkState LedgerState (x : xs)
hardForkState
        QueryHardFork queryHardFork ->
          HardForkLedgerConfig (x : xs)
-> QueryHardFork (x : xs) result
-> LedgerState (HardForkBlock (x : xs))
-> result
forall (xs :: [*]) result.
All SingleEraBlock xs =>
HardForkLedgerConfig xs
-> QueryHardFork xs result
-> LedgerState (HardForkBlock xs)
-> result
interpretQueryHardFork
            LedgerConfig (HardForkBlock xs)
HardForkLedgerConfig (x : xs)
lcfg
            QueryHardFork (x : xs) result
queryHardFork
            LedgerState (HardForkBlock xs)
LedgerState (HardForkBlock (x : xs))
st
    where
      cfgs :: NP ExtLedgerCfg xs
cfgs = (forall a. TopLevelConfig a -> ExtLedgerCfg a)
-> NP TopLevelConfig xs -> NP ExtLedgerCfg xs
forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *)
       (f' :: k -> *).
(SListIN (Prod h) xs, HAp h) =>
(forall (a :: k). f a -> f' a) -> h f xs -> h f' xs
hmap forall a. TopLevelConfig a -> ExtLedgerCfg a
ExtLedgerCfg (NP TopLevelConfig xs -> NP ExtLedgerCfg xs)
-> NP TopLevelConfig xs -> NP ExtLedgerCfg xs
forall a b. (a -> b) -> a -> b
$ EpochInfo (Except PastHorizonException)
-> TopLevelConfig (HardForkBlock xs) -> NP TopLevelConfig xs
forall (xs :: [*]).
All SingleEraBlock xs =>
EpochInfo (Except PastHorizonException)
-> TopLevelConfig (HardForkBlock xs) -> NP TopLevelConfig xs
distribTopLevelConfig EpochInfo (Except PastHorizonException)
ei TopLevelConfig (HardForkBlock xs)
cfg
      lcfg :: LedgerConfig (HardForkBlock xs)
lcfg = TopLevelConfig (HardForkBlock xs)
-> LedgerConfig (HardForkBlock xs)
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig (HardForkBlock xs)
cfg
      ei :: EpochInfo (Except PastHorizonException)
ei   = HardForkLedgerConfig xs
-> HardForkState LedgerState xs
-> EpochInfo (Except PastHorizonException)
forall (xs :: [*]).
All SingleEraBlock xs =>
HardForkLedgerConfig xs
-> HardForkState LedgerState xs
-> EpochInfo (Except PastHorizonException)
State.epochInfoLedger LedgerConfig (HardForkBlock xs)
HardForkLedgerConfig xs
lcfg HardForkState LedgerState xs
hardForkState

-- | Precondition: the 'ledgerState' and 'headerState' should be from the same
-- era. In practice, this is _always_ the case, unless the 'ExtLedgerState' was
-- manually crafted.
distribExtLedgerState ::
     All SingleEraBlock xs
  => ExtLedgerState (HardForkBlock xs) -> NS ExtLedgerState xs
distribExtLedgerState :: ExtLedgerState (HardForkBlock xs) -> NS ExtLedgerState xs
distribExtLedgerState (ExtLedgerState LedgerState (HardForkBlock xs)
ledgerState HeaderState (HardForkBlock xs)
headerState) =
    (forall a. Product HeaderState LedgerState a -> ExtLedgerState a)
-> NS (Product HeaderState LedgerState) xs -> NS ExtLedgerState xs
forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *)
       (f' :: k -> *).
(SListIN (Prod h) xs, HAp h) =>
(forall (a :: k). f a -> f' a) -> h f xs -> h f' xs
hmap (\(Pair hst lst) -> LedgerState a -> HeaderState a -> ExtLedgerState a
forall blk.
LedgerState blk -> HeaderState blk -> ExtLedgerState blk
ExtLedgerState LedgerState a
lst HeaderState a
hst) (NS (Product HeaderState LedgerState) xs -> NS ExtLedgerState xs)
-> NS (Product HeaderState LedgerState) xs -> NS ExtLedgerState xs
forall a b. (a -> b) -> a -> b
$
      String
-> NS HeaderState xs
-> NS LedgerState xs
-> NS (Product HeaderState LedgerState) xs
forall k (f :: k -> *) (g :: k -> *) (xs :: [k]).
HasCallStack =>
String -> NS f xs -> NS g xs -> NS (Product f g) xs
mustMatchNS
        String
"HeaderState"
        (HeaderState (HardForkBlock xs) -> NS HeaderState xs
forall (xs :: [*]).
All SingleEraBlock xs =>
HeaderState (HardForkBlock xs) -> NS HeaderState xs
distribHeaderState HeaderState (HardForkBlock xs)
headerState)
        (HardForkState LedgerState xs -> NS LedgerState xs
forall (xs :: [*]) (f :: * -> *).
SListI xs =>
HardForkState f xs -> NS f xs
State.tip (LedgerState (HardForkBlock xs) -> HardForkState LedgerState xs
forall (xs :: [*]).
LedgerState (HardForkBlock xs) -> HardForkState LedgerState xs
hardForkLedgerStatePerEra LedgerState (HardForkBlock xs)
ledgerState))

-- | Precondition: the 'headerStateTip' and 'headerStateChainDep' should be from
-- the same era. In practice, this is _always_ the case, unless the
-- 'HeaderState' was manually crafted.
distribHeaderState ::
     All SingleEraBlock xs
  => HeaderState (HardForkBlock xs) -> NS HeaderState xs
distribHeaderState :: HeaderState (HardForkBlock xs) -> NS HeaderState xs
distribHeaderState (HeaderState WithOrigin (AnnTip (HardForkBlock xs))
tip ChainDepState (BlockProtocol (HardForkBlock xs))
chainDepState) =
    case WithOrigin (AnnTip (HardForkBlock xs))
tip of
      WithOrigin (AnnTip (HardForkBlock xs))
Origin ->
        (forall a. WrapChainDepState a -> HeaderState a)
-> NS WrapChainDepState xs -> NS HeaderState xs
forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *)
       (f' :: k -> *).
(SListIN (Prod h) xs, HAp h) =>
(forall (a :: k). f a -> f' a) -> h f xs -> h f' xs
hmap (WithOrigin (AnnTip a)
-> ChainDepState (BlockProtocol a) -> HeaderState a
forall blk.
WithOrigin (AnnTip blk)
-> ChainDepState (BlockProtocol blk) -> HeaderState blk
HeaderState WithOrigin (AnnTip a)
forall t. WithOrigin t
Origin (ChainDepState (BlockProtocol a) -> HeaderState a)
-> (WrapChainDepState a -> ChainDepState (BlockProtocol a))
-> WrapChainDepState a
-> HeaderState a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapChainDepState a -> ChainDepState (BlockProtocol a)
forall blk.
WrapChainDepState blk -> ChainDepState (BlockProtocol blk)
unwrapChainDepState) (HardForkState WrapChainDepState xs -> NS WrapChainDepState xs
forall (xs :: [*]) (f :: * -> *).
SListI xs =>
HardForkState f xs -> NS f xs
State.tip ChainDepState (BlockProtocol (HardForkBlock xs))
HardForkState WrapChainDepState xs
chainDepState)
      NotOrigin AnnTip (HardForkBlock xs)
annTip ->
        (forall a. Product AnnTip WrapChainDepState a -> HeaderState a)
-> NS (Product AnnTip WrapChainDepState) xs -> NS HeaderState xs
forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *)
       (f' :: k -> *).
(SListIN (Prod h) xs, HAp h) =>
(forall (a :: k). f a -> f' a) -> h f xs -> h f' xs
hmap
          (\(Pair t cds) -> WithOrigin (AnnTip a)
-> ChainDepState (BlockProtocol a) -> HeaderState a
forall blk.
WithOrigin (AnnTip blk)
-> ChainDepState (BlockProtocol blk) -> HeaderState blk
HeaderState (AnnTip a -> WithOrigin (AnnTip a)
forall t. t -> WithOrigin t
NotOrigin AnnTip a
t) (WrapChainDepState a -> ChainDepState (BlockProtocol a)
forall blk.
WrapChainDepState blk -> ChainDepState (BlockProtocol blk)
unwrapChainDepState WrapChainDepState a
cds))
          (String
-> NS AnnTip xs
-> NS WrapChainDepState xs
-> NS (Product AnnTip WrapChainDepState) xs
forall k (f :: k -> *) (g :: k -> *) (xs :: [k]).
HasCallStack =>
String -> NS f xs -> NS g xs -> NS (Product f g) xs
mustMatchNS String
"AnnTip" (AnnTip (HardForkBlock xs) -> NS AnnTip xs
forall (xs :: [*]).
SListI xs =>
AnnTip (HardForkBlock xs) -> NS AnnTip xs
distribAnnTip AnnTip (HardForkBlock xs)
annTip) (HardForkState WrapChainDepState xs -> NS WrapChainDepState xs
forall (xs :: [*]) (f :: * -> *).
SListI xs =>
HardForkState f xs -> NS f xs
State.tip ChainDepState (BlockProtocol (HardForkBlock xs))
HardForkState WrapChainDepState xs
chainDepState))

instance All SingleEraBlock xs => SameDepIndex (BlockQuery (HardForkBlock xs)) where
  sameDepIndex :: BlockQuery (HardForkBlock xs) a
-> BlockQuery (HardForkBlock xs) b -> Maybe (a :~: b)
sameDepIndex (QueryIfCurrent qry) (QueryIfCurrent qry') =
      (Either (MismatchEraInfo xs) :~: Either (MismatchEraInfo xs))
-> (result :~: result)
-> Either (MismatchEraInfo xs) result
   :~: Either (MismatchEraInfo xs) result
forall k1 k2 (f :: k1 -> k2) (g :: k1 -> k2) (a :: k1) (b :: k1).
(f :~: g) -> (a :~: b) -> f a :~: g b
apply Either (MismatchEraInfo xs) :~: Either (MismatchEraInfo xs)
forall k (a :: k). a :~: a
Refl ((result :~: result)
 -> Either (MismatchEraInfo xs) result
    :~: Either (MismatchEraInfo xs) result)
-> Maybe (result :~: result)
-> Maybe
     (Either (MismatchEraInfo xs) result
      :~: Either (MismatchEraInfo xs) result)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QueryIfCurrent xs result
-> QueryIfCurrent xs result -> Maybe (result :~: result)
forall (f :: * -> *) a b.
SameDepIndex f =>
f a -> f b -> Maybe (a :~: b)
sameDepIndex QueryIfCurrent xs result
qry QueryIfCurrent xs result
qry'
  sameDepIndex (QueryIfCurrent {}) BlockQuery (HardForkBlock xs) b
_ =
      Maybe (a :~: b)
forall a. Maybe a
Nothing
  sameDepIndex (QueryAnytime qry era) (QueryAnytime qry' era')
    | EraIndex (x : xs)
era EraIndex (x : xs) -> EraIndex (x : xs) -> Bool
forall a. Eq a => a -> a -> Bool
== EraIndex (x : xs)
EraIndex (x : xs)
era'
    = QueryAnytime a -> QueryAnytime b -> Maybe (a :~: b)
forall (f :: * -> *) a b.
SameDepIndex f =>
f a -> f b -> Maybe (a :~: b)
sameDepIndex QueryAnytime a
qry QueryAnytime b
qry'
    | Bool
otherwise
    = Maybe (a :~: b)
forall a. Maybe a
Nothing
  sameDepIndex (QueryAnytime {}) BlockQuery (HardForkBlock xs) b
_ =
      Maybe (a :~: b)
forall a. Maybe a
Nothing
  sameDepIndex (QueryHardFork qry) (QueryHardFork qry') =
      QueryHardFork (x : xs) a
-> QueryHardFork (x : xs) b -> Maybe (a :~: b)
forall (f :: * -> *) a b.
SameDepIndex f =>
f a -> f b -> Maybe (a :~: b)
sameDepIndex QueryHardFork (x : xs) a
qry QueryHardFork (x : xs) b
QueryHardFork (x : xs) b
qry'
  sameDepIndex (QueryHardFork {}) BlockQuery (HardForkBlock xs) b
_ =
      Maybe (a :~: b)
forall a. Maybe a
Nothing

deriving instance All SingleEraBlock xs => Show (BlockQuery (HardForkBlock xs) result)

getHardForkQuery :: BlockQuery (HardForkBlock xs) result
                 -> (forall result'.
                          result :~: HardForkQueryResult xs result'
                       -> QueryIfCurrent xs result'
                       -> r)
                 -> (forall x' xs'.
                          xs :~: x' ': xs'
                       -> ProofNonEmpty xs'
                       -> QueryAnytime result
                       -> EraIndex xs
                       -> r)
                 -> (forall x' xs'.
                          xs :~: x' ': xs'
                       -> ProofNonEmpty xs'
                       -> QueryHardFork xs result
                       -> r)
                 -> r
getHardForkQuery :: BlockQuery (HardForkBlock xs) result
-> (forall result'.
    (result :~: HardForkQueryResult xs result')
    -> QueryIfCurrent xs result' -> r)
-> (forall x' (xs' :: [*]).
    (xs :~: (x' : xs'))
    -> ProofNonEmpty xs' -> QueryAnytime result -> EraIndex xs -> r)
-> (forall x' (xs' :: [*]).
    (xs :~: (x' : xs'))
    -> ProofNonEmpty xs' -> QueryHardFork xs result -> r)
-> r
getHardForkQuery BlockQuery (HardForkBlock xs) result
q forall result'.
(result :~: HardForkQueryResult xs result')
-> QueryIfCurrent xs result' -> r
k1 forall x' (xs' :: [*]).
(xs :~: (x' : xs'))
-> ProofNonEmpty xs' -> QueryAnytime result -> EraIndex xs -> r
k2 forall x' (xs' :: [*]).
(xs :~: (x' : xs'))
-> ProofNonEmpty xs' -> QueryHardFork xs result -> r
k3 = case BlockQuery (HardForkBlock xs) result
q of
    QueryIfCurrent qry   -> (result :~: HardForkQueryResult xs result)
-> QueryIfCurrent xs result -> r
forall result'.
(result :~: HardForkQueryResult xs result')
-> QueryIfCurrent xs result' -> r
k1 result :~: HardForkQueryResult xs result
forall k (a :: k). a :~: a
Refl QueryIfCurrent xs result
qry
    QueryAnytime qry era -> (xs :~: (x : xs))
-> ProofNonEmpty xs -> QueryAnytime result -> EraIndex xs -> r
forall x' (xs' :: [*]).
(xs :~: (x' : xs'))
-> ProofNonEmpty xs' -> QueryAnytime result -> EraIndex xs -> r
k2 xs :~: (x : xs)
forall k (a :: k). a :~: a
Refl (Proxy xs -> ProofNonEmpty xs
forall a (xs :: [a]) (proxy :: [a] -> *).
IsNonEmpty xs =>
proxy xs -> ProofNonEmpty xs
isNonEmpty Proxy xs
forall k (t :: k). Proxy t
Proxy) QueryAnytime result
qry EraIndex xs
EraIndex (x : xs)
era
    QueryHardFork qry    -> (xs :~: (x : xs))
-> ProofNonEmpty xs -> QueryHardFork xs result -> r
forall x' (xs' :: [*]).
(xs :~: (x' : xs'))
-> ProofNonEmpty xs' -> QueryHardFork xs result -> r
k3 xs :~: (x : xs)
forall k (a :: k). a :~: a
Refl (Proxy xs -> ProofNonEmpty xs
forall a (xs :: [a]) (proxy :: [a] -> *).
IsNonEmpty xs =>
proxy xs -> ProofNonEmpty xs
isNonEmpty Proxy xs
forall k (t :: k). Proxy t
Proxy) QueryHardFork xs result
QueryHardFork (x : xs) result
qry

{-------------------------------------------------------------------------------
  Current era queries
-------------------------------------------------------------------------------}

data QueryIfCurrent :: [Type] -> Type -> Type where
  QZ :: BlockQuery x result      -> QueryIfCurrent (x ': xs) result
  QS :: QueryIfCurrent xs result -> QueryIfCurrent (x ': xs) result

deriving instance All SingleEraBlock xs => Show (QueryIfCurrent xs result)

instance All SingleEraBlock xs => ShowQuery (QueryIfCurrent xs) where
  showResult :: QueryIfCurrent xs result -> result -> String
showResult (QZ BlockQuery x result
qry) = BlockQuery x result -> result -> String
forall (query :: * -> *) result.
ShowQuery query =>
query result -> result -> String
showResult BlockQuery x result
qry
  showResult (QS QueryIfCurrent xs result
qry) = QueryIfCurrent xs result -> result -> String
forall (query :: * -> *) result.
ShowQuery query =>
query result -> result -> String
showResult QueryIfCurrent xs result
qry

instance All SingleEraBlock xs => SameDepIndex (QueryIfCurrent xs) where
  sameDepIndex :: QueryIfCurrent xs a -> QueryIfCurrent xs b -> Maybe (a :~: b)
sameDepIndex (QZ BlockQuery x a
qry) (QZ BlockQuery x b
qry') = BlockQuery x a -> BlockQuery x b -> Maybe (a :~: b)
forall (f :: * -> *) a b.
SameDepIndex f =>
f a -> f b -> Maybe (a :~: b)
sameDepIndex BlockQuery x a
qry BlockQuery x b
BlockQuery x b
qry'
  sameDepIndex (QS QueryIfCurrent xs a
qry) (QS QueryIfCurrent xs b
qry') = QueryIfCurrent xs a -> QueryIfCurrent xs b -> Maybe (a :~: b)
forall (f :: * -> *) a b.
SameDepIndex f =>
f a -> f b -> Maybe (a :~: b)
sameDepIndex QueryIfCurrent xs a
qry QueryIfCurrent xs b
QueryIfCurrent xs b
qry'
  sameDepIndex QueryIfCurrent xs a
_        QueryIfCurrent xs b
_         = Maybe (a :~: b)
forall a. Maybe a
Nothing

interpretQueryIfCurrent ::
     forall result xs. All SingleEraBlock xs
  => NP ExtLedgerCfg xs
  -> QueryIfCurrent xs result
  -> NS ExtLedgerState xs
  -> HardForkQueryResult xs result
interpretQueryIfCurrent :: NP ExtLedgerCfg xs
-> QueryIfCurrent xs result
-> NS ExtLedgerState xs
-> HardForkQueryResult xs result
interpretQueryIfCurrent = NP ExtLedgerCfg xs
-> QueryIfCurrent xs result
-> NS ExtLedgerState xs
-> HardForkQueryResult xs result
forall (xs' :: [*]).
All SingleEraBlock xs' =>
NP ExtLedgerCfg xs'
-> QueryIfCurrent xs' result
-> NS ExtLedgerState xs'
-> HardForkQueryResult xs' result
go
  where
    go :: All SingleEraBlock xs'
       => NP ExtLedgerCfg xs'
       -> QueryIfCurrent xs' result
       -> NS ExtLedgerState xs'
       -> HardForkQueryResult xs' result
    go :: NP ExtLedgerCfg xs'
-> QueryIfCurrent xs' result
-> NS ExtLedgerState xs'
-> HardForkQueryResult xs' result
go (ExtLedgerCfg x
c :* NP ExtLedgerCfg xs
_)  (QZ BlockQuery x result
qry) (Z ExtLedgerState x
st) =
        result -> HardForkQueryResult xs' result
forall a b. b -> Either a b
Right (result -> HardForkQueryResult xs' result)
-> result -> HardForkQueryResult xs' result
forall a b. (a -> b) -> a -> b
$ ExtLedgerCfg x -> BlockQuery x result -> ExtLedgerState x -> result
forall blk result.
QueryLedger blk =>
ExtLedgerCfg blk
-> BlockQuery blk result -> ExtLedgerState blk -> result
answerBlockQuery ExtLedgerCfg x
c BlockQuery x result
BlockQuery x result
qry ExtLedgerState x
ExtLedgerState x
st
    go (ExtLedgerCfg x
_ :* NP ExtLedgerCfg xs
cs) (QS QueryIfCurrent xs result
qry) (S NS ExtLedgerState xs
st) =
        (MismatchEraInfo xs -> MismatchEraInfo (x : xs))
-> Either (MismatchEraInfo xs) result
-> Either (MismatchEraInfo (x : xs)) result
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first MismatchEraInfo xs -> MismatchEraInfo (x : xs)
forall (xs :: [*]) x.
MismatchEraInfo xs -> MismatchEraInfo (x : xs)
shiftMismatch (Either (MismatchEraInfo xs) result
 -> Either (MismatchEraInfo (x : xs)) result)
-> Either (MismatchEraInfo xs) result
-> Either (MismatchEraInfo (x : xs)) result
forall a b. (a -> b) -> a -> b
$ NP ExtLedgerCfg xs
-> QueryIfCurrent xs result
-> NS ExtLedgerState xs
-> Either (MismatchEraInfo xs) result
forall (xs' :: [*]).
All SingleEraBlock xs' =>
NP ExtLedgerCfg xs'
-> QueryIfCurrent xs' result
-> NS ExtLedgerState xs'
-> HardForkQueryResult xs' result
go NP ExtLedgerCfg xs
cs QueryIfCurrent xs result
QueryIfCurrent xs result
qry NS ExtLedgerState xs
NS ExtLedgerState xs
st
    go NP ExtLedgerCfg xs'
_         (QZ BlockQuery x result
qry) (S NS ExtLedgerState xs
st) =
        MismatchEraInfo (x : xs)
-> Either (MismatchEraInfo (x : xs)) result
forall a b. a -> Either a b
Left (MismatchEraInfo (x : xs)
 -> Either (MismatchEraInfo (x : xs)) result)
-> MismatchEraInfo (x : xs)
-> Either (MismatchEraInfo (x : xs)) result
forall a b. (a -> b) -> a -> b
$ Mismatch SingleEraInfo LedgerEraInfo (x : xs)
-> MismatchEraInfo (x : xs)
forall (xs :: [*]).
Mismatch SingleEraInfo LedgerEraInfo xs -> MismatchEraInfo xs
MismatchEraInfo (Mismatch SingleEraInfo LedgerEraInfo (x : xs)
 -> MismatchEraInfo (x : xs))
-> Mismatch SingleEraInfo LedgerEraInfo (x : xs)
-> MismatchEraInfo (x : xs)
forall a b. (a -> b) -> a -> b
$ SingleEraInfo x
-> NS LedgerEraInfo xs
-> Mismatch SingleEraInfo LedgerEraInfo (x : xs)
forall a (f :: a -> *) (x :: a) (g :: a -> *) (xs :: [a]).
f x -> NS g xs -> Mismatch f g (x : xs)
ML (BlockQuery x result -> SingleEraInfo x
forall blk (query :: * -> * -> *) result.
SingleEraBlock blk =>
query blk result -> SingleEraInfo blk
queryInfo BlockQuery x result
qry) (Proxy SingleEraBlock
-> (forall a.
    SingleEraBlock a =>
    ExtLedgerState a -> LedgerEraInfo a)
-> NS ExtLedgerState xs
-> NS LedgerEraInfo xs
forall k l (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *).
(AllN (Prod h) c xs, HAp h) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a) -> h f xs -> h f' xs
hcmap Proxy SingleEraBlock
proxySingle forall a. SingleEraBlock a => ExtLedgerState a -> LedgerEraInfo a
ledgerInfo NS ExtLedgerState xs
st)
    go NP ExtLedgerCfg xs'
_         (QS QueryIfCurrent xs result
qry) (Z ExtLedgerState x
st) =
        MismatchEraInfo (x : xs)
-> Either (MismatchEraInfo (x : xs)) result
forall a b. a -> Either a b
Left (MismatchEraInfo (x : xs)
 -> Either (MismatchEraInfo (x : xs)) result)
-> MismatchEraInfo (x : xs)
-> Either (MismatchEraInfo (x : xs)) result
forall a b. (a -> b) -> a -> b
$ Mismatch SingleEraInfo LedgerEraInfo (x : xs)
-> MismatchEraInfo (x : xs)
forall (xs :: [*]).
Mismatch SingleEraInfo LedgerEraInfo xs -> MismatchEraInfo xs
MismatchEraInfo (Mismatch SingleEraInfo LedgerEraInfo (x : xs)
 -> MismatchEraInfo (x : xs))
-> Mismatch SingleEraInfo LedgerEraInfo (x : xs)
-> MismatchEraInfo (x : xs)
forall a b. (a -> b) -> a -> b
$ NS SingleEraInfo xs
-> LedgerEraInfo x -> Mismatch SingleEraInfo LedgerEraInfo (x : xs)
forall a (f :: a -> *) (xs :: [a]) (g :: a -> *) (x :: a).
NS f xs -> g x -> Mismatch f g (x : xs)
MR (QueryIfCurrent xs result -> NS SingleEraInfo xs
forall (xs :: [*]) result.
All SingleEraBlock xs =>
QueryIfCurrent xs result -> NS SingleEraInfo xs
hardForkQueryInfo QueryIfCurrent xs result
qry) (ExtLedgerState x -> LedgerEraInfo x
forall a. SingleEraBlock a => ExtLedgerState a -> LedgerEraInfo a
ledgerInfo ExtLedgerState x
st)

{-------------------------------------------------------------------------------
  Any era queries
-------------------------------------------------------------------------------}

data QueryAnytime result where
  GetEraStart :: QueryAnytime (Maybe Bound)

deriving instance Show (QueryAnytime result)

instance ShowQuery QueryAnytime where
  showResult :: QueryAnytime result -> result -> String
showResult QueryAnytime result
GetEraStart = result -> String
forall a. Show a => a -> String
show

instance SameDepIndex QueryAnytime where
  sameDepIndex :: QueryAnytime a -> QueryAnytime b -> Maybe (a :~: b)
sameDepIndex QueryAnytime a
GetEraStart QueryAnytime b
GetEraStart = (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl

interpretQueryAnytime ::
     forall result xs. All SingleEraBlock xs
  => HardForkLedgerConfig xs
  -> QueryAnytime result
  -> EraIndex xs
  -> State.HardForkState LedgerState xs
  -> result
interpretQueryAnytime :: HardForkLedgerConfig xs
-> QueryAnytime result
-> EraIndex xs
-> HardForkState LedgerState xs
-> result
interpretQueryAnytime HardForkLedgerConfig xs
cfg QueryAnytime result
query (EraIndex NS (K ()) xs
era) HardForkState LedgerState xs
st =
    HardForkLedgerConfig xs
-> QueryAnytime result -> Situated (K ()) LedgerState xs -> result
forall (xs :: [*]) result (h :: * -> *).
All SingleEraBlock xs =>
HardForkLedgerConfig xs
-> QueryAnytime result -> Situated h LedgerState xs -> result
answerQueryAnytime HardForkLedgerConfig xs
cfg QueryAnytime result
query (NS (K ()) xs
-> HardForkState LedgerState xs -> Situated (K ()) LedgerState xs
forall (h :: * -> *) (xs :: [*]) (f :: * -> *).
NS h xs -> HardForkState f xs -> Situated h f xs
State.situate NS (K ()) xs
era HardForkState LedgerState xs
st)

answerQueryAnytime ::
     All SingleEraBlock xs
  => HardForkLedgerConfig xs
  -> QueryAnytime result
  -> Situated h LedgerState xs
  -> result
answerQueryAnytime :: HardForkLedgerConfig xs
-> QueryAnytime result -> Situated h LedgerState xs -> result
answerQueryAnytime HardForkLedgerConfig{Shape xs
PerEraLedgerConfig xs
hardForkLedgerConfigPerEra :: forall (xs :: [*]).
HardForkLedgerConfig xs -> PerEraLedgerConfig xs
hardForkLedgerConfigShape :: forall (xs :: [*]). HardForkLedgerConfig xs -> Shape xs
hardForkLedgerConfigPerEra :: PerEraLedgerConfig xs
hardForkLedgerConfigShape :: Shape xs
..} =
    NP WrapPartialLedgerConfig xs
-> NP (K EraParams) xs
-> QueryAnytime result
-> Situated h LedgerState xs
-> result
forall (xs' :: [*]) result (h :: * -> *).
All SingleEraBlock xs' =>
NP WrapPartialLedgerConfig xs'
-> NP (K EraParams) xs'
-> QueryAnytime result
-> Situated h LedgerState xs'
-> result
go NP WrapPartialLedgerConfig xs
cfgs (Exactly xs EraParams -> NP (K EraParams) xs
forall (xs :: [*]) a. Exactly xs a -> NP (K a) xs
getExactly (Shape xs -> Exactly xs EraParams
forall (xs :: [*]). Shape xs -> Exactly xs EraParams
getShape Shape xs
hardForkLedgerConfigShape))
  where
    cfgs :: NP WrapPartialLedgerConfig xs
cfgs = PerEraLedgerConfig xs -> NP WrapPartialLedgerConfig xs
forall (xs :: [*]).
PerEraLedgerConfig xs -> NP WrapPartialLedgerConfig xs
getPerEraLedgerConfig PerEraLedgerConfig xs
hardForkLedgerConfigPerEra

    go :: All SingleEraBlock xs'
       => NP WrapPartialLedgerConfig xs'
       -> NP (K EraParams) xs'
       -> QueryAnytime result
       -> Situated h LedgerState xs'
       -> result
    go :: NP WrapPartialLedgerConfig xs'
-> NP (K EraParams) xs'
-> QueryAnytime result
-> Situated h LedgerState xs'
-> result
go NP WrapPartialLedgerConfig xs'
Nil       NP (K EraParams) xs'
_             QueryAnytime result
_           Situated h LedgerState xs'
ctxt = case Situated h LedgerState xs'
ctxt of {}
    go (WrapPartialLedgerConfig x
c :* NP WrapPartialLedgerConfig xs
cs) (K EraParams
ps :* NP (K EraParams) xs
pss) QueryAnytime result
GetEraStart Situated h LedgerState xs'
ctxt = case Situated h LedgerState xs'
ctxt of
      SituatedShift Situated h LedgerState xs
ctxt'   -> NP WrapPartialLedgerConfig xs
-> NP (K EraParams) xs
-> QueryAnytime (Maybe Bound)
-> Situated h LedgerState xs
-> Maybe Bound
forall (xs' :: [*]) result (h :: * -> *).
All SingleEraBlock xs' =>
NP WrapPartialLedgerConfig xs'
-> NP (K EraParams) xs'
-> QueryAnytime result
-> Situated h LedgerState xs'
-> result
go NP WrapPartialLedgerConfig xs
cs NP (K EraParams) xs
NP (K EraParams) xs
pss QueryAnytime (Maybe Bound)
GetEraStart Situated h LedgerState xs
Situated h LedgerState xs
ctxt'
      SituatedFuture Current LedgerState x
_ NS h xs
_    -> result
forall a. Maybe a
Nothing
      SituatedPast K Past x
past h x
_   -> Bound -> Maybe Bound
forall a. a -> Maybe a
Just (Bound -> Maybe Bound) -> Bound -> Maybe Bound
forall a b. (a -> b) -> a -> b
$ Past -> Bound
pastStart (Past -> Bound) -> Past -> Bound
forall a b. (a -> b) -> a -> b
$ K Past x -> Past
forall k a (b :: k). K a b -> a
unK K Past x
past
      SituatedCurrent Current LedgerState x
cur h x
_ -> Bound -> Maybe Bound
forall a. a -> Maybe a
Just (Bound -> Maybe Bound) -> Bound -> Maybe Bound
forall a b. (a -> b) -> a -> b
$ Current LedgerState x -> Bound
forall (f :: * -> *) blk. Current f blk -> Bound
currentStart Current LedgerState x
cur
      SituatedNext Current LedgerState x
cur h y
_    ->
        HasCallStack => EraParams -> Bound -> EpochNo -> Bound
EraParams -> Bound -> EpochNo -> Bound
History.mkUpperBound EraParams
ps (Current LedgerState x -> Bound
forall (f :: * -> *) blk. Current f blk -> Bound
currentStart Current LedgerState x
cur) (EpochNo -> Bound) -> Maybe EpochNo -> Maybe Bound
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
          PartialLedgerConfig x
-> EraParams -> Bound -> LedgerState x -> Maybe EpochNo
forall blk.
SingleEraBlock blk =>
PartialLedgerConfig blk
-> EraParams -> Bound -> LedgerState blk -> Maybe EpochNo
singleEraTransition
          (WrapPartialLedgerConfig x -> PartialLedgerConfig x
forall blk. WrapPartialLedgerConfig blk -> PartialLedgerConfig blk
unwrapPartialLedgerConfig WrapPartialLedgerConfig x
c)
          EraParams
ps
          (Current LedgerState x -> Bound
forall (f :: * -> *) blk. Current f blk -> Bound
currentStart Current LedgerState x
cur)
          (Current LedgerState x -> LedgerState x
forall (f :: * -> *) blk. Current f blk -> f blk
currentState Current LedgerState x
cur)

{-------------------------------------------------------------------------------
  Hard fork queries
-------------------------------------------------------------------------------}

data QueryHardFork xs result where
  GetInterpreter :: QueryHardFork xs (History.Interpreter xs)
  GetCurrentEra  :: QueryHardFork xs (EraIndex xs)

deriving instance Show (QueryHardFork xs result)

instance All SingleEraBlock xs => ShowQuery (QueryHardFork xs) where
  showResult :: QueryHardFork xs result -> result -> String
showResult QueryHardFork xs result
GetInterpreter = result -> String
forall a. Show a => a -> String
show
  showResult QueryHardFork xs result
GetCurrentEra  = result -> String
forall a. Show a => a -> String
show

instance SameDepIndex (QueryHardFork xs) where
  sameDepIndex :: QueryHardFork xs a -> QueryHardFork xs b -> Maybe (a :~: b)
sameDepIndex QueryHardFork xs a
GetInterpreter QueryHardFork xs b
GetInterpreter =
      (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
  sameDepIndex QueryHardFork xs a
GetInterpreter QueryHardFork xs b
_ =
      Maybe (a :~: b)
forall a. Maybe a
Nothing
  sameDepIndex QueryHardFork xs a
GetCurrentEra QueryHardFork xs b
GetCurrentEra =
      (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
  sameDepIndex QueryHardFork xs a
GetCurrentEra QueryHardFork xs b
_ =
      Maybe (a :~: b)
forall a. Maybe a
Nothing

interpretQueryHardFork ::
     All SingleEraBlock xs
  => HardForkLedgerConfig xs
  -> QueryHardFork xs result
  -> LedgerState (HardForkBlock xs)
  -> result
interpretQueryHardFork :: HardForkLedgerConfig xs
-> QueryHardFork xs result
-> LedgerState (HardForkBlock xs)
-> result
interpretQueryHardFork HardForkLedgerConfig xs
cfg QueryHardFork xs result
query LedgerState (HardForkBlock xs)
st =
    case QueryHardFork xs result
query of
      QueryHardFork xs result
GetInterpreter ->
        Summary xs -> Interpreter xs
forall (xs :: [*]). Summary xs -> Interpreter xs
History.mkInterpreter (Summary xs -> Interpreter xs) -> Summary xs -> Interpreter xs
forall a b. (a -> b) -> a -> b
$ LedgerConfig (HardForkBlock xs)
-> LedgerState (HardForkBlock xs)
-> Summary (HardForkIndices (HardForkBlock xs))
forall blk.
HasHardForkHistory blk =>
LedgerConfig blk
-> LedgerState blk -> Summary (HardForkIndices blk)
hardForkSummary LedgerConfig (HardForkBlock xs)
HardForkLedgerConfig xs
cfg LedgerState (HardForkBlock xs)
st
      QueryHardFork xs result
GetCurrentEra  ->
        NS LedgerState xs -> EraIndex xs
forall (xs :: [*]) (f :: * -> *).
SListI xs =>
NS f xs -> EraIndex xs
eraIndexFromNS (NS LedgerState xs -> EraIndex xs)
-> NS LedgerState xs -> EraIndex xs
forall a b. (a -> b) -> a -> b
$ HardForkState LedgerState xs -> NS LedgerState xs
forall (xs :: [*]) (f :: * -> *).
SListI xs =>
HardForkState f xs -> NS f xs
State.tip (HardForkState LedgerState xs -> NS LedgerState xs)
-> HardForkState LedgerState xs -> NS LedgerState xs
forall a b. (a -> b) -> a -> b
$ LedgerState (HardForkBlock xs) -> HardForkState LedgerState xs
forall (xs :: [*]).
LedgerState (HardForkBlock xs) -> HardForkState LedgerState xs
hardForkLedgerStatePerEra LedgerState (HardForkBlock xs)
st

{-------------------------------------------------------------------------------
  Serialisation
-------------------------------------------------------------------------------}

instance Serialise (Some QueryAnytime) where
  encode :: Some QueryAnytime -> Encoding
encode (Some QueryAnytime a
GetEraStart) = [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat [
        Word -> Encoding
Enc.encodeListLen Word
1
      , Word8 -> Encoding
Enc.encodeWord8 Word8
0
      ]

  decode :: Decoder s (Some QueryAnytime)
decode = do
    Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"QueryAnytime" Int
1
    Word8
tag <- Decoder s Word8
forall s. Decoder s Word8
Dec.decodeWord8
    case Word8
tag of
      Word8
0 -> Some QueryAnytime -> Decoder s (Some QueryAnytime)
forall (m :: * -> *) a. Monad m => a -> m a
return (Some QueryAnytime -> Decoder s (Some QueryAnytime))
-> Some QueryAnytime -> Decoder s (Some QueryAnytime)
forall a b. (a -> b) -> a -> b
$ QueryAnytime (Maybe Bound) -> Some QueryAnytime
forall k (f :: k -> *) (a :: k). f a -> Some f
Some QueryAnytime (Maybe Bound)
GetEraStart
      Word8
_ -> String -> Decoder s (Some QueryAnytime)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s (Some QueryAnytime))
-> String -> Decoder s (Some QueryAnytime)
forall a b. (a -> b) -> a -> b
$ String
"QueryAnytime: invalid tag " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
tag

encodeQueryAnytimeResult :: QueryAnytime result -> result -> Encoding
encodeQueryAnytimeResult :: QueryAnytime result -> result -> Encoding
encodeQueryAnytimeResult QueryAnytime result
GetEraStart = result -> Encoding
forall a. Serialise a => a -> Encoding
encode

decodeQueryAnytimeResult :: QueryAnytime result -> forall s. Decoder s result
decodeQueryAnytimeResult :: QueryAnytime result -> forall s. Decoder s result
decodeQueryAnytimeResult QueryAnytime result
GetEraStart = Decoder s result
forall a s. Serialise a => Decoder s a
decode

encodeQueryHardForkResult ::
     SListI xs
  => QueryHardFork xs result -> result -> Encoding
encodeQueryHardForkResult :: QueryHardFork xs result -> result -> Encoding
encodeQueryHardForkResult = \case
    QueryHardFork xs result
GetInterpreter -> result -> Encoding
forall a. Serialise a => a -> Encoding
encode
    QueryHardFork xs result
GetCurrentEra  -> result -> Encoding
forall a. Serialise a => a -> Encoding
encode

decodeQueryHardForkResult ::
     SListI xs
  => QueryHardFork xs result -> forall s. Decoder s result
decodeQueryHardForkResult :: QueryHardFork xs result -> forall s. Decoder s result
decodeQueryHardForkResult = \case
    QueryHardFork xs result
GetInterpreter -> Decoder s result
forall a s. Serialise a => Decoder s a
decode
    QueryHardFork xs result
GetCurrentEra  -> Decoder s result
forall a s. Serialise a => Decoder s a
decode

{-------------------------------------------------------------------------------
  Auxiliary
-------------------------------------------------------------------------------}

ledgerInfo :: forall blk. SingleEraBlock blk
           => ExtLedgerState blk
           -> LedgerEraInfo blk
ledgerInfo :: ExtLedgerState blk -> LedgerEraInfo blk
ledgerInfo ExtLedgerState blk
_ = SingleEraInfo blk -> LedgerEraInfo blk
forall blk. SingleEraInfo blk -> LedgerEraInfo blk
LedgerEraInfo (SingleEraInfo blk -> LedgerEraInfo blk)
-> SingleEraInfo blk -> LedgerEraInfo blk
forall a b. (a -> b) -> a -> b
$ Proxy blk -> SingleEraInfo blk
forall blk (proxy :: * -> *).
SingleEraBlock blk =>
proxy blk -> SingleEraInfo blk
singleEraInfo (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk)

queryInfo :: forall blk query result. SingleEraBlock blk
          => query blk result -> SingleEraInfo blk
queryInfo :: query blk result -> SingleEraInfo blk
queryInfo query blk result
_ = Proxy blk -> SingleEraInfo blk
forall blk (proxy :: * -> *).
SingleEraBlock blk =>
proxy blk -> SingleEraInfo blk
singleEraInfo (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk)

hardForkQueryInfo :: All SingleEraBlock xs
                  => QueryIfCurrent xs result -> NS SingleEraInfo xs
hardForkQueryInfo :: QueryIfCurrent xs result -> NS SingleEraInfo xs
hardForkQueryInfo = QueryIfCurrent xs result -> NS SingleEraInfo xs
forall (xs :: [*]) result.
All SingleEraBlock xs =>
QueryIfCurrent xs result -> NS SingleEraInfo xs
go
  where
    go :: All SingleEraBlock xs'
       => QueryIfCurrent xs' result -> NS SingleEraInfo xs'
    go :: QueryIfCurrent xs' result -> NS SingleEraInfo xs'
go (QZ BlockQuery x result
qry) = SingleEraInfo x -> NS SingleEraInfo (x : xs)
forall a (f :: a -> *) (x :: a) (xs :: [a]). f x -> NS f (x : xs)
Z (BlockQuery x result -> SingleEraInfo x
forall blk (query :: * -> * -> *) result.
SingleEraBlock blk =>
query blk result -> SingleEraInfo blk
queryInfo BlockQuery x result
qry)
    go (QS QueryIfCurrent xs result
qry) = NS SingleEraInfo xs -> NS SingleEraInfo (x : xs)
forall a (f :: a -> *) (xs :: [a]) (x :: a).
NS f xs -> NS f (x : xs)
S (QueryIfCurrent xs result -> NS SingleEraInfo xs
forall (xs :: [*]) result.
All SingleEraBlock xs =>
QueryIfCurrent xs result -> NS SingleEraInfo xs
go QueryIfCurrent xs result
qry)

shiftMismatch :: MismatchEraInfo xs -> MismatchEraInfo (x ': xs)
shiftMismatch :: MismatchEraInfo xs -> MismatchEraInfo (x : xs)
shiftMismatch = Mismatch SingleEraInfo LedgerEraInfo (x : xs)
-> MismatchEraInfo (x : xs)
forall (xs :: [*]).
Mismatch SingleEraInfo LedgerEraInfo xs -> MismatchEraInfo xs
MismatchEraInfo (Mismatch SingleEraInfo LedgerEraInfo (x : xs)
 -> MismatchEraInfo (x : xs))
-> (MismatchEraInfo xs
    -> Mismatch SingleEraInfo LedgerEraInfo (x : xs))
-> MismatchEraInfo xs
-> MismatchEraInfo (x : xs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mismatch SingleEraInfo LedgerEraInfo xs
-> Mismatch SingleEraInfo LedgerEraInfo (x : xs)
forall a (f :: a -> *) (g :: a -> *) (xs :: [a]) (x :: a).
Mismatch f g xs -> Mismatch f g (x : xs)
MS (Mismatch SingleEraInfo LedgerEraInfo xs
 -> Mismatch SingleEraInfo LedgerEraInfo (x : xs))
-> (MismatchEraInfo xs -> Mismatch SingleEraInfo LedgerEraInfo xs)
-> MismatchEraInfo xs
-> Mismatch SingleEraInfo LedgerEraInfo (x : xs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MismatchEraInfo xs -> Mismatch SingleEraInfo LedgerEraInfo xs
forall (xs :: [*]).
MismatchEraInfo xs -> Mismatch SingleEraInfo LedgerEraInfo xs
getMismatchEraInfo