{-# 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, SomeSecond)
import           Ouroboros.Consensus.HeaderValidation (AnnTip)
import           Ouroboros.Consensus.Ledger.Abstract (LedgerState)
import           Ouroboros.Consensus.Ledger.Extended (ExtLedgerState)
import           Ouroboros.Consensus.Ledger.Query (BlockQuery)
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 (SomeSecond BlockQuery blk)
exampleQuery            :: Labelled (SomeSecond 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)
exampleLedgerState      :: Labelled (LedgerState blk)
    , forall blk.
Examples blk -> Labelled (ChainDepState (BlockProtocol blk))
exampleChainDepState    :: Labelled (ChainDepState (BlockProtocol blk))
    , forall blk. Examples blk -> Labelled (ExtLedgerState blk)
exampleExtLedgerState   :: Labelled (ExtLedgerState blk)
    , forall blk. Examples blk -> Labelled SlotNo
exampleSlotNo           :: Labelled SlotNo
    }

emptyExamples :: Examples blk
emptyExamples :: forall blk. Examples blk
emptyExamples = Examples {
      exampleBlock :: Labelled blk
exampleBlock            = Labelled blk
forall a. Monoid a => a
mempty
    , exampleSerialisedBlock :: Labelled (Serialised blk)
exampleSerialisedBlock  = Labelled (Serialised blk)
forall a. Monoid a => a
mempty
    , exampleHeader :: Labelled (Header blk)
exampleHeader           = Labelled (Header blk)
forall a. Monoid a => a
mempty
    , exampleSerialisedHeader :: Labelled (SerialisedHeader blk)
exampleSerialisedHeader = Labelled (SerialisedHeader blk)
forall a. Monoid a => a
mempty
    , exampleHeaderHash :: Labelled (HeaderHash blk)
exampleHeaderHash       = Labelled (HeaderHash blk)
forall a. Monoid a => a
mempty
    , exampleGenTx :: Labelled (GenTx blk)
exampleGenTx            = Labelled (GenTx blk)
forall a. Monoid a => a
mempty
    , exampleGenTxId :: Labelled (GenTxId blk)
exampleGenTxId          = Labelled (GenTxId blk)
forall a. Monoid a => a
mempty
    , exampleApplyTxErr :: Labelled (ApplyTxErr blk)
exampleApplyTxErr       = Labelled (ApplyTxErr blk)
forall a. Monoid a => a
mempty
    , exampleQuery :: Labelled (SomeSecond BlockQuery blk)
exampleQuery            = Labelled (SomeSecond BlockQuery blk)
forall a. Monoid a => a
mempty
    , exampleResult :: Labelled (SomeResult blk)
exampleResult           = Labelled (SomeResult blk)
forall a. Monoid a => a
mempty
    , exampleAnnTip :: Labelled (AnnTip blk)
exampleAnnTip           = Labelled (AnnTip blk)
forall a. Monoid a => a
mempty
    , exampleLedgerState :: Labelled (LedgerState blk)
exampleLedgerState      = Labelled (LedgerState blk)
forall a. Monoid a => a
mempty
    , exampleChainDepState :: Labelled (ChainDepState (BlockProtocol blk))
exampleChainDepState    = Labelled (ChainDepState (BlockProtocol blk))
forall a. Monoid a => a
mempty
    , exampleExtLedgerState :: Labelled (ExtLedgerState blk)
exampleExtLedgerState   = Labelled (ExtLedgerState blk)
forall a. Monoid a => a
mempty
    , exampleSlotNo :: Labelled SlotNo
exampleSlotNo           = Labelled SlotNo
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 (SomeSecond BlockQuery blk)
exampleQuery            = (Examples blk -> Labelled (SomeSecond BlockQuery blk))
-> Labelled (SomeSecond BlockQuery blk)
forall a. (Examples blk -> Labelled a) -> Labelled a
combine Examples blk -> Labelled (SomeSecond BlockQuery blk)
forall blk. Examples blk -> Labelled (SomeSecond 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)
exampleLedgerState      = (Examples blk -> Labelled (LedgerState blk))
-> Labelled (LedgerState blk)
forall a. (Examples blk -> Labelled a) -> Labelled a
combine Examples blk -> Labelled (LedgerState blk)
forall blk. Examples blk -> Labelled (LedgerState blk)
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)
exampleExtLedgerState   = (Examples blk -> Labelled (ExtLedgerState blk))
-> Labelled (ExtLedgerState blk)
forall a. (Examples blk -> Labelled a) -> Labelled a
combine Examples blk -> Labelled (ExtLedgerState blk)
forall blk. Examples blk -> Labelled (ExtLedgerState blk)
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
    }
  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 Labelled a -> Labelled a -> Labelled 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 ((Labelled a -> Labelled a)
-> Labelled a -> Labelled a -> Labelled a
forall a b. a -> b -> a
const Labelled a -> Labelled 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)