{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Util.Orphans.ToExpr () where

import qualified Control.Monad.Class.MonadTime.SI as SI
import Data.Maybe.Strict (StrictMaybe)
import Data.Set.NonEmpty (NESet)
import Data.TreeDiff
import GHC.Generics (Generic)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.BlockchainTime.WallClock.Types (RelativeTime, WithArrivalTime)
import Ouroboros.Consensus.Committee.Class (VotingCommittee)
import Ouroboros.Consensus.Committee.WFA (SeatIndex)
import Ouroboros.Consensus.HeaderValidation
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.Extended
import Ouroboros.Consensus.Ledger.Peras (PerasState)
import Ouroboros.Consensus.Ledger.SupportsMempool
import Ouroboros.Consensus.Mempool.API
import Ouroboros.Consensus.Mempool.TxSeq
import Ouroboros.Consensus.Peras.Cert.Mock (MockPerasCert)
import Ouroboros.Consensus.Peras.Context
  ( PerasEpochContextNotFoundForRound
  , PerasEpochContextResolver
  )
import Ouroboros.Consensus.Peras.Crypto.Mock (MockPerasVotingCommitteeScheme)
import Ouroboros.Consensus.Peras.Error.Mock (MockPerasError)
import Ouroboros.Consensus.Peras.Vote.Mock (MockPerasVote)
import Ouroboros.Consensus.Peras.Voting.Adapter (PerasConversionError)
import Ouroboros.Consensus.Protocol.Abstract
import Ouroboros.Consensus.Storage.ChainDB.API (LoE (..))
import Ouroboros.Consensus.Storage.ImmutableDB
import Ouroboros.Consensus.Storage.LedgerDB.Snapshots
import Ouroboros.Consensus.Util.STM (Fingerprint, WithFingerprint)
import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
import qualified Ouroboros.Network.AnchoredFragment as Fragment
import Ouroboros.Network.Block (MaxSlotNo)
import Ouroboros.Network.Mock.Chain
import Ouroboros.Network.Mock.ProducerState
import Ouroboros.Network.Point
import System.FS.API
import System.FS.CRC (CRC (..))
import Test.Cardano.Slotting.TreeDiff ()
import Test.Util.ToExpr ()

{-------------------------------------------------------------------------------
  ouroboros-network
-------------------------------------------------------------------------------}

instance ToExpr (HeaderHash blk) => ToExpr (Point blk)
instance ToExpr (HeaderHash blk) => ToExpr (RealPoint blk)
instance (ToExpr slot, ToExpr hash) => ToExpr (Block slot hash)

deriving instance
  ( ToExpr blk
  , ToExpr (HeaderHash blk)
  ) =>
  ToExpr (Fragment.Anchor blk)

instance (ToExpr blk, ToExpr (HeaderHash blk)) => ToExpr (AnchoredFragment blk) where
  toExpr :: AnchoredFragment blk -> Expr
toExpr AnchoredFragment blk
f = (Anchor blk, [blk]) -> Expr
forall a. ToExpr a => a -> Expr
toExpr (AnchoredFragment blk -> Anchor blk
forall v a b. AnchoredSeq v a b -> a
Fragment.anchor AnchoredFragment blk
f, AnchoredFragment blk -> [blk]
forall v a b. AnchoredSeq v a b -> [b]
Fragment.toOldestFirst AnchoredFragment blk
f)

{-------------------------------------------------------------------------------
  ouroboros-consensus
-------------------------------------------------------------------------------}

instance
  ( ToExpr (LedgerState blk EmptyMK)
  , ToExpr (ChainDepState (BlockProtocol blk))
  , ToExpr (TipInfo blk)
  , Show (PerasVotingCommittee blk)
  ) =>
  ToExpr (ExtLedgerState blk EmptyMK)

instance
  Show (PerasVotingCommittee blk) =>
  ToExpr (PerasState blk)

instance
  ( ToExpr (ChainDepState (BlockProtocol blk))
  , ToExpr (TipInfo blk)
  ) =>
  ToExpr (HeaderState blk)

instance ToExpr SecurityParam where
  toExpr :: SecurityParam -> Expr
toExpr = SecurityParam -> Expr
forall a. Show a => a -> Expr
defaultExprViaShow

instance ToExpr CRC
instance ToExpr DiskSnapshot

instance ToExpr ChunkSize
instance ToExpr ChunkNo
instance ToExpr ChunkSlot
instance ToExpr RelativeSlot
instance
  ( ToExpr a
  , ToExpr b
  , ToExpr c
  , ToExpr d
  , ToExpr e
  , ToExpr f
  , ToExpr g
  , ToExpr h
  , ToExpr i
  , ToExpr j
  ) =>
  ToExpr (a, b, c, d, e, f, g, h, i, j)
  where
  toExpr :: (a, b, c, d, e, f, g, h, i, j) -> Expr
toExpr (a
a, b
b, c
c, d
d, e
e, f
f, g
g, h
h, i
i, j
j) =
    String -> [Expr] -> Expr
App
      String
"_×_×_×_×_×_×_×_×_x_"
      [ a -> Expr
forall a. ToExpr a => a -> Expr
toExpr a
a
      , b -> Expr
forall a. ToExpr a => a -> Expr
toExpr b
b
      , c -> Expr
forall a. ToExpr a => a -> Expr
toExpr c
c
      , d -> Expr
forall a. ToExpr a => a -> Expr
toExpr d
d
      , e -> Expr
forall a. ToExpr a => a -> Expr
toExpr e
e
      , f -> Expr
forall a. ToExpr a => a -> Expr
toExpr f
f
      , g -> Expr
forall a. ToExpr a => a -> Expr
toExpr g
g
      , h -> Expr
forall a. ToExpr a => a -> Expr
toExpr h
h
      , i -> Expr
forall a. ToExpr a => a -> Expr
toExpr i
i
      , j -> Expr
forall a. ToExpr a => a -> Expr
toExpr j
j
      ]

instance ToExpr RelativeTime where
  toExpr :: RelativeTime -> Expr
toExpr = RelativeTime -> Expr
forall a. Show a => a -> Expr
defaultExprViaShow
instance ToExpr ChunkInfo where
  toExpr :: ChunkInfo -> Expr
toExpr = ChunkInfo -> Expr
forall a. Show a => a -> Expr
defaultExprViaShow
instance ToExpr FsError where
  toExpr :: FsError -> Expr
toExpr FsError
fsError = String -> [Expr] -> Expr
App (FsError -> String
forall a. Show a => a -> String
show FsError
fsError) []

deriving instance ToExpr a => ToExpr (LoE a)

deriving anyclass instance ToExpr PerasRoundNo

deriving instance ToExpr a => ToExpr (StrictMaybe a)

deriving anyclass instance ToExpr PerasWeight

deriving anyclass instance ToExpr VoteWeight

deriving anyclass instance ToExpr PerasVoteId

deriving anyclass instance ToExpr a => ToExpr (WithArrivalTime a)

deriving anyclass instance ToExpr a => ToExpr (NESet a)

instance ToExpr (HeaderHash blk) => ToExpr (MockPerasVote blk)
instance ToExpr (HeaderHash blk) => ToExpr (MockPerasCert blk)

instance ToExpr (PerasVotingCommitteeError blk) => ToExpr (MockPerasError blk)

instance
  Show (PerasVotingCommittee blk) =>
  ToExpr (VotingCommittee crypto (MockPerasVotingCommitteeScheme blk))
  where
  toExpr :: VotingCommittee crypto (MockPerasVotingCommitteeScheme blk) -> Expr
toExpr = VotingCommittee crypto (MockPerasVotingCommitteeScheme blk) -> Expr
forall a. Show a => a -> Expr
defaultExprViaShow

instance
  Show (PerasVotingCommittee blk) =>
  ToExpr (PerasEpochContextResolver blk)
  where
  toExpr :: PerasEpochContextResolver blk -> Expr
toExpr = PerasEpochContextResolver blk -> Expr
forall a. Show a => a -> Expr
defaultExprViaShow

deriving anyclass instance ToExpr PerasEpochContextNotFoundForRound

deriving anyclass instance ToExpr SeatIndex
deriving anyclass instance ToExpr PerasSeatIndex

deriving anyclass instance ToExpr PerasConversionError

{-------------------------------------------------------------------------------
  si-timers
--------------------------------------------------------------------------------}

instance ToExpr SI.Time where toExpr :: Time -> Expr
toExpr = Time -> Expr
forall a. Show a => a -> Expr
defaultExprViaShow

deriving anyclass instance ToExpr Fingerprint
deriving anyclass instance ToExpr FollowerNext
deriving anyclass instance ToExpr MaxSlotNo

deriving instance ToExpr (HeaderHash blk) => ToExpr (ChainHash blk)
deriving instance ToExpr (HeaderHash blk) => ToExpr (FollowerState blk)

deriving instance Generic FollowerNext
deriving instance Generic (Chain blk)
deriving instance Generic (ChainProducerState blk)
deriving instance Generic (FollowerState blk)

deriving instance ToExpr blk => ToExpr (Chain blk)
deriving instance
  ( ToExpr blk
  , ToExpr (HeaderHash blk)
  ) =>
  ToExpr (ChainProducerState blk)
deriving instance ToExpr a => ToExpr (WithFingerprint a)

instance ToExpr (TipInfo blk) => ToExpr (AnnTip blk)

{-------------------------------------------------------------------------------
  Mempool and transactions
-------------------------------------------------------------------------------}

deriving newtype instance ToExpr TicketNo

instance Show (TxId (GenTx blk)) => ToExpr (TxId (GenTx blk)) where
  toExpr :: TxId (GenTx blk) -> Expr
toExpr TxId (GenTx blk)
x = String -> [Expr] -> Expr
App (TxId (GenTx blk) -> String
forall a. Show a => a -> String
show TxId (GenTx blk)
x) []

deriving instance
  ( ToExpr (GenTx blk)
  , LedgerSupportsMempool blk
  , measure ~ TxMeasure blk
  , ToExpr measure
  , ToExpr (Validated (GenTx blk))
  ) =>
  ToExpr (TxTicket measure (Validated (GenTx blk)))

instance
  ( ToExpr (GenTx blk)
  , LedgerSupportsMempool blk
  , ToExpr (Validated (GenTx blk))
  ) =>
  ToExpr (MempoolAddTxResult blk)
  where
  toExpr :: MempoolAddTxResult blk -> Expr
toExpr (MempoolTxAdded Validated (GenTx blk)
vtx LedgerTables blk DiffMK
_) = String -> [Expr] -> Expr
App String
"Added" [Validated (GenTx blk) -> Expr
forall a. ToExpr a => a -> Expr
toExpr Validated (GenTx blk)
vtx]
  toExpr (MempoolTxRejected GenTx blk
tx ApplyTxErr blk
e) = String -> [Expr] -> Expr
App String
"Rejected" [GenTx blk -> Expr
forall a. ToExpr a => a -> Expr
toExpr GenTx blk
tx, String -> [Expr] -> Expr
App (ApplyTxErr blk -> String
forall a. Show a => a -> String
show ApplyTxErr blk
e) []]