{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Test.Util.Serialisation.Examples
  ( -- * Examples
    Examples (..)

    -- ** Operations on examples
  , combineExamples
  , mapExamples
  , prefixExamples

    -- * Labelling
  , Labelled
  , labelled
  , unlabelled
  ) where

import Data.Bifunctor (first)
import Ouroboros.Consensus.Block
  ( BlockProtocol
  , Header
  , HeaderHash
  , SlotNo
  )
import Ouroboros.Consensus.HeaderValidation (AnnTip)
import Ouroboros.Consensus.Ledger.Abstract
  ( EmptyMK
  , LedgerConfig
  , LedgerState
  )
import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState)
import Ouroboros.Consensus.Ledger.Query (BlockQuery, SomeBlockQuery)
import Ouroboros.Consensus.Ledger.SupportsMempool
  ( ApplyTxErr
  , GenTx
  , GenTxId
  )
import Ouroboros.Consensus.Protocol.Abstract (ChainDepState)
import Ouroboros.Consensus.Storage.Serialisation (SerialisedHeader)
import Ouroboros.Network.Block (Serialised)
import Test.Util.Serialisation.SomeResult (SomeResult (..))

{-------------------------------------------------------------------------------
  Examples
-------------------------------------------------------------------------------}

data Examples blk = Examples
  { forall blk. Examples blk -> Labelled blk
exampleBlock :: Labelled blk
  , forall blk. Examples blk -> Labelled (Serialised blk)
exampleSerialisedBlock :: Labelled (Serialised blk)
  , forall blk. Examples blk -> Labelled (Header blk)
exampleHeader :: Labelled (Header blk)
  , forall blk. Examples blk -> Labelled (SerialisedHeader blk)
exampleSerialisedHeader :: Labelled (SerialisedHeader blk)
  , forall blk. Examples blk -> Labelled (HeaderHash blk)
exampleHeaderHash :: Labelled (HeaderHash blk)
  , forall blk. Examples blk -> Labelled (GenTx blk)
exampleGenTx :: Labelled (GenTx blk)
  , forall blk. Examples blk -> Labelled (GenTxId blk)
exampleGenTxId :: Labelled (GenTxId blk)
  , forall blk. Examples blk -> Labelled (ApplyTxErr blk)
exampleApplyTxErr :: Labelled (ApplyTxErr blk)
  , forall blk.
Examples blk -> Labelled (SomeBlockQuery (BlockQuery blk))
exampleQuery :: Labelled (SomeBlockQuery (BlockQuery blk))
  , forall blk. Examples blk -> Labelled (SomeResult blk)
exampleResult :: Labelled (SomeResult blk)
  , forall blk. Examples blk -> Labelled (AnnTip blk)
exampleAnnTip :: Labelled (AnnTip blk)
  , forall blk. Examples blk -> Labelled (LedgerState blk EmptyMK)
exampleLedgerState :: Labelled (LedgerState blk EmptyMK)
  , forall blk.
Examples blk -> Labelled (ChainDepState (BlockProtocol blk))
exampleChainDepState :: Labelled (ChainDepState (BlockProtocol blk))
  , forall blk. Examples blk -> Labelled (ExtLedgerState blk EmptyMK)
exampleExtLedgerState :: Labelled (ExtLedgerState blk EmptyMK)
  , forall blk. Examples blk -> Labelled SlotNo
exampleSlotNo :: Labelled SlotNo
  , forall blk. Examples blk -> Labelled (LedgerConfig blk)
exampleLedgerConfig :: Labelled (LedgerConfig blk)
  }

