Allow user to pass custom packet generator to genPackets

clash-protocols/clash-protocols.cabal

@@ -147,6 +147,7 @@ library
     Protocols.Axi4.WriteData
     Protocols.Axi4.WriteResponse
     Protocols.PacketStream
+    Protocols.PacketStream.Lol
     Protocols.PacketStream.Base
     Protocols.PacketStream.AsyncFifo
     Protocols.PacketStream.Converters

clash-protocols/src/Protocols/PacketStream/Hedgehog.hs

@@ -29,7 +29,7 @@ module Protocols.PacketStream.Hedgehog (
   -- * Hedgehog generators
   AbortMode (..),
   genValidPacket,
-  genValidPackets,
+  genPackets,
 ) where
 
 import Prelude
@@ -159,7 +159,7 @@ downConvert ::
 downConvert = concatMap chopPacket
 
 {- |
-Merges a list of `PacketStream` transfers with data width @dataWidth into
+Merges a list of `PacketStream` transfers with data width @dataWidth@ into
 a list of `PacketStream` transfers with data width @1@
 -}
 upConvert ::
@@ -309,93 +309,96 @@ Otherwise, transfers of roughly 50% of the packets will randomly have _abort set
 data AbortMode = Abort | NoAbort
 
 {- |
-Generate valid packets, i.e. packets of which all transfers carry the same
-`_meta` and with all unenabled bytes in `_data` set to 0x00.
+Generate packets with a user-supplied generator.
 -}
-genValidPackets ::
-  forall (dataWidth :: C.Nat) (metaType :: C.Type).
+genPackets ::
+  forall (dataWidth :: C.Nat) (meta :: C.Type).
   (1 C.<= dataWidth) =>
   (C.KnownNat dataWidth) =>
-  (C.BitPack metaType) =>
   -- | The amount of packets to generate.
   Range Int ->
-  -- | The amount of transfers with @_last = Nothing@ to generate per packet.
-  --   This function will always generate an extra transfer per packet
-  --   with @_last = Just i@.
-  Range Int ->
-  -- | If set to @NoAbort@, no generated packets will have `_abort` set in
-  --   any of their transfers. Else, roughly 50% of packets will contain
-  --   fragments with their `_abort` randomly set.
+  -- | If set to @NoAbort@, always pass @NoAbort@ to the packet generator.
+  --   Else, pass @Abort@ to roughly 50% of the packet generators.
   AbortMode ->
-  Gen [PacketStreamM2S dataWidth metaType]
-genValidPackets pkts size Abort = concat <$> Gen.list pkts gen
- where
-  gen = do
-    abortPacket <- Gen.bool
-    genValidPacket size (if abortPacket then Abort else NoAbort)
-genValidPackets pkts size NoAbort =
-  concat <$> Gen.list pkts (genValidPacket size NoAbort)
+  -- | Packet generator.
+  (AbortMode -> Gen [PacketStreamM2S dataWidth meta]) ->
+  Gen [PacketStreamM2S dataWidth meta]
+genPackets pkts Abort pktGen =
+  concat
+    <$> Gen.list
+      pkts
+      (Gen.choice [pktGen Abort, pktGen NoAbort])
+genPackets pkts NoAbort pktGen =
+  concat
+    <$> Gen.list
+      pkts
+      (pktGen NoAbort)
 
 {- |
 Generate a valid packet, i.e. a packet of which all transfers carry the same
 `_meta` and with all unenabled bytes in `_data` set to 0x00.
 -}
 genValidPacket ::
-  forall (dataWidth :: C.Nat) (metaType :: C.Type).
+  forall (dataWidth :: C.Nat) (meta :: C.Type).
   (1 C.<= dataWidth) =>
   (C.KnownNat dataWidth) =>
-  (C.BitPack metaType) =>
+  -- | Generator for the metadata.
+  Gen meta ->
   -- | The amount of transfers with @_last = Nothing@ to generate.
   --   This function will always generate an extra transfer with @_last = Just i@.
   Range Int ->
   -- | If set to @NoAbort@, no transfers in the packet will have @_abort@ set.
-  --   Else, they will randomly have @_abort@ set.
+  --   Else, each transfer has a 10% chance to have @_abort@ set.
   AbortMode ->
-  Gen [PacketStreamM2S dataWidth metaType]
-genValidPacket size abortMode = do
-  meta <- C.unpack <$> Gen.enumBounded
+  Gen [PacketStreamM2S dataWidth meta]
+genValidPacket metaGen size abortMode = do
+  meta <- metaGen
   transfers <- Gen.list size (genTransfer @dataWidth meta abortMode)
   lastTransfer <- genLastTransfer @dataWidth meta abortMode
   pure (transfers ++ [lastTransfer])
 
 -- | Generate a single transfer which is not yet the end of a packet.
 genTransfer ::
