{-# 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.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.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
             -> 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)
  -> Gen [GenTx (HardForkBlock xs)]
testGenTxsHfc :: forall (xs :: [*]).
(All TxGen xs, CanHardFork xs) =>
CoreNodeId
-> NumCoreNodes
-> SlotNo
-> TopLevelConfig (HardForkBlock xs)
-> NP WrapTxGenExtra xs
-> LedgerState (HardForkBlock xs)
-> Gen [GenTx (HardForkBlock xs)]
testGenTxsHfc CoreNodeId
coreNodeId NumCoreNodes
numCoreNodes SlotNo
curSlotNo TopLevelConfig (HardForkBlock xs)
cfg NP WrapTxGenExtra xs
extras LedgerState (HardForkBlock xs)
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
    -> LedgerState a
    -> K (Gen [GenTx (HardForkBlock xs)]) a)
-> NP TopLevelConfig xs
-> NP WrapTxGenExtra xs
-> NS LedgerState 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
-> LedgerState a
-> K (Gen [GenTx (HardForkBlock xs)]) a
forall a.
TxGen a =>
Index xs a
-> TopLevelConfig a
-> WrapTxGenExtra a
-> LedgerState a
-> K (Gen [GenTx (HardForkBlock xs)]) a
aux
      NP TopLevelConfig xs
cfgs
      NP WrapTxGenExtra xs
extras
      (HardForkState LedgerState xs -> NS LedgerState xs
forall (xs :: [*]) (f :: * -> *).
SListI xs =>
HardForkState f xs -> NS f xs
State.tip (LedgerState (HardForkBlock xs) -> HardForkState LedgerState xs
forall (xs :: [*]).
LedgerState (HardForkBlock xs) -> HardForkState LedgerState xs
hardForkLedgerStatePerEra LedgerState (HardForkBlock xs)
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 LedgerState xs
-> EpochInfo (Except PastHorizonException)
forall (xs :: [*]).
All SingleEraBlock xs =>
HardForkLedgerConfig xs
-> HardForkState LedgerState 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) -> HardForkState LedgerState xs
forall (xs :: [*]).
LedgerState (HardForkBlock xs) -> HardForkState LedgerState xs
hardForkLedgerStatePerEra LedgerState (HardForkBlock xs)
state)

    aux ::
         forall blk. TxGen blk
      => Index xs blk
      -> TopLevelConfig blk
      -> WrapTxGenExtra blk
      -> LedgerState blk
      -> K (Gen [GenTx (HardForkBlock xs)]) blk
    aux :: forall a.
TxGen a =>
Index xs a
-> TopLevelConfig a
-> WrapTxGenExtra a
-> LedgerState a
-> K (Gen [GenTx (HardForkBlock xs)]) a
aux Index xs blk
index TopLevelConfig blk
cfg' (WrapTxGenExtra TxGenExtra blk
extra') LedgerState blk
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]).
(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
-> Gen [GenTx blk]
forall blk.
TxGen blk =>
CoreNodeId
-> NumCoreNodes
-> SlotNo
-> TopLevelConfig blk
-> TxGenExtra blk
-> LedgerState blk
-> Gen [GenTx blk]
testGenTxs CoreNodeId
coreNodeId NumCoreNodes
numCoreNodes SlotNo
curSlotNo TopLevelConfig blk
cfg' TxGenExtra blk
extra' LedgerState blk
state'