emptyExamples :: Examples blk
emptyExamples :: forall blk. Examples blk
emptyExamples =
  Examples
    { exampleBlock :: [(Maybe String, blk)]
exampleBlock = [(Maybe String, blk)]
forall a. Monoid a => a
mempty
    , exampleSerialisedBlock :: [(Maybe String, Serialised blk)]
exampleSerialisedBlock = [(Maybe String, Serialised blk)]
forall a. Monoid a => a
mempty
    , exampleHeader :: [(Maybe String, Header blk)]
exampleHeader = [(Maybe String, Header blk)]
forall a. Monoid a => a
mempty
    , exampleSerialisedHeader :: [(Maybe String, SerialisedHeader blk)]
exampleSerialisedHeader = [(Maybe String, SerialisedHeader blk)]
forall a. Monoid a => a
mempty
    , exampleHeaderHash :: [(Maybe String, HeaderHash blk)]
exampleHeaderHash = [(Maybe String, HeaderHash blk)]
forall a. Monoid a => a
mempty
    , exampleGenTx :: [(Maybe String, GenTx blk)]
exampleGenTx = [(Maybe String, GenTx blk)]
forall a. Monoid a => a
mempty
    , exampleGenTxId :: [(Maybe String, GenTxId blk)]
exampleGenTxId = [(Maybe String, GenTxId blk)]
forall a. Monoid a => a
mempty
    , exampleApplyTxErr :: [(Maybe String, ApplyTxErr blk)]
exampleApplyTxErr = [(Maybe String, ApplyTxErr blk)]
forall a. Monoid a => a
mempty
    , exampleQuery :: [(Maybe String, SomeBlockQuery (BlockQuery blk))]
exampleQuery = [(Maybe String, SomeBlockQuery (BlockQuery blk))]
forall a. Monoid a => a
mempty
    , exampleResult :: [(Maybe String, SomeResult blk)]
exampleResult = [(Maybe String, SomeResult blk)]
forall a. Monoid a => a
mempty
    , exampleAnnTip :: [(Maybe String, AnnTip blk)]
exampleAnnTip = [(Maybe String, AnnTip blk)]
forall a. Monoid a => a
mempty
    , exampleLedgerState :: [(Maybe String, LedgerState blk EmptyMK)]
exampleLedgerState = [(Maybe String, LedgerState blk EmptyMK)]
forall a. Monoid a => a
mempty
    , exampleChainDepState :: [(Maybe String, ChainDepState (BlockProtocol blk))]
exampleChainDepState = [(Maybe String, ChainDepState (BlockProtocol blk))]
forall a. Monoid a => a
mempty
    , exampleExtLedgerState :: [(Maybe String, ExtLedgerState blk EmptyMK)]
exampleExtLedgerState = [(Maybe String, ExtLedgerState blk EmptyMK)]
forall a. Monoid a => a
mempty
    , exampleSlotNo :: Labelled SlotNo
exampleSlotNo = Labelled SlotNo
forall a. Monoid a => a
mempty
    , exampleLedgerConfig :: [(Maybe String, LedgerCfg LedgerState blk)]
exampleLedgerConfig = [(Maybe String, LedgerCfg LedgerState blk)]
forall a. Monoid a => a
mempty
    }

combineExamples ::
  forall blk.
  (forall a. Labelled a -> Labelled a -> Labelled a) ->
  Examples blk ->
  Examples blk ->
  Examples blk
