{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Ouroboros.Consensus.HardFork.Combinator.Degenerate
  ( -- * Pattern synonyms
    BlockConfig (DegenBlockConfig)
  , BlockQuery (DegenQuery)
  , CodecConfig (DegenCodecConfig)
  , ConsensusConfig (DegenConsensusConfig)
  , Either (DegenQueryResult)
  , GenTx (DegenGenTx)
  , HardForkApplyTxErr (DegenApplyTxErr)
  , HardForkBlock (DegenBlock)
  , HardForkEnvelopeErr (DegenOtherHeaderEnvelopeError)
  , HardForkLedgerConfig (DegenLedgerConfig)
  , HardForkLedgerError (DegenLedgerError)
  , Header (DegenHeader)
  , LedgerState (DegenLedgerState)
  , OneEraTipInfo (DegenTipInfo)
  , TopLevelConfig (DegenTopLevelConfig)
  , TxId (DegenGenTxId)
  ) where

import Data.SOP.Functors (Flip (..))
import Data.SOP.Strict
import Ouroboros.Consensus.Block.Abstract
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.HardFork.Combinator.Abstract.NoHardForks
import Ouroboros.Consensus.HardFork.Combinator.AcrossEras
import Ouroboros.Consensus.HardFork.Combinator.Basics
import Ouroboros.Consensus.HardFork.Combinator.Embed.Unary
import Ouroboros.Consensus.HardFork.Combinator.Ledger
import Ouroboros.Consensus.HardFork.Combinator.Ledger.CommonProtocolParams ()
import Ouroboros.Consensus.HardFork.Combinator.Ledger.Query
import Ouroboros.Consensus.HardFork.Combinator.Mempool
import Ouroboros.Consensus.HardFork.Combinator.Node ()
import Ouroboros.Consensus.HardFork.Combinator.PartialConfig
import Ouroboros.Consensus.HardFork.Combinator.Serialisation.SerialiseDisk ()
import Ouroboros.Consensus.HardFork.Combinator.Serialisation.SerialiseNodeToClient ()
import Ouroboros.Consensus.HardFork.Combinator.Serialisation.SerialiseNodeToNode ()
import Ouroboros.Consensus.HeaderValidation
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.SupportsMempool
import Ouroboros.Consensus.TypeFamilyWrappers

{-------------------------------------------------------------------------------
  Simple patterns
-------------------------------------------------------------------------------}

{-# COMPLETE DegenApplyTxErr #-}
{-# COMPLETE DegenBlock #-}
{-# COMPLETE DegenBlockConfig #-}
{-# COMPLETE DegenCodecConfig #-}
{-# COMPLETE DegenGenTx #-}
{-# COMPLETE DegenGenTxId #-}
{-# COMPLETE DegenHeader #-}
{-# COMPLETE DegenLedgerError #-}
{-# COMPLETE DegenLedgerState #-}
{-# COMPLETE DegenOtherHeaderEnvelopeError #-}
{-# COMPLETE DegenQuery #-}
{-# COMPLETE DegenQueryResult #-}
{-# COMPLETE DegenTipInfo #-}

pattern DegenBlock ::
  forall b.
  NoHardForks b =>
  b ->
  HardForkBlock '[b]
pattern $mDegenBlock :: forall {r} {b}.
NoHardForks b =>
HardForkBlock '[b] -> (b -> r) -> ((# #) -> r) -> r
$bDegenBlock :: forall b. NoHardForks b => b -> HardForkBlock '[b]
DegenBlock x <- (project' (Proxy @(I b)) -> x)
  where
    DegenBlock b
x = Proxy (I b) -> b -> HardForkBlock '[b]
forall (proxy :: * -> *) (f :: * -> *) x y blk.
(Isomorphic f, NoHardForks blk, Coercible x (f blk),
 Coercible y (f (HardForkBlock '[blk]))) =>
proxy (f blk) -> x -> y
inject' (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(I b)) b
x

pattern DegenHeader ::
  NoHardForks b =>
  Header b ->
  Header (HardForkBlock '[b])
pattern $mDegenHeader :: forall {r} {b}.
NoHardForks b =>
Header (HardForkBlock '[b]) -> (Header b -> r) -> ((# #) -> r) -> r
$bDegenHeader :: forall b. NoHardForks b => Header b -> Header (HardForkBlock '[b])
DegenHeader x <- (project -> x)
  where
    DegenHeader Header b
x = Header b -> Header (HardForkBlock '[b])
forall b. NoHardForks b => Header b -> Header (HardForkBlock '[b])
forall (f :: * -> *) blk.
(Isomorphic f, NoHardForks blk) =>
f blk -> f (HardForkBlock '[blk])
inject Header b
x

pattern DegenGenTx ::
  NoHardForks b =>
  GenTx b ->
  GenTx (HardForkBlock '[b])
pattern $mDegenGenTx :: forall {r} {b}.
NoHardForks b =>
GenTx (HardForkBlock '[b]) -> (GenTx b -> r) -> ((# #) -> r) -> r
$bDegenGenTx :: forall b. NoHardForks b => GenTx b -> GenTx (HardForkBlock '[b])
DegenGenTx x <- (project -> x)
  where
    DegenGenTx GenTx b
x = GenTx b -> GenTx (HardForkBlock '[b])
forall b. NoHardForks b => GenTx b -> GenTx (HardForkBlock '[b])
forall (f :: * -> *) blk.
(Isomorphic f, NoHardForks blk) =>
f blk -> f (HardForkBlock '[blk])
inject GenTx b
x

pattern DegenGenTxId ::
  forall b.
  NoHardForks b =>
  GenTxId b ->
  GenTxId (HardForkBlock '[b])
pattern $mDegenGenTxId :: forall {r} {b}.
NoHardForks b =>
GenTxId (HardForkBlock '[b])
-> (GenTxId b -> r) -> ((# #) -> r) -> r
$bDegenGenTxId :: forall b.
NoHardForks b =>
GenTxId b -> GenTxId (HardForkBlock '[b])
DegenGenTxId x <- (project' (Proxy @(WrapGenTxId b)) -> x)
  where
    DegenGenTxId GenTxId b
x = Proxy (WrapGenTxId b) -> GenTxId b -> GenTxId (HardForkBlock '[b])
forall (proxy :: * -> *) (f :: * -> *) x y blk.
(Isomorphic f, NoHardForks blk, Coercible x (f blk),
 Coercible y (f (HardForkBlock '[blk]))) =>
proxy (f blk) -> x -> y
inject' (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(WrapGenTxId b)) GenTxId b
x

pattern DegenApplyTxErr ::
  forall b.
  NoHardForks b =>
  ApplyTxErr b ->
  HardForkApplyTxErr '[b] -- ApplyTxErr (HardForkBlock '[b])
pattern $mDegenApplyTxErr :: forall {r} {b}.
NoHardForks b =>
HardForkApplyTxErr '[b] -> (ApplyTxErr b -> r) -> ((# #) -> r) -> r
$bDegenApplyTxErr :: forall b. NoHardForks b => ApplyTxErr b -> HardForkApplyTxErr '[b]
DegenApplyTxErr x <- (project' (Proxy @(WrapApplyTxErr b)) -> x)
  where
    DegenApplyTxErr ApplyTxErr b
x = Proxy (WrapApplyTxErr b) -> ApplyTxErr b -> HardForkApplyTxErr '[b]
forall (proxy :: * -> *) (f :: * -> *) x y blk.
(Isomorphic f, NoHardForks blk, Coercible x (f blk),
 Coercible y (f (HardForkBlock '[blk]))) =>
proxy (f blk) -> x -> y
inject' (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(WrapApplyTxErr b)) ApplyTxErr b
x

pattern DegenLedgerError ::
  forall b.
  NoHardForks b =>
  LedgerError b ->
  HardForkLedgerError '[b] -- LedgerError (HardForkBlock '[b])
pattern $mDegenLedgerError :: forall {r} {b}.
NoHardForks b =>
HardForkLedgerError '[b]
-> (LedgerError b -> r) -> ((# #) -> r) -> r
$bDegenLedgerError :: forall b.
NoHardForks b =>
LedgerError b -> HardForkLedgerError '[b]
DegenLedgerError x <- (project' (Proxy @(WrapLedgerErr b)) -> x)
  where
    DegenLedgerError LedgerErr (LedgerState b)
x = Proxy (WrapLedgerErr b)
-> LedgerErr (LedgerState b) -> HardForkLedgerError '[b]
forall (proxy :: * -> *) (f :: * -> *) x y blk.
(Isomorphic f, NoHardForks blk, Coercible x (f blk),
 Coercible y (f (HardForkBlock '[blk]))) =>
proxy (f blk) -> x -> y
inject' (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(WrapLedgerErr b)) LedgerErr (LedgerState b)
x

pattern DegenOtherHeaderEnvelopeError ::
  forall b.
  NoHardForks b =>
  OtherHeaderEnvelopeError b ->
  HardForkEnvelopeErr '[b] -- OtherHeaderEnvelopeError (HardForkBlock '[b])
pattern $mDegenOtherHeaderEnvelopeError :: forall {r} {b}.
NoHardForks b =>
HardForkEnvelopeErr '[b]
-> (OtherHeaderEnvelopeError b -> r) -> ((# #) -> r) -> r
$bDegenOtherHeaderEnvelopeError :: forall b.
NoHardForks b =>
OtherHeaderEnvelopeError b -> HardForkEnvelopeErr '[b]
DegenOtherHeaderEnvelopeError x <- (project' (Proxy @(WrapEnvelopeErr b)) -> x)
  where
    DegenOtherHeaderEnvelopeError OtherHeaderEnvelopeError b
x = Proxy (WrapEnvelopeErr b)
-> OtherHeaderEnvelopeError b -> HardForkEnvelopeErr '[b]
forall (proxy :: * -> *) (f :: * -> *) x y blk.
(Isomorphic f, NoHardForks blk, Coercible x (f blk),
 Coercible y (f (HardForkBlock '[blk]))) =>
proxy (f blk) -> x -> y
inject' (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(WrapEnvelopeErr b)) OtherHeaderEnvelopeError b
x

pattern DegenTipInfo ::
  forall b.
  NoHardForks b =>
  TipInfo b ->
  OneEraTipInfo '[b] -- TipInfo (HardForkBlock '[b])
pattern $mDegenTipInfo :: forall {r} {b}.
NoHardForks b =>
OneEraTipInfo '[b] -> (TipInfo b -> r) -> ((# #) -> r) -> r
$bDegenTipInfo :: forall b. NoHardForks b => TipInfo b -> OneEraTipInfo '[b]
DegenTipInfo x <- (project' (Proxy @(WrapTipInfo b)) -> x)
  where
    DegenTipInfo TipInfo b
x = Proxy (WrapTipInfo b) -> TipInfo b -> OneEraTipInfo '[b]
forall (proxy :: * -> *) (f :: * -> *) x y blk.
(Isomorphic f, NoHardForks blk, Coercible x (f blk),
 Coercible y (f (HardForkBlock '[blk]))) =>
proxy (f blk) -> x -> y
inject' (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(WrapTipInfo b)) TipInfo b
x

pattern DegenQuery ::
  () =>
  HardForkQueryResult '[b] result ~ a =>
  BlockQuery b fp result ->
  BlockQuery (HardForkBlock '[b]) fp a
pattern $mDegenQuery :: forall {r} {b} {a} {fp :: QueryFootprint}.
BlockQuery (HardForkBlock '[b]) fp a
-> (forall {result}.
    (HardForkQueryResult '[b] result ~ a) =>
    BlockQuery b fp result -> r)
-> ((# #) -> r)
-> r
$bDegenQuery :: forall b a (fp :: QueryFootprint) result.
(HardForkQueryResult '[b] result ~ a) =>
BlockQuery b fp result -> BlockQuery (HardForkBlock '[b]) fp a
DegenQuery x <- (projQuery' -> ProjHardForkQuery x)
  where
    DegenQuery BlockQuery b fp result
x = BlockQuery b fp result
-> BlockQuery
     (HardForkBlock '[b]) fp (HardForkQueryResult '[b] result)
forall (fp :: QueryFootprint) b result.
BlockQuery b fp result
-> BlockQuery
     (HardForkBlock '[b]) fp (HardForkQueryResult '[b] result)
injQuery BlockQuery b fp result
x

pattern DegenQueryResult ::
  result ->
  HardForkQueryResult '[b] result
pattern $mDegenQueryResult :: forall {r} {result} {b}.
HardForkQueryResult '[b] result
-> (result -> r) -> ((# #) -> r) -> r
$bDegenQueryResult :: forall result b. result -> HardForkQueryResult '[b] result
DegenQueryResult x <- (projQueryResult -> x)
  where
    DegenQueryResult result
x = result -> HardForkQueryResult '[b] result
forall result b. result -> HardForkQueryResult '[b] result
injQueryResult result
x

pattern DegenCodecConfig ::
  NoHardForks b =>
  CodecConfig b ->
  CodecConfig (HardForkBlock '[b])
pattern $mDegenCodecConfig :: forall {r} {b}.
NoHardForks b =>
CodecConfig (HardForkBlock '[b])
-> (CodecConfig b -> r) -> ((# #) -> r) -> r
$bDegenCodecConfig :: forall b.
NoHardForks b =>
CodecConfig b -> CodecConfig (HardForkBlock '[b])
DegenCodecConfig x <- (project -> x)
  where
    DegenCodecConfig CodecConfig b
x = CodecConfig b -> CodecConfig (HardForkBlock '[b])
forall b.
NoHardForks b =>
CodecConfig b -> CodecConfig (HardForkBlock '[b])
forall (f :: * -> *) blk.
(Isomorphic f, NoHardForks blk) =>
f blk -> f (HardForkBlock '[blk])
inject CodecConfig b
x

pattern DegenBlockConfig ::
  NoHardForks b =>
  BlockConfig b ->
  BlockConfig (HardForkBlock '[b])
pattern $mDegenBlockConfig :: forall {r} {b}.
NoHardForks b =>
BlockConfig (HardForkBlock '[b])
-> (BlockConfig b -> r) -> ((# #) -> r) -> r
$bDegenBlockConfig :: forall b.
NoHardForks b =>
BlockConfig b -> BlockConfig (HardForkBlock '[b])
DegenBlockConfig x <- (project -> x)
  where
    DegenBlockConfig BlockConfig b
x = BlockConfig b -> BlockConfig (HardForkBlock '[b])
forall b.
NoHardForks b =>
BlockConfig b -> BlockConfig (HardForkBlock '[b])
forall (f :: * -> *) blk.
(Isomorphic f, NoHardForks blk) =>
f blk -> f (HardForkBlock '[blk])
inject BlockConfig b
x

pattern DegenLedgerState ::
  NoHardForks b =>
  LedgerState b mk ->
  LedgerState (HardForkBlock '[b]) mk
pattern $mDegenLedgerState :: forall {r} {b} {mk :: MapKind}.
NoHardForks b =>
LedgerState (HardForkBlock '[b]) mk
-> (LedgerState b mk -> r) -> ((# #) -> r) -> r
$bDegenLedgerState :: forall b (mk :: MapKind).
NoHardForks b =>
LedgerState b mk -> LedgerState (HardForkBlock '[b]) mk
DegenLedgerState x <- (unFlip . project . Flip -> x)
  where
    DegenLedgerState LedgerState b mk
x = Flip LedgerState mk (HardForkBlock '[b])
-> LedgerState (HardForkBlock '[b]) mk
forall x1 y1 (f :: x1 -> y1 -> *) (x2 :: y1) (y2 :: x1).
Flip f x2 y2 -> f y2 x2
unFlip (Flip LedgerState mk (HardForkBlock '[b])
 -> LedgerState (HardForkBlock '[b]) mk)
-> Flip LedgerState mk (HardForkBlock '[b])
-> LedgerState (HardForkBlock '[b]) mk
forall a b. (a -> b) -> a -> b
$ Flip LedgerState mk b -> Flip LedgerState mk (HardForkBlock '[b])
forall blk.
NoHardForks blk =>
Flip LedgerState mk blk
-> Flip LedgerState mk (HardForkBlock '[blk])
forall (f :: * -> *) blk.
(Isomorphic f, NoHardForks blk) =>
f blk -> f (HardForkBlock '[blk])
inject (Flip LedgerState mk b -> Flip LedgerState mk (HardForkBlock '[b]))
-> Flip LedgerState mk b
-> Flip LedgerState mk (HardForkBlock '[b])
forall a b. (a -> b) -> a -> b
$ LedgerState b mk -> Flip LedgerState mk b
forall x y (f :: x -> y -> *) (x1 :: y) (y1 :: x).
f y1 x1 -> Flip f x1 y1
Flip LedgerState b mk
x

{-------------------------------------------------------------------------------
  Dealing with the config

  NOTE: The pattern synonyms for 'ConsensusConfig' and 'LedgerConfig'
  give you a /partial/ config. The pattern synonym for the 'TopLevelConfig'
  /does/ give you a full config.
-------------------------------------------------------------------------------}

{-# COMPLETE DegenConsensusConfig #-}
{-# COMPLETE DegenLedgerConfig #-}
{-# COMPLETE DegenTopLevelConfig #-}

pattern DegenConsensusConfig ::
  PartialConsensusConfig (BlockProtocol b) ->
  ConsensusConfig (BlockProtocol (HardForkBlock '[b]))
pattern $mDegenConsensusConfig :: forall {r} {b}.
ConsensusConfig (BlockProtocol (HardForkBlock '[b]))
-> (PartialConsensusConfig (BlockProtocol b) -> r)
-> ((# #) -> r)
-> r
DegenConsensusConfig x <-
  HardForkConsensusConfig
    { hardForkConsensusConfigPerEra =
      PerEraConsensusConfig
        ( WrapPartialConsensusConfig x
            :* Nil
          )
    }

pattern DegenLedgerConfig ::
  PartialLedgerConfig b ->
  HardForkLedgerConfig '[b] -- LedgerConfig (HardForkBlock '[b])
pattern $mDegenLedgerConfig :: forall {r} {b}.
HardForkLedgerConfig '[b]
-> (PartialLedgerConfig b -> r) -> ((# #) -> r) -> r
DegenLedgerConfig x <-
  HardForkLedgerConfig
    { hardForkLedgerConfigPerEra =
      PerEraLedgerConfig
        ( WrapPartialLedgerConfig x
            :* Nil
          )
    }

pattern DegenTopLevelConfig ::
  NoHardForks b =>
  TopLevelConfig b ->
  TopLevelConfig (HardForkBlock '[b])
pattern $mDegenTopLevelConfig :: forall {r} {b}.
NoHardForks b =>
TopLevelConfig (HardForkBlock '[b])
-> (TopLevelConfig b -> r) -> ((# #) -> r) -> r
$bDegenTopLevelConfig :: forall b.
NoHardForks b =>
TopLevelConfig b -> TopLevelConfig (HardForkBlock '[b])
DegenTopLevelConfig x <- (project -> x)
  where
    DegenTopLevelConfig TopLevelConfig b
x = TopLevelConfig b -> TopLevelConfig (HardForkBlock '[b])
forall b.
NoHardForks b =>
TopLevelConfig b -> TopLevelConfig (HardForkBlock '[b])
forall (f :: * -> *) blk.
(Isomorphic f, NoHardForks blk) =>
f blk -> f (HardForkBlock '[blk])
inject TopLevelConfig b
x