-  forall (dataWidth :: C.Nat) (metaType :: C.Type).
+  forall (dataWidth :: C.Nat) (meta :: C.Type).
   (1 C.<= dataWidth) =>
   (C.KnownNat dataWidth) =>
   -- | We need to use the same metadata
   --   for every transfer in a packet to satisfy the protocol
   --   invariant that metadata is constant for an entire packet.
-  metaType ->
+  meta ->
   -- | If set to @NoAbort@, hardcode @_abort@ to @False@. Else,
-  --   randomly generate it.
+  --   there is a 10% chance for it to be set.
   AbortMode ->
-  Gen (PacketStreamM2S dataWidth metaType)
+  Gen (PacketStreamM2S dataWidth meta)
 genTransfer meta abortMode =
   PacketStreamM2S
     <$> genVec Gen.enumBounded
     <*> Gen.constant Nothing
     <*> Gen.constant meta
     <*> case abortMode of
-      Abort -> Gen.enumBounded
+      Abort ->
+        Gen.frequency
+          [ (90, Gen.constant False)
+          , (10, Gen.constant True)
+          ]
       NoAbort -> Gen.constant False
 
 {- |
 Generate the last transfer of a packet, i.e. a transfer with @_last@ set as @Just@.
 All bytes which are not enabled are set to 0x00.
 -}
 genLastTransfer ::
-  forall (dataWidth :: C.Nat) (metaType :: C.Type).
+  forall (dataWidth :: C.Nat) (meta :: C.Type).
   (1 C.<= dataWidth) =>
   (C.KnownNat dataWidth) =>
   -- | We need to use the same metadata
   --   for every transfer in a packet to satisfy the protocol
   --   invariant that metadata is constant for an entire packet.
-  metaType ->
+  meta ->
   -- | If set to @NoAbort@, hardcode @_abort@ to @False@. Else,
   --   randomly generate it.
   AbortMode ->