combineExamples :: forall blk.
(forall a. Labelled a -> Labelled a -> Labelled a)
-> Examples blk -> Examples blk -> Examples blk
combineExamples forall a. Labelled a -> Labelled a -> Labelled a
f Examples blk
e1 Examples blk
e2 =
  Examples
    { exampleBlock :: Labelled blk
exampleBlock = (Examples blk -> Labelled blk) -> Labelled blk
forall a. (Examples blk -> Labelled a) -> Labelled a
combine Examples blk -> Labelled blk
forall blk. Examples blk -> Labelled blk
exampleBlock
    , exampleSerialisedBlock :: Labelled (Serialised blk)
exampleSerialisedBlock = (Examples blk -> Labelled (Serialised blk))
-> Labelled (Serialised blk)
forall a. (Examples blk -> Labelled a) -> Labelled a
combine Examples blk -> Labelled (Serialised blk)
forall blk. Examples blk -> Labelled (Serialised blk)
exampleSerialisedBlock
    , exampleHeader :: Labelled (Header blk)
exampleHeader = (Examples blk -> Labelled (Header blk)) -> Labelled (Header blk)
forall a. (Examples blk -> Labelled a) -> Labelled a
combine Examples blk -> Labelled (Header blk)
forall blk. Examples blk -> Labelled (Header blk)
exampleHeader
    , exampleSerialisedHeader :: Labelled (SerialisedHeader blk)
exampleSerialisedHeader = (Examples blk -> Labelled (SerialisedHeader blk))
-> Labelled (SerialisedHeader blk)
forall a. (Examples blk -> Labelled a) -> Labelled a
combine Examples blk -> Labelled (SerialisedHeader blk)
forall blk. Examples blk -> Labelled (SerialisedHeader blk)
exampleSerialisedHeader
    , exampleHeaderHash :: Labelled (HeaderHash blk)
exampleHeaderHash = (Examples blk -> Labelled (HeaderHash blk))
-> Labelled (HeaderHash blk)
forall a. (Examples blk -> Labelled a) -> Labelled a
combine Examples blk -> Labelled (HeaderHash blk)
forall blk. Examples blk -> Labelled (HeaderHash blk)
exampleHeaderHash
    , exampleGenTx :: Labelled (GenTx blk)
exampleGenTx = (Examples blk -> Labelled (GenTx blk)) -> Labelled (GenTx blk)
forall a. (Examples blk -> Labelled a) -> Labelled a
combine Examples blk -> Labelled (GenTx blk)
forall blk. Examples blk -> Labelled (GenTx blk)
exampleGenTx
    , exampleGenTxId :: Labelled (GenTxId blk)
exampleGenTxId = (Examples blk -> Labelled (GenTxId blk)) -> Labelled (GenTxId blk)
forall a. (Examples blk -> Labelled a) -> Labelled a
combine Examples blk -> Labelled (GenTxId blk)
forall blk. Examples blk -> Labelled (GenTxId blk)
exampleGenTxId
    , exampleApplyTxErr :: Labelled (ApplyTxErr blk)
exampleApplyTxErr = (Examples blk -> Labelled (ApplyTxErr blk))
-> Labelled (ApplyTxErr blk)
forall a. (Examples blk -> Labelled a) -> Labelled a
combine Examples blk -> Labelled (ApplyTxErr blk)
forall blk. Examples blk -> Labelled (ApplyTxErr blk)
exampleApplyTxErr
    , exampleQuery :: Labelled (SomeBlockQuery (BlockQuery blk))
exampleQuery = (Examples blk -> Labelled (SomeBlockQuery (BlockQuery blk)))
-> Labelled (SomeBlockQuery (BlockQuery blk))
forall a. (Examples blk -> Labelled a) -> Labelled a
combine Examples blk -> Labelled (SomeBlockQuery (BlockQuery blk))
forall blk.
Examples blk -> Labelled (SomeBlockQuery (BlockQuery blk))
exampleQuery
    , exampleResult :: Labelled (SomeResult blk)
exampleResult = (Examples blk -> Labelled (SomeResult blk))
-> Labelled (SomeResult blk)
forall a. (Examples blk -> Labelled a) -> Labelled a
combine Examples blk -> Labelled (SomeResult blk)
forall blk. Examples blk -> Labelled (SomeResult blk)
exampleResult
    , exampleAnnTip :: Labelled (AnnTip blk)
exampleAnnTip = (Examples blk -> Labelled (AnnTip blk)) -> Labelled (AnnTip blk)
forall a. (Examples blk -> Labelled a) -> Labelled a
combine Examples blk -> Labelled (AnnTip blk)
forall blk. Examples blk -> Labelled (AnnTip blk)
exampleAnnTip
    , exampleLedgerState :: Labelled (LedgerState blk EmptyMK)
exampleLedgerState = (Examples blk -> Labelled (LedgerState blk EmptyMK))
-> Labelled (LedgerState blk EmptyMK)
forall a. (Examples blk -> Labelled a) -> Labelled a
combine Examples blk -> Labelled (LedgerState blk EmptyMK)
forall blk. Examples blk -> Labelled (LedgerState blk EmptyMK)
exampleLedgerState
    , exampleChainDepState :: Labelled (ChainDepState (BlockProtocol blk))
exampleChainDepState = (Examples blk -> Labelled (ChainDepState (BlockProtocol blk)))
-> Labelled (ChainDepState (BlockProtocol blk))
forall a. (Examples blk -> Labelled a) -> Labelled a
combine Examples blk -> Labelled (ChainDepState (BlockProtocol blk))
forall blk.
Examples blk -> Labelled (ChainDepState (BlockProtocol blk))
exampleChainDepState
    , exampleExtLedgerState :: Labelled (ExtLedgerState blk EmptyMK)
exampleExtLedgerState = (Examples blk -> Labelled (ExtLedgerState blk EmptyMK))
-> Labelled (ExtLedgerState blk EmptyMK)
forall a. (Examples blk -> Labelled a) -> Labelled a
combine Examples blk -> Labelled (ExtLedgerState blk EmptyMK)
forall blk. Examples blk -> Labelled (ExtLedgerState blk EmptyMK)
exampleExtLedgerState
    , exampleSlotNo :: Labelled SlotNo
exampleSlotNo = (Examples blk -> Labelled SlotNo) -> Labelled SlotNo
forall a. (Examples blk -> Labelled a) -> Labelled a
combine Examples blk -> Labelled SlotNo
forall blk. Examples blk -> Labelled SlotNo
exampleSlotNo
    , exampleLedgerConfig :: Labelled (LedgerConfig blk)
exampleLedgerConfig = (Examples blk -> Labelled (LedgerConfig blk))
-> Labelled (LedgerConfig blk)
forall a. (Examples blk -> Labelled a) -> Labelled a
combine Examples blk -> Labelled (LedgerConfig blk)
forall blk. Examples blk -> Labelled (LedgerConfig blk)
exampleLedgerConfig
    }
 where
  combine :: (Examples blk -> Labelled a) -> Labelled a
  combine :: forall a. (Examples blk -> Labelled a) -> Labelled a
