{-# 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 (..)
  , WrapLedgerEvent (..)
  , WrapLedgerUpdate (..)
  , WrapLedgerWarning (..)
  , WrapTentativeHeaderState (..)
  , WrapTentativeHeaderView (..)
  , WrapTipInfo (..)
  , WrapTxIn (..)
  , WrapTxMeasure (..)
  , WrapTxOut (..)
  , WrapValidatedGenTx (..)

    -- * Protocol based
  , WrapCanBeLeader (..)
  , WrapChainDepState (..)
  , WrapChainOrderConfig (..)
  , WrapConsensusConfig (..)
  , WrapIsLeader (..)
  , WrapLedgerView (..)
  , WrapSelectView (..)
  , WrapValidateView (..)
  , WrapValidationErr (..)

    -- * Versioning
  , WrapNodeToClientVersion (..)
  , WrapNodeToNodeVersion (..)

    -- * 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 {forall blk. WrapApplyTxErr blk -> ApplyTxErr blk
unwrapApplyTxErr :: ApplyTxErr blk}
newtype WrapCannotForge blk = WrapCannotForge {forall blk. WrapCannotForge blk -> CannotForge blk
unwrapCannotForge :: CannotForge blk}
newtype WrapEnvelopeErr blk = WrapEnvelopeErr {forall blk. WrapEnvelopeErr blk -> OtherHeaderEnvelopeError blk
unwrapEnvelopeErr :: OtherHeaderEnvelopeError blk}
newtype WrapForgeStateInfo blk = WrapForgeStateInfo {forall blk. WrapForgeStateInfo blk -> ForgeStateInfo blk
unwrapForgeStateInfo :: ForgeStateInfo blk}
newtype WrapForgeStateUpdateError blk = WrapForgeStateUpdateError {forall blk.
WrapForgeStateUpdateError blk -> ForgeStateUpdateError blk
unwrapForgeStateUpdateError :: ForgeStateUpdateError blk}
newtype WrapGenTxId blk = WrapGenTxId {forall blk. WrapGenTxId blk -> GenTxId blk
unwrapGenTxId :: GenTxId blk}
newtype WrapHeaderHash blk = WrapHeaderHash {forall blk. WrapHeaderHash blk -> HeaderHash blk
unwrapHeaderHash :: HeaderHash blk}
newtype WrapLedgerConfig blk = WrapLedgerConfig {forall blk. WrapLedgerConfig blk -> LedgerConfig blk
unwrapLedgerConfig :: LedgerConfig blk}
newtype WrapLedgerEvent blk = WrapLedgerEvent {forall blk. WrapLedgerEvent blk -> AuxLedgerEvent (LedgerState blk)
unwrapLedgerEvent :: AuxLedgerEvent (LedgerState blk)}
newtype WrapLedgerErr blk = WrapLedgerErr {forall blk. WrapLedgerErr blk -> LedgerError blk
unwrapLedgerErr :: LedgerError blk}
newtype WrapLedgerUpdate blk = WrapLedgerUpdate {forall blk. WrapLedgerUpdate blk -> LedgerUpdate blk
unwrapLedgerUpdate :: LedgerUpdate blk}
newtype WrapLedgerWarning blk = WrapLedgerWarning {forall blk. WrapLedgerWarning blk -> LedgerWarning blk
unwrapLedgerWarning :: LedgerWarning blk}
newtype WrapTentativeHeaderState blk = WrapTentativeHeaderState {forall blk.
WrapTentativeHeaderState blk -> TentativeHeaderState blk
unwrapTentativeHeaderState :: TentativeHeaderState blk}
newtype WrapTentativeHeaderView blk = WrapTentativeHeaderView {forall blk. WrapTentativeHeaderView blk -> TentativeHeaderView blk
unwrapTentativeHeaderView :: TentativeHeaderView blk}
newtype WrapTipInfo blk = WrapTipInfo {forall blk. WrapTipInfo blk -> TipInfo blk
unwrapTipInfo :: TipInfo blk}

-- | A data family wrapper for @'Validated' . 'GenTx'@
--
-- 'Validated' is is data family, so this is an outlier in this module full of
-- type family wrappers. However, the standard functor composition operator @f
-- :.: g@ incurs some type classes instances that are inappropriate when the
-- outer type constructor @f@ is a family and hence non-parametric (eg @'Eq' (f
-- :.: g)@ requires @'Data.Functor.Classes.Eq1' f)). The bespoke composition
-- 'WrapValidatedGenTx' therefore serves much the same purpose as the other
-- wrappers in this module.
newtype WrapValidatedGenTx blk = WrapValidatedGenTx {forall blk. WrapValidatedGenTx blk -> Validated (GenTx blk)
unwrapValidatedGenTx :: Validated (GenTx blk)}