-  Gen (PacketStreamM2S dataWidth metaType)
+  Gen (PacketStreamM2S dataWidth meta)
 genLastTransfer meta abortMode =
   setNull
     <$> ( PacketStreamM2S

clash-protocols/src/Protocols/PacketStream/Lol.hs

@@ -0,0 +1,3 @@
+{-# LANGUAGE NumericUnderscores #-}
+
+module Protocols.PacketStream.Lol where

clash-protocols/tests/Tests/Protocols/PacketStream/AsyncFifo.hs

@@ -6,6 +6,7 @@ module Tests.Protocols.PacketStream.AsyncFifo where
 import Clash.Prelude
 
 import Hedgehog (Property)
+import qualified Hedgehog.Gen as Gen
 import qualified Hedgehog.Range as Range
 
 import Test.Tasty (TestTree, localOption, mkTimeout)
@@ -70,7 +71,8 @@ generateAsyncFifoIdProp ::
 generateAsyncFifoIdProp wClk wRst wEn rClk rRst rEn =
   idWithModel
     defExpectOptions
-    (genValidPackets (Range.linear 1 10) (Range.linear 1 30) Abort)
+    ( genPackets (Range.linear 1 10) Abort (genValidPacket Gen.enumBounded (Range.linear 1 30))
+    )
     id
     (asyncFifoC @wDom @rDom @4 @1 @Int d4 wClk wRst wEn rClk rRst rEn)
 

clash-protocols/tests/Tests/Protocols/PacketStream/Converters.hs

@@ -5,6 +5,7 @@ module Tests.Protocols.PacketStream.Converters where
 import Clash.Prelude
 
 import Hedgehog (Property)
+import qualified Hedgehog.Gen as Gen
 import qualified Hedgehog.Range as Range
 
 import Test.Tasty
@@ -29,7 +30,8 @@ generateUpConverterProperty ::
 generateUpConverterProperty SNat SNat =
   idWithModelSingleDomain
     defExpectOptions
-    (genValidPackets (Range.linear 1 10) (Range.linear 1 20) Abort)
+    ( genPackets (Range.linear 1 10) Abort (genValidPacket Gen.enumBounded (Range.linear 1 20))
+    )
     (exposeClockResetEnable (upConvert . downConvert))
     (exposeClockResetEnable @System (upConverterC @dwIn @dwOut @Int))
 
@@ -64,7 +66,7 @@ generateDownConverterProperty ::
 generateDownConverterProperty SNat SNat =
   idWithModelSingleDomain
     defExpectOptions{eoSampleMax = 1000}
-    (genValidPackets (Range.linear 1 8) (Range.linear 1 10) Abort)
+    (genPackets (Range.linear 1 8) Abort (genValidPacket Gen.enumBounded (Range.linear 1 10)))
     (exposeClockResetEnable (upConvert . downConvert))
     (exposeClockResetEnable @System (downConverterC @dwIn @dwOut @Int))
 

clash-protocols/tests/Tests/Protocols/PacketStream/Delay.hs

@@ -8,6 +8,7 @@ module Tests.Protocols.PacketStream.Delay (
 import Clash.Prelude
 
 import Hedgehog
+import qualified Hedgehog.Gen as Gen
 import qualified Hedgehog.Range as Range
 
 import Test.Tasty
@@ -25,14 +26,14 @@ prop_delaystream_id =
   idWithModelSingleDomain
     @System
     defExpectOptions
-    (genValidPackets (Range.linear 1 10) (Range.linear 1 6) Abort)
+    (genPackets (Range.linear 1 10) Abort (genValidPacket Gen.enumBounded (Range.linear 1 6)))
     (exposeClockResetEnable id)
     (exposeClockResetEnable ckt)
  where
   ckt ::
     (HiddenClockResetEnable System) =>
-    Circuit (PacketStream System 2 ()) (PacketStream System 2 ())
-  ckt = delayStream @System @2 @() @4 d4
+    Circuit (PacketStream System 2 Int) (PacketStream System 2 Int)
+  ckt = delayStream @System @2 @Int @4 d4
 
 tests :: TestTree
 tests =

clash-protocols/tests/Tests/Protocols/PacketStream/Depacketizers.hs

@@ -38,7 +38,7 @@ depacketizerPropertyGenerator SNat SNat =
   idWithModelSingleDomain
     @System
     defExpectOptions{eoSampleMax = 1000, eoStopAfterEmpty = 1000}
-    (genValidPackets (Range.linear 1 4) (Range.linear 1 30) Abort)
+    (genPackets (Range.linear 1 4) Abort (genValidPacket (pure ()) (Range.linear 1 30)))
     (exposeClockResetEnable model)
     (exposeClockResetEnable ckt)
  where
@@ -82,7 +82,7 @@ depacketizeToDfPropertyGenerator SNat SNat =
   idWithModelSingleDomain
     @System
     defExpectOptions{eoSampleMax = 1000, eoStopAfterEmpty = 1000}
-    (genValidPackets (Range.linear 1 4) (Range.linear 1 30) NoAbort)
+    (genPackets (Range.linear 1 10) Abort (genValidPacket (pure ()) (Range.linear 1 20)))
     (exposeClockResetEnable model)
     (exposeClockResetEnable ckt)
  where

clash-protocols/tests/Tests/Protocols/PacketStream/PacketFifo.hs

@@ -10,7 +10,8 @@ import Clash.Prelude
 import Data.Int (Int16)
 import qualified Data.List as L
 
-import Hedgehog as H
+import Hedgehog
+import qualified Hedgehog.Gen as Gen
 import qualified Hedgehog.Range as Range
 
 import Test.Tasty
@@ -30,7 +31,8 @@ prop_packetFifo_id =
   idWithModelSingleDomain
     @System
     defExpectOptions{eoSampleMax = 1000, eoStopAfterEmpty = 1000}
-    (genValidPackets (Range.linear 1 30) (Range.linear 1 10) Abort)
+    ( genPackets (Range.linear 1 30) Abort (genValidPacket Gen.enumBounded (Range.linear 1 10))
+    )
     (exposeClockResetEnable dropAbortedPackets)
     (exposeClockResetEnable ckt)
  where
@@ -45,7 +47,8 @@ prop_packetFifo_small_buffer_id =
   idWithModelSingleDomain
     @System
     defExpectOptions{eoSampleMax = 1000, eoStopAfterEmpty = 1000}
-    (genValidPackets (Range.linear 1 10) (Range.linear 1 30) NoAbort)
+    ( genPackets (Range.linear 1 10) Abort (genValidPacket Gen.enumBounded (Range.linear 1 30))
+    )
     (exposeClockResetEnable dropAbortedPackets)
     (exposeClockResetEnable ckt)
  where
@@ -65,9 +68,13 @@ prop_packetFifo_no_gaps = property $ do
           systemClockGen
           resetGen
           enableGen
-      gen = genValidPackets (Range.linear 1 10) (Range.linear 1 10) NoAbort
+      gen =
+        genPackets
+          (Range.linear 1 10)
+          NoAbort
+          (genValidPacket Gen.enumBounded (Range.linear 1 10))
 
-  packets :: [PacketStreamM2S 4 Int16] <- H.forAll gen
+  packets :: [PacketStreamM2S 4 Int16] <- forAll gen
 
   let packetSize = 2 Prelude.^ snatToInteger packetFifoSize
       cfg = SimulationConfig 1 (2 * packetSize) False
@@ -86,7 +93,8 @@ prop_overFlowDrop_packetFifo_id =
   idWithModelSingleDomain
     @System
     defExpectOptions{eoSampleMax = 2000, eoStopAfterEmpty = 1000}
-    (genValidPackets (Range.linear 1 30) (Range.linear 1 10) Abort)
+    ( genPackets (Range.linear 1 30) Abort (genValidPacket Gen.enumBounded (Range.linear 1 10))
+    )
     (exposeClockResetEnable dropAbortedPackets)
     (exposeClockResetEnable ckt)
  where
@@ -116,16 +124,16 @@ prop_overFlowDrop_packetFifo_drop =
    where
     packetChunk = chunkByPacket packets
 
-  genSmall = genValidPacket (Range.linear 1 5) NoAbort
-  genBig = genValidPacket (Range.linear 33 33) NoAbort
+  genSmall = genValidPacket Gen.enumBounded (Range.linear 1 5) NoAbort
+  genBig = genValidPacket Gen.enumBounded (Range.linear 33 33) NoAbort
 
 -- | test for id using a small metabuffer to ensure backpressure using the metabuffer is tested
 prop_packetFifo_small_metaBuffer :: Property
 prop_packetFifo_small_metaBuffer =
   idWithModelSingleDomain
     @System
     defExpectOptions
-    (genValidPackets (Range.linear 1 30) (Range.linear 1 4) Abort)
+    (genPackets (Range.linear 1 30) Abort (genValidPacket Gen.enumBounded (Range.linear 1 4)))
     (exposeClockResetEnable dropAbortedPackets)
     (exposeClockResetEnable ckt)
  where

clash-protocols/tests/Tests/Protocols/PacketStream/Packetizers.hs

@@ -40,7 +40,11 @@ packetizerPropertyGenerator SNat SNat =
   idWithModelSingleDomain
     @System
     defExpectOptions
-    (genValidPackets (Range.linear 1 10) (Range.linear 1 10) Abort)
+    ( genPackets
+        (Range.linear 1 10)
+        Abort
+        (genValidPacket (genVec Gen.enumBounded) (Range.linear 1 10))
+    )
     (exposeClockResetEnable model)
     (exposeClockResetEnable ckt)
  where

clash-protocols/tests/Tests/Protocols/PacketStream/Routing.hs

@@ -8,6 +8,7 @@ import Clash.Prelude
 import qualified Clash.Prelude as C
 
 import Hedgehog hiding (Parallel)
+import qualified Hedgehog.Gen as Gen
 import qualified Hedgehog.Range as Range
 
 import Test.Tasty
@@ -64,7 +65,8 @@ makePropPacketArbiter _ _ mode =
  where
   genSources = mapM setMeta (indicesI @p)
   setMeta j = do
-    pkts <- genValidPackets @n @() (Range.linear 1 10) (Range.linear 1 10) Abort
+    pkts <-
+      genPackets @n (Range.linear 1 10) Abort (genValidPacket (pure ()) (Range.linear 1 10))
     pure $ L.map (\pkt -> pkt{_meta = j}) pkts
 
   partitionPackets packets =
@@ -106,6 +108,7 @@ makePropPacketDispatcher ::
   , 1 <= dataWidth
   , TestType a
   , Bounded a
+  , Enum a
   , BitPack a
   ) =>
   SNat dataWidth ->
@@ -114,7 +117,7 @@ makePropPacketDispatcher ::
 makePropPacketDispatcher _ fs =
   idWithModelSingleDomain @System
     defExpectOptions{eoSampleMax = 2000, eoStopAfterEmpty = 1000}
-    (genValidPackets (Range.linear 1 10) (Range.linear 1 6) Abort)
+    (genPackets (Range.linear 1 10) Abort (genValidPacket Gen.enumBounded (Range.linear 1 6)))
     (exposeClockResetEnable (model 0))
     (exposeClockResetEnable (packetDispatcherC fs))
  where