combine Examples blk -> Labelled a
getField = Labelled a -> Labelled a -> Labelled a
forall a. Labelled a -> Labelled a -> Labelled a
f (Examples blk -> Labelled a
getField Examples blk
e1) (Examples blk -> Labelled a
getField Examples blk
e2)

instance Semigroup (Examples blk) where
  <> :: Examples blk -> Examples blk -> Examples blk
(<>) = (forall a. Labelled a -> Labelled a -> Labelled a)
-> Examples blk -> Examples blk -> Examples blk
forall blk.
(forall a. Labelled a -> Labelled a -> Labelled a)
-> Examples blk -> Examples blk -> Examples blk
combineExamples [(Maybe String, a)] -> [(Maybe String, a)] -> [(Maybe String, a)]
forall a. Semigroup a => a -> a -> a
forall a. Labelled a -> Labelled a -> Labelled a
(<>)

instance Monoid (Examples blk) where
  mempty :: Examples blk
mempty = Examples blk
forall blk. Examples blk
emptyExamples
  mappend :: Examples blk -> Examples blk -> Examples blk
mappend = Examples blk -> Examples blk -> Examples blk
forall a. Semigroup a => a -> a -> a
(<>)

mapExamples ::
  forall blk.
  (forall a. Labelled a -> Labelled a) ->
  Examples blk ->
  Examples blk
mapExamples :: forall blk.
(forall a. Labelled a -> Labelled a)
-> Examples blk -> Examples blk
mapExamples forall a. Labelled a -> Labelled a
f = (forall a. Labelled a -> Labelled a -> Labelled a)
-> Examples blk -> Examples blk -> Examples blk
forall blk.
(forall a. Labelled a -> Labelled a -> Labelled a)
-> Examples blk -> Examples blk -> Examples blk
combineExamples (([(Maybe String, a)] -> [(Maybe String, a)])
-> [(Maybe String, a)]
-> [(Maybe String, a)]
-> [(Maybe String, a)]
forall a b. a -> b -> a
const [(Maybe String, a)] -> [(Maybe String, a)]
forall a. Labelled a -> Labelled a
f) Examples blk
forall a. Monoid a => a
mempty

-- | Add the given prefix to each labelled example.
--
-- When a label is empty, the prefix is used as the label. If the label is not
-- empty, the prefix and @_@ are prepended.
prefixExamples :: String -> Examples blk -> Examples blk
prefixExamples :: forall blk. String -> Examples blk -> Examples blk
prefixExamples String
prefix = (forall a. Labelled a -> Labelled a)
-> Examples blk -> Examples blk
forall blk.
(forall a. Labelled a -> Labelled a)
-> Examples blk -> Examples blk
mapExamples Labelled a -> Labelled a
forall a. Labelled a -> Labelled a
addPrefix
 where
  addPrefix :: Labelled a -> Labelled a
  addPrefix :: forall a. Labelled a -> Labelled a
addPrefix Labelled a
l =
    [ (String -> Maybe String
forall a. a -> Maybe a
Just String
label, a
x)
    | (Maybe String
mbLabel, a
x) <- Labelled a
l
    , let label :: String
label = case Maybe String
mbLabel of
            Maybe String
Nothing -> String
prefix
            Just String
lbl -> String
prefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
lbl
    ]

{-------------------------------------------------------------------------------
  Labelling
-------------------------------------------------------------------------------}

type Labelled a = [(Maybe String, a)]

unlabelled :: a -> Labelled a
unlabelled :: forall a. a -> Labelled a
unlabelled a
x = [(Maybe String
forall a. Maybe a
Nothing, a
x)]

labelled :: [(String, a)] -> Labelled a
labelled :: forall a. [(String, a)] -> Labelled a
labelled = ((String, a) -> (Maybe String, a))
-> [(String, a)] -> [(Maybe String, a)]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> Maybe String) -> (String, a) -> (Maybe String, a)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> Maybe String
forall a. a -> Maybe a
Just)