newtype WrapTxMeasure blk = WrapTxMeasure {forall blk. WrapTxMeasure blk -> TxMeasure blk
unwrapTxMeasure :: TxMeasure blk}

newtype WrapTxIn blk = WrapTxIn {forall blk. WrapTxIn blk -> TxIn (LedgerState blk)
unwrapTxIn :: TxIn (LedgerState blk)}
newtype WrapTxOut blk = WrapTxOut {forall blk. WrapTxOut blk -> TxOut (LedgerState blk)
unwrapTxOut :: TxOut (LedgerState blk)}

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

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

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

newtype WrapNodeToNodeVersion blk = WrapNodeToNodeVersion {forall blk. WrapNodeToNodeVersion blk -> BlockNodeToNodeVersion blk
unwrapNodeToNodeVersion :: BlockNodeToNodeVersion blk}
newtype WrapNodeToClientVersion blk = WrapNodeToClientVersion {forall blk.
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 (TentativeHeaderState blk) => Eq (WrapTentativeHeaderState blk)
deriving instance Eq (TentativeHeaderView blk) => Eq (WrapTentativeHeaderView blk)
deriving instance Eq (TipInfo blk) => Eq (WrapTipInfo blk)
deriving instance Eq (Validated (GenTx blk)) => Eq (WrapValidatedGenTx blk)

deriving instance Ord (GenTxId blk) => Ord (WrapGenTxId blk)
deriving instance Ord (TentativeHeaderState blk) => Ord (WrapTentativeHeaderState 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 (TentativeHeaderState blk) => Show (WrapTentativeHeaderState blk)
deriving instance Show (TentativeHeaderView blk) => Show (WrapTentativeHeaderView blk)
deriving instance Show (TipInfo blk) => Show (WrapTipInfo blk)
deriving instance Show (Validated (GenTx blk)) => Show (WrapValidatedGenTx 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 (TentativeHeaderState blk) => NoThunks (WrapTentativeHeaderState blk)
deriving instance
  NoThunks (TipInfo blk) => NoThunks (WrapTipInfo blk)
deriving instance
  NoThunks (Validated (GenTx blk)) => NoThunks (WrapValidatedGenTx blk)

deriving instance Show (TxIn (LedgerState blk)) => Show (WrapTxIn blk)
deriving instance Eq (TxIn (LedgerState blk)) => Eq (WrapTxIn blk)
deriving instance Ord (TxIn (LedgerState blk)) => Ord (WrapTxIn blk)
deriving instance NoThunks (TxIn (LedgerState blk)) => NoThunks (WrapTxIn blk)

deriving instance Show (TxOut (LedgerState blk)) => Show (WrapTxOut blk)
deriving instance Eq (TxOut (LedgerState blk)) => Eq (WrapTxOut blk)
deriving instance Ord (TxOut (LedgerState blk)) => Ord (WrapTxOut blk)
deriving instance NoThunks (TxOut (LedgerState blk)) => NoThunks (WrapTxOut blk)

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

deriving instance Eq (ChainDepState (BlockProtocol blk)) => Eq (WrapChainDepState blk)
deriving instance Eq (SelectView (BlockProtocol blk)) => Eq (WrapSelectView blk)
deriving instance Eq (ValidationErr (BlockProtocol blk)) => Eq (WrapValidationErr blk)

deriving instance Ord (SelectView (BlockProtocol blk)) => Ord (WrapSelectView blk)

deriving instance ChainOrder (SelectView (BlockProtocol blk)) => ChainOrder (WrapSelectView blk)

deriving instance Show (ChainDepState (BlockProtocol blk)) => Show (WrapChainDepState 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 (ChainDepState (BlockProtocol blk)) => NoThunks (WrapChainDepState blk)
deriving instance NoThunks (SelectView (BlockProtocol blk)) => NoThunks (WrapSelectView 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 (WrapChainDepState blk) = WrapTickedChainDepState
  { forall blk.
Ticked (WrapChainDepState blk)
-> Ticked (ChainDepState (BlockProtocol blk))
unwrapTickedChainDepState :: Ticked (ChainDepState (BlockProtocol blk))
  }