{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# 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.TreeDiff
import           GHC.Generics (Generic)
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.HeaderValidation
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.Extended
import           Ouroboros.Consensus.Ledger.SupportsMempool
import           Ouroboros.Consensus.Mempool.API
import           Ouroboros.Consensus.Mempool.TxSeq
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)
         ) => ToExpr (ExtLedgerState blk EmptyMK)

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 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)


{-------------------------------------------------------------------------------
  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)     = 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) [] ]