{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE UndecidableInstances       #-}

-- | Newtypes around type families so that they can be partially applied
module Ouroboros.Consensus.TypeFamilyWrappers (
    -- * Block based
    WrapApplyTxErr(..)
  , WrapCannotForge(..)
  , WrapEnvelopeErr(..)
  , WrapForgeStateInfo(..)
  , WrapForgeStateUpdateError(..)
  , WrapGenTxId(..)
  , WrapHeaderHash(..)
  , WrapLedgerConfig(..)
  , WrapLedgerErr(..)
  , WrapLedgerUpdate(..)
  , WrapLedgerWarning(..)
  , WrapTipInfo(..)
    -- * Protocol based
  , WrapCanBeLeader(..)
  , WrapChainDepState(..)
  , WrapChainSelConfig(..)
  , WrapConsensusConfig(..)
  , WrapIsLeader(..)
  , WrapLedgerView(..)
  , WrapSelectView(..)
  , WrapValidateView(..)
  , WrapValidationErr(..)
    -- * Versioning
  , WrapNodeToNodeVersion(..)
  , WrapNodeToClientVersion(..)
    -- * Type family instances
  , Ticked(..)
  ) where

import           Codec.Serialise (Serialise)
import           NoThunks.Class (NoThunks)

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.HeaderValidation
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.Inspect
import           Ouroboros.Consensus.Ledger.SupportsMempool
import           Ouroboros.Consensus.Node.NetworkProtocolVersion
import           Ouroboros.Consensus.Protocol.Abstract

{-------------------------------------------------------------------------------
  Block based
-------------------------------------------------------------------------------}

newtype WrapApplyTxErr            blk = WrapApplyTxErr            { WrapApplyTxErr blk -> ApplyTxErr blk
unwrapApplyTxErr            :: ApplyTxErr               blk }
newtype WrapCannotForge           blk = WrapCannotForge           { WrapCannotForge blk -> CannotForge blk
unwrapCannotForge           :: CannotForge              blk }
newtype WrapEnvelopeErr           blk = WrapEnvelopeErr           { WrapEnvelopeErr blk -> OtherHeaderEnvelopeError blk
unwrapEnvelopeErr           :: OtherHeaderEnvelopeError blk }
newtype WrapForgeStateInfo        blk = WrapForgeStateInfo        { WrapForgeStateInfo blk -> ForgeStateInfo blk
unwrapForgeStateInfo        :: ForgeStateInfo           blk }
newtype WrapForgeStateUpdateError blk = WrapForgeStateUpdateError { WrapForgeStateUpdateError blk -> ForgeStateUpdateError blk
unwrapForgeStateUpdateError :: ForgeStateUpdateError    blk }
newtype WrapGenTxId               blk = WrapGenTxId               { WrapGenTxId blk -> GenTxId blk
unwrapGenTxId               :: GenTxId                  blk }
newtype WrapHeaderHash            blk = WrapHeaderHash            { WrapHeaderHash blk -> HeaderHash blk
unwrapHeaderHash            :: HeaderHash               blk }
newtype WrapLedgerConfig          blk = WrapLedgerConfig          { WrapLedgerConfig blk -> LedgerConfig blk
unwrapLedgerConfig          :: LedgerConfig             blk }
newtype WrapLedgerErr             blk = WrapLedgerErr             { WrapLedgerErr blk -> LedgerError blk
unwrapLedgerErr             :: LedgerError              blk }
newtype WrapLedgerUpdate          blk = WrapLedgerUpdate          { WrapLedgerUpdate blk -> LedgerUpdate blk
unwrapLedgerUpdate          :: LedgerUpdate             blk }
newtype WrapLedgerWarning         blk = WrapLedgerWarning         { WrapLedgerWarning blk -> LedgerWarning blk
unwrapLedgerWarning         :: LedgerWarning            blk }
newtype WrapTipInfo               blk = WrapTipInfo               { WrapTipInfo blk -> TipInfo blk
unwrapTipInfo               :: TipInfo                  blk }

{-------------------------------------------------------------------------------
  Consensus based
-------------------------------------------------------------------------------}

newtype WrapCanBeLeader     blk = WrapCanBeLeader     { WrapCanBeLeader blk -> CanBeLeader (BlockProtocol blk)
unwrapCanBeLeader     :: CanBeLeader     (BlockProtocol blk) }
newtype WrapChainDepState   blk = WrapChainDepState   { WrapChainDepState blk -> ChainDepState (BlockProtocol blk)
unwrapChainDepState   :: ChainDepState   (BlockProtocol blk) }
newtype WrapChainSelConfig  blk = WrapChainSelConfig  { WrapChainSelConfig blk -> ChainSelConfig (BlockProtocol blk)
unwrapChainSelConfig  :: ChainSelConfig  (BlockProtocol blk) }
newtype WrapConsensusConfig blk = WrapConsensusConfig { WrapConsensusConfig blk -> ConsensusConfig (BlockProtocol blk)
unwrapConsensusConfig :: ConsensusConfig (BlockProtocol blk) }
newtype WrapIsLeader        blk = WrapIsLeader        { WrapIsLeader blk -> IsLeader (BlockProtocol blk)
unwrapIsLeader        :: IsLeader        (BlockProtocol blk) }
newtype WrapLedgerView      blk = WrapLedgerView      { WrapLedgerView blk -> LedgerView (BlockProtocol blk)
unwrapLedgerView      :: LedgerView      (BlockProtocol blk) }
newtype WrapSelectView      blk = WrapSelectView      { WrapSelectView blk -> SelectView (BlockProtocol blk)
unwrapSelectView      :: SelectView      (BlockProtocol blk) }
newtype WrapValidateView    blk = WrapValidateView    { WrapValidateView blk -> ValidateView (BlockProtocol blk)
unwrapValidateView    :: ValidateView    (BlockProtocol blk) }
newtype WrapValidationErr   blk = WrapValidationErr   { WrapValidationErr blk -> ValidationErr (BlockProtocol blk)
unwrapValidationErr   :: ValidationErr   (BlockProtocol blk) }

{-------------------------------------------------------------------------------
  Versioning
-------------------------------------------------------------------------------}

newtype WrapNodeToNodeVersion   blk = WrapNodeToNodeVersion   { WrapNodeToNodeVersion blk -> BlockNodeToNodeVersion blk
unwrapNodeToNodeVersion   :: BlockNodeToNodeVersion   blk }
newtype WrapNodeToClientVersion blk = WrapNodeToClientVersion { WrapNodeToClientVersion blk -> BlockNodeToClientVersion blk
unwrapNodeToClientVersion :: BlockNodeToClientVersion blk }

{-------------------------------------------------------------------------------
  Instances
-------------------------------------------------------------------------------}

deriving instance Eq (ApplyTxErr               blk) => Eq (WrapApplyTxErr     blk)
deriving instance Eq (GenTxId                  blk) => Eq (WrapGenTxId        blk)
deriving instance Eq (LedgerError              blk) => Eq (WrapLedgerErr      blk)
deriving instance Eq (LedgerUpdate             blk) => Eq (WrapLedgerUpdate   blk)
deriving instance Eq (LedgerWarning            blk) => Eq (WrapLedgerWarning  blk)
deriving instance Eq (OtherHeaderEnvelopeError blk) => Eq (WrapEnvelopeErr    blk)
deriving instance Eq (TipInfo                  blk) => Eq (WrapTipInfo        blk)

deriving instance Ord (GenTxId blk) => Ord (WrapGenTxId blk)

deriving instance Show (ApplyTxErr               blk) => Show (WrapApplyTxErr            blk)
deriving instance Show (CannotForge              blk) => Show (WrapCannotForge           blk)
deriving instance Show (ForgeStateInfo           blk) => Show (WrapForgeStateInfo        blk)
deriving instance Show (ForgeStateUpdateError    blk) => Show (WrapForgeStateUpdateError blk)
deriving instance Show (GenTxId                  blk) => Show (WrapGenTxId               blk)
deriving instance Show (LedgerError              blk) => Show (WrapLedgerErr             blk)
deriving instance Show (LedgerUpdate             blk) => Show (WrapLedgerUpdate          blk)
deriving instance Show (LedgerWarning            blk) => Show (WrapLedgerWarning         blk)
deriving instance Show (OtherHeaderEnvelopeError blk) => Show (WrapEnvelopeErr           blk)
deriving instance Show (TipInfo                  blk) => Show (WrapTipInfo               blk)

deriving instance NoThunks (GenTxId                  blk) => NoThunks (WrapGenTxId         blk)
deriving instance NoThunks (LedgerError              blk) => NoThunks (WrapLedgerErr       blk)
deriving instance NoThunks (OtherHeaderEnvelopeError blk) => NoThunks (WrapEnvelopeErr     blk)
deriving instance NoThunks (TipInfo                  blk) => NoThunks (WrapTipInfo         blk)

{-------------------------------------------------------------------------------
  .. consensus based
-------------------------------------------------------------------------------}

deriving instance Eq (ChainDepState  (BlockProtocol blk)) => Eq (WrapChainDepState  blk)
deriving instance Eq (ChainSelConfig (BlockProtocol blk)) => Eq (WrapChainSelConfig blk)
deriving instance Eq (ValidationErr  (BlockProtocol blk)) => Eq (WrapValidationErr  blk)

deriving instance Show (ChainDepState  (BlockProtocol blk)) => Show (WrapChainDepState  blk)
deriving instance Show (ChainSelConfig (BlockProtocol blk)) => Show (WrapChainSelConfig blk)
deriving instance Show (LedgerView     (BlockProtocol blk)) => Show (WrapLedgerView     blk)
deriving instance Show (SelectView     (BlockProtocol blk)) => Show (WrapSelectView     blk)
deriving instance Show (ValidationErr  (BlockProtocol blk)) => Show (WrapValidationErr  blk)

deriving instance NoThunks (ChainSelConfig (BlockProtocol blk)) => NoThunks (WrapChainSelConfig blk)
deriving instance NoThunks (ChainDepState  (BlockProtocol blk)) => NoThunks (WrapChainDepState  blk)
deriving instance NoThunks (ValidationErr  (BlockProtocol blk)) => NoThunks (WrapValidationErr  blk)

{-------------------------------------------------------------------------------
  Versioning
-------------------------------------------------------------------------------}

deriving instance Show (BlockNodeToNodeVersion   blk) => Show (WrapNodeToNodeVersion   blk)
deriving instance Show (BlockNodeToClientVersion blk) => Show (WrapNodeToClientVersion blk)

deriving instance Eq (BlockNodeToNodeVersion   blk) => Eq (WrapNodeToNodeVersion   blk)
deriving instance Eq (BlockNodeToClientVersion blk) => Eq (WrapNodeToClientVersion blk)

{-------------------------------------------------------------------------------
  Serialise instances

  These are primarily useful in testing.
-------------------------------------------------------------------------------}

deriving instance Serialise (GenTxId                      blk)  => Serialise (WrapGenTxId       blk)
deriving instance Serialise (ChainDepState (BlockProtocol blk)) => Serialise (WrapChainDepState blk)
deriving instance Serialise (TipInfo                      blk)  => Serialise (WrapTipInfo       blk)

{-------------------------------------------------------------------------------
  Ticking

  These are just forwarding instances
-------------------------------------------------------------------------------}

newtype instance Ticked (WrapLedgerView blk) = WrapTickedLedgerView {
      Ticked (WrapLedgerView blk)
-> Ticked (LedgerView (BlockProtocol blk))
unwrapTickedLedgerView :: Ticked (LedgerView (BlockProtocol blk))
    }

newtype instance Ticked (WrapChainDepState blk) = WrapTickedChainDepState {
      Ticked (WrapChainDepState blk)
-> Ticked (ChainDepState (BlockProtocol blk))
unwrapTickedChainDepState :: Ticked (ChainDepState (BlockProtocol blk))
    }