{-# 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))
    }