{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Transaction generator for testing
module Test.ThreadNet.TxGen (
    TxGen (..)
    -- * Implementation for HFC
  , WrapTxGenExtra (..)
  , testGenTxsHfc
  ) where

import           Data.Kind (Type)
import           Data.SOP.BasicFunctors
import           Data.SOP.Constraint
import           Data.SOP.Functors (Flip (..))
import           Data.SOP.Index
import           Data.SOP.Strict
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.HardFork.Combinator
import qualified Ouroboros.Consensus.HardFork.Combinator.State as State
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Node.ProtocolInfo (NumCoreNodes (..))
import           Ouroboros.Consensus.NodeId (CoreNodeId)
import           Test.QuickCheck (Gen)

{-------------------------------------------------------------------------------
  TxGen class
-------------------------------------------------------------------------------}

class TxGen blk where

  -- | Extra information required to generate transactions
  type TxGenExtra blk :: Type
  type TxGenExtra blk = ()

  -- | Generate a number of transactions, valid or invalid, that can be
  -- submitted to a node's Mempool.
  --
  -- This function will be called to generate transactions in consensus tests.
  --
  -- Note: this function returns a list so that an empty list can be returned
  -- in case we are unable to generate transactions for a @blk@.
  testGenTxs :: CoreNodeId
             -> NumCoreNodes
             -> SlotNo
             -> TopLevelConfig blk
             -> TxGenExtra blk
             -> LedgerState blk ValuesMK
             -> Gen [GenTx blk]

{-------------------------------------------------------------------------------
  Implementation for HFC
-------------------------------------------------------------------------------}

-- | Newtypes wrapper around the 'TxGenExtra' type family so that it can be
-- partially applied.
newtype WrapTxGenExtra blk = WrapTxGenExtra {
      forall blk. WrapTxGenExtra blk -> TxGenExtra blk
unwrapTxGenExtra :: TxGenExtra blk
    }

-- | Function that can be used for 'TxGen' instances for 'HardForkBlock'.
--
-- We don't provide a generic instance of 'TxGen' because it might be desirable
-- to provide custom implementations for specific instantiations of the eras of
-- 'HardForkBlock'. Instead, we provide this function that can be used when a
-- generic implemenation is desired.
--
-- Choose @NP WrapTxGenExtra xs@ for the instance of the 'TxGenExtra' type
-- family, where @xs@ matches the concrete instantiation.
testGenTxsHfc ::
     forall xs. (All TxGen xs, CanHardFork xs)
  => CoreNodeId
  -> NumCoreNodes
  -> SlotNo
  -> TopLevelConfig (HardForkBlock xs)
  -> NP WrapTxGenExtra xs
  -> LedgerState (HardForkBlock xs) ValuesMK
  -> Gen [GenTx (HardForkBlock xs)]
testGenTxsHfc :: forall (xs :: [*]).
(All TxGen xs, CanHardFork xs) =>
CoreNodeId
-> NumCoreNodes
-> SlotNo
-> TopLevelConfig (HardForkBlock xs)
-> NP WrapTxGenExtra xs
-> LedgerState (HardForkBlock xs) ValuesMK
-> Gen [GenTx (HardForkBlock xs)]
testGenTxsHfc CoreNodeId
coreNodeId NumCoreNodes
numCoreNodes SlotNo
curSlotNo TopLevelConfig (HardForkBlock xs)
cfg NP WrapTxGenExtra xs
extras LedgerState (HardForkBlock xs) ValuesMK
state =
    NS (K (Gen [GenTx (HardForkBlock xs)])) xs
-> CollapseTo NS (Gen [GenTx (HardForkBlock xs)])
forall (xs :: [*]) a.
SListIN NS xs =>
NS (K a) xs -> CollapseTo NS a
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (NS (K (Gen [GenTx (HardForkBlock xs)])) xs
 -> CollapseTo NS (Gen [GenTx (HardForkBlock xs)]))
-> NS (K (Gen [GenTx (HardForkBlock xs)])) xs
-> CollapseTo NS (Gen [GenTx (HardForkBlock xs)])
forall a b. (a -> b) -> a -> b
$
    Proxy TxGen
-> (forall a.
    TxGen a =>
    Index xs a
    -> TopLevelConfig a
    -> WrapTxGenExtra a
    -> Flip LedgerState ValuesMK a
    -> K (Gen [GenTx (HardForkBlock xs)]) a)
-> NP TopLevelConfig xs
-> NP WrapTxGenExtra xs
-> NS (Flip LedgerState ValuesMK) xs
-> NS (K (Gen [GenTx (HardForkBlock xs)])) xs
forall {k} (h :: (k -> *) -> [k] -> *) (c :: k -> Constraint)
       (xs :: [k]) (proxy :: (k -> Constraint) -> *) (f1 :: k -> *)
       (f2 :: k -> *) (f3 :: k -> *) (f4 :: k -> *).
(HAp h, All c xs, Prod h ~ NP) =>
proxy c
-> (forall (a :: k).
    c a =>
    Index xs a -> f1 a -> f2 a -> f3 a -> f4 a)
-> NP f1 xs
-> NP f2 xs
-> h f3 xs
-> h f4 xs
hcizipWith3
      (forall {k} (t :: k). Proxy t
forall (t :: * -> Constraint). Proxy t
Proxy @TxGen)
      Index xs a
-> TopLevelConfig a
-> WrapTxGenExtra a
-> Flip LedgerState ValuesMK a
-> K (Gen [GenTx (HardForkBlock xs)]) a
forall a.
TxGen a =>
Index xs a
-> TopLevelConfig a
-> WrapTxGenExtra a
-> Flip LedgerState ValuesMK a
-> K (Gen [GenTx (HardForkBlock xs)]) a
aux
      NP TopLevelConfig xs
cfgs
      NP WrapTxGenExtra xs
extras
      (HardForkState (Flip LedgerState ValuesMK) xs
-> NS (Flip LedgerState ValuesMK) xs
forall (xs :: [*]) (f :: * -> *).
SListI xs =>
HardForkState f xs -> NS f xs
State.tip (LedgerState (HardForkBlock xs) ValuesMK
-> HardForkState (Flip LedgerState ValuesMK) xs
forall (xs :: [*]) (mk :: MapKind).
LedgerState (HardForkBlock xs) mk
-> HardForkState (Flip LedgerState mk) xs
hardForkLedgerStatePerEra LedgerState (HardForkBlock xs) ValuesMK
state))
  where
    cfgs :: NP TopLevelConfig xs
cfgs = EpochInfo (Except PastHorizonException)
-> TopLevelConfig (HardForkBlock xs) -> NP TopLevelConfig xs
forall (xs :: [*]).
All SingleEraBlock xs =>
EpochInfo (Except PastHorizonException)
-> TopLevelConfig (HardForkBlock xs) -> NP TopLevelConfig xs
distribTopLevelConfig EpochInfo (Except PastHorizonException)
ei TopLevelConfig (HardForkBlock xs)
cfg
    ei :: EpochInfo (Except PastHorizonException)
ei   = HardForkLedgerConfig xs
-> HardForkState (Flip LedgerState ValuesMK) xs
-> EpochInfo (Except PastHorizonException)
forall (xs :: [*]) (mk :: MapKind).
All SingleEraBlock xs =>
HardForkLedgerConfig xs
-> HardForkState (Flip LedgerState mk) xs
-> EpochInfo (Except PastHorizonException)
State.epochInfoLedger
             (TopLevelConfig (HardForkBlock xs)
-> LedgerConfig (HardForkBlock xs)
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig (HardForkBlock xs)
cfg)
             (LedgerState (HardForkBlock xs) ValuesMK
-> HardForkState (Flip LedgerState ValuesMK) xs
forall (xs :: [*]) (mk :: MapKind).
LedgerState (HardForkBlock xs) mk
-> HardForkState (Flip LedgerState mk) xs
hardForkLedgerStatePerEra LedgerState (HardForkBlock xs) ValuesMK
state)

    aux ::
         forall blk. TxGen blk
      => Index xs blk
      -> TopLevelConfig blk
      -> WrapTxGenExtra blk
      -> Flip LedgerState ValuesMK blk
      -> K (Gen [GenTx (HardForkBlock xs)]) blk
    aux :: forall a.
TxGen a =>
Index xs a
-> TopLevelConfig a
-> WrapTxGenExtra a
-> Flip LedgerState ValuesMK a
-> K (Gen [GenTx (HardForkBlock xs)]) a
aux Index xs blk
index TopLevelConfig blk
cfg' (WrapTxGenExtra TxGenExtra blk
extra') (Flip LedgerState blk ValuesMK
state') = Gen [GenTx (HardForkBlock xs)]
-> K (Gen [GenTx (HardForkBlock xs)]) blk
forall k a (b :: k). a -> K a b
K (Gen [GenTx (HardForkBlock xs)]
 -> K (Gen [GenTx (HardForkBlock xs)]) blk)
-> Gen [GenTx (HardForkBlock xs)]
-> K (Gen [GenTx (HardForkBlock xs)]) blk
forall a b. (a -> b) -> a -> b
$
        (GenTx blk -> GenTx (HardForkBlock xs))
-> [GenTx blk] -> [GenTx (HardForkBlock xs)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Proxy GenTx
-> Index xs blk -> GenTx blk -> GenTx (HardForkBlock xs)
forall {k} (f :: k -> *) a b (x :: k) (xs :: [k]).
(All Top xs, Coercible a (f x), Coercible b (NS f xs)) =>
Proxy f -> Index xs x -> a -> b
injectNS' (forall {k} (t :: k). Proxy t
forall (t :: * -> *). Proxy t
Proxy @GenTx) Index xs blk
index)
          ([GenTx blk] -> [GenTx (HardForkBlock xs)])
-> Gen [GenTx blk] -> Gen [GenTx (HardForkBlock xs)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreNodeId
-> NumCoreNodes
-> SlotNo
-> TopLevelConfig blk
-> TxGenExtra blk
-> LedgerState blk ValuesMK
-> Gen [GenTx blk]
forall blk.
TxGen blk =>
CoreNodeId
-> NumCoreNodes
-> SlotNo
-> TopLevelConfig blk
-> TxGenExtra blk
-> LedgerState blk ValuesMK
-> Gen [GenTx blk]
testGenTxs CoreNodeId
coreNodeId NumCoreNodes
numCoreNodes SlotNo
curSlotNo TopLevelConfig blk
cfg' TxGenExtra blk
extra' LedgerState blk ValuesMK
state'