{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE EmptyCase           #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators       #-}

module Ouroboros.Consensus.HardFork.Combinator.Compat (
    HardForkCompatQuery (..)
    -- * Convenience constructors
  , compatGetEraStart
  , compatGetInterpreter
  , compatIfCurrent
    -- * Wrappers
  , forwardCompatQuery
  , singleEraCompatQuery
  ) where

import           Data.Kind (Type)
import           Data.SOP.Strict

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.BlockchainTime
import           Ouroboros.Consensus.HardFork.History.Summary (Bound, Summary,
                     initBound, neverForksSummary)
import           Ouroboros.Consensus.Util.SOP

import           Ouroboros.Consensus.HardFork.Abstract
import           Ouroboros.Consensus.HardFork.Combinator.Abstract.SingleEraBlock
import           Ouroboros.Consensus.HardFork.Combinator.Basics
import           Ouroboros.Consensus.HardFork.Combinator.Ledger.Query
import qualified Ouroboros.Consensus.HardFork.History.Qry as Qry

{-------------------------------------------------------------------------------
  Query language
-------------------------------------------------------------------------------}

-- | Version of @Query (HardForkBlock xs)@ without the restriction to have
-- at least two eras
data HardForkCompatQuery blk :: Type -> Type where
  CompatIfCurrent ::
       BlockQuery blk result
    -> HardForkCompatQuery blk result

  CompatAnytime ::
       QueryAnytime result
    -> EraIndex (HardForkIndices blk)
    -> HardForkCompatQuery blk result

  CompatHardFork ::
       QueryHardFork (HardForkIndices blk) result
    -> HardForkCompatQuery blk result

{-------------------------------------------------------------------------------
  Convenience constructors for 'HardForkCompatQuery'
-------------------------------------------------------------------------------}

-- | Submit query to underlying ledger
compatIfCurrent ::
     BlockQuery blk result
  -> HardForkCompatQuery blk result
compatIfCurrent :: BlockQuery blk result -> HardForkCompatQuery blk result
compatIfCurrent = BlockQuery blk result -> HardForkCompatQuery blk result
forall blk result.
BlockQuery blk result -> HardForkCompatQuery blk result
CompatIfCurrent

-- | Get the start of the specified era, if known
compatGetEraStart ::
     EraIndex (HardForkIndices blk)
  -> HardForkCompatQuery blk (Maybe Bound)
compatGetEraStart :: EraIndex (HardForkIndices blk)
-> HardForkCompatQuery blk (Maybe Bound)
compatGetEraStart = QueryAnytime (Maybe Bound)
-> EraIndex (HardForkIndices blk)
-> HardForkCompatQuery blk (Maybe Bound)
forall result blk.
QueryAnytime result
-> EraIndex (HardForkIndices blk) -> HardForkCompatQuery blk result
CompatAnytime QueryAnytime (Maybe Bound)
GetEraStart

-- | Get an interpreter for history queries
--
-- I.e., this can be used for slot/epoch/time conversions.
compatGetInterpreter ::
    HardForkCompatQuery blk (Qry.Interpreter (HardForkIndices blk))
compatGetInterpreter :: HardForkCompatQuery blk (Interpreter (HardForkIndices blk))
compatGetInterpreter = QueryHardFork
  (HardForkIndices blk) (Interpreter (HardForkIndices blk))
-> HardForkCompatQuery blk (Interpreter (HardForkIndices blk))
forall blk result.
QueryHardFork (HardForkIndices blk) result
-> HardForkCompatQuery blk result
CompatHardFork QueryHardFork
  (HardForkIndices blk) (Interpreter (HardForkIndices blk))
forall (xs :: [*]). QueryHardFork xs (Interpreter xs)
GetInterpreter

{-------------------------------------------------------------------------------
  Wrappers
-------------------------------------------------------------------------------}

-- | Wrapper used when connecting to a server that's running the HFC with
-- at least two eras
forwardCompatQuery ::
       forall m x xs. IsNonEmpty xs
    => (forall result. BlockQuery (HardForkBlock (x ': xs)) result -> m result)
    -- ^ Submit a query through the LocalStateQuery protocol.
    -> (forall result. HardForkCompatQuery (HardForkBlock (x ': xs)) result -> m result)
forwardCompatQuery :: (forall result.
 BlockQuery (HardForkBlock (x : xs)) result -> m result)
-> forall result.
   HardForkCompatQuery (HardForkBlock (x : xs)) result -> m result
forwardCompatQuery forall result.
BlockQuery (HardForkBlock (x : xs)) result -> m result
f = HardForkCompatQuery (HardForkBlock (x : xs)) result -> m result
forall result.
HardForkCompatQuery (HardForkBlock (x : xs)) result -> m result
go
  where
    go :: HardForkCompatQuery (HardForkBlock (x ': xs)) result -> m result
    go :: HardForkCompatQuery (HardForkBlock (x : xs)) result -> m result
go (CompatIfCurrent BlockQuery (HardForkBlock (x : xs)) result
qry)    = BlockQuery (HardForkBlock (x : xs)) result -> m result
forall result.
BlockQuery (HardForkBlock (x : xs)) result -> m result
f BlockQuery (HardForkBlock (x : xs)) result
qry
    go (CompatAnytime   QueryAnytime result
qry EraIndex (HardForkIndices (HardForkBlock (x : xs)))
ix) = BlockQuery (HardForkBlock (x : xs)) result -> m result
forall result.
BlockQuery (HardForkBlock (x : xs)) result -> m result
f (QueryAnytime result
-> EraIndex (x : xs) -> BlockQuery (HardForkBlock (x : xs)) result
forall (xs :: [*]) result xs.
IsNonEmpty xs =>
QueryAnytime result
-> EraIndex (xs : xs)
-> BlockQuery (HardForkBlock (xs : xs)) result
QueryAnytime QueryAnytime result
qry EraIndex (x : xs)
EraIndex (HardForkIndices (HardForkBlock (x : xs)))
ix)
    go (CompatHardFork  QueryHardFork (HardForkIndices (HardForkBlock (x : xs))) result
qry)    = BlockQuery (HardForkBlock (x : xs)) result -> m result
forall result.
BlockQuery (HardForkBlock (x : xs)) result -> m result
f (QueryHardFork (x : xs) result
-> BlockQuery (HardForkBlock (x : xs)) result
forall (xs :: [*]) x result.
IsNonEmpty xs =>
QueryHardFork (x : xs) result
-> BlockQuery (HardForkBlock (x : xs)) result
QueryHardFork QueryHardFork (x : xs) result
QueryHardFork (HardForkIndices (HardForkBlock (x : xs))) result
qry)

-- | Wrapper used when connecting to a server that's not using the HFC, or
-- is using the HFC but with a single era only.
singleEraCompatQuery ::
       forall m blk era. (Monad m, HardForkIndices blk ~ '[era])
    => EpochSize
    -> SlotLength
    -> (forall result. BlockQuery blk result -> m result)
    -- ^ Submit a query through the LocalStateQuery protocol.
    -> (forall result. HardForkCompatQuery blk result -> m result)
singleEraCompatQuery :: EpochSize
-> SlotLength
-> (forall result. BlockQuery blk result -> m result)
-> forall result. HardForkCompatQuery blk result -> m result
singleEraCompatQuery EpochSize
epochSize SlotLength
slotLen forall result. BlockQuery blk result -> m result
f = HardForkCompatQuery blk result -> m result
forall result. HardForkCompatQuery blk result -> m result
go
  where
    go :: HardForkCompatQuery blk result -> m result
    go :: HardForkCompatQuery blk result -> m result
go (CompatIfCurrent BlockQuery blk result
qry)    = BlockQuery blk result -> m result
forall result. BlockQuery blk result -> m result
f BlockQuery blk result
qry
    go (CompatAnytime   QueryAnytime result
qry EraIndex (HardForkIndices blk)
ix) = m result -> () -> m result
forall a b. a -> b -> a
const (QueryAnytime result -> m result
forall result. QueryAnytime result -> m result
goAnytime QueryAnytime result
qry) (EraIndex '[era] -> ()
trivialIndex EraIndex '[era]
EraIndex (HardForkIndices blk)
ix)
    go (CompatHardFork  QueryHardFork (HardForkIndices blk) result
qry)    = QueryHardFork '[era] result -> m result
forall result. QueryHardFork '[era] result -> m result
goHardFork QueryHardFork '[era] result
QueryHardFork (HardForkIndices blk) result
qry

    goAnytime :: QueryAnytime result -> m result
    goAnytime :: QueryAnytime result -> m result
goAnytime QueryAnytime result
GetEraStart = Maybe Bound -> m (Maybe Bound)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Bound -> m (Maybe Bound)) -> Maybe Bound -> m (Maybe Bound)
forall a b. (a -> b) -> a -> b
$ Bound -> Maybe Bound
forall a. a -> Maybe a
Just Bound
initBound

    goHardFork :: QueryHardFork '[era] result -> m result
    goHardFork :: QueryHardFork '[era] result -> m result
goHardFork QueryHardFork '[era] result
GetInterpreter = Interpreter '[era] -> m (Interpreter '[era])
forall (m :: * -> *) a. Monad m => a -> m a
return (Interpreter '[era] -> m (Interpreter '[era]))
-> Interpreter '[era] -> m (Interpreter '[era])
forall a b. (a -> b) -> a -> b
$ Summary '[era] -> Interpreter '[era]
forall (xs :: [*]). Summary xs -> Interpreter xs
Qry.mkInterpreter Summary '[era]
summary
    goHardFork QueryHardFork '[era] result
GetCurrentEra  = EraIndex '[era] -> m (EraIndex '[era])
forall (m :: * -> *) a. Monad m => a -> m a
return (EraIndex '[era] -> m (EraIndex '[era]))
-> EraIndex '[era] -> m (EraIndex '[era])
forall a b. (a -> b) -> a -> b
$ EraIndex '[era]
forall x (xs :: [*]). EraIndex (x : xs)
eraIndexZero

    summary :: Summary '[era]
    summary :: Summary '[era]
summary = EpochSize -> SlotLength -> Summary '[era]
forall x. EpochSize -> SlotLength -> Summary '[x]
neverForksSummary EpochSize
epochSize SlotLength
slotLen

    trivialIndex :: EraIndex '[era] -> ()
    trivialIndex :: EraIndex '[era] -> ()
trivialIndex (EraIndex (Z (K ()))) = ()