{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
#if __GLASGOW_HASKELL__ <= 906
{-# LANGUAGE TypeFamilies #-}
#endif
{-# 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 ()
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)
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)
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)
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) [] ]