Write arbitrary instance for data that uses sized

plutus-pab/plutus-pab.cabal

@@ -432,6 +432,7 @@ test-suite plutus-pab-test-light
         Cardano.Wallet.RemoteClientSpec
         Cardano.Wallet.ServerSpec
         Control.Concurrent.STM.ExtrasSpec
+        Plutus.PAB.ArbitrarySpec
 
     build-depends:
         QuickCheck -any,
@@ -455,11 +456,13 @@ test-suite plutus-pab-test-light
         plutus-pab,
         plutus-ledger -any,
         plutus-ledger-constraints -any,
+        plutus-tx -any,
         quickcheck-instances -any,
         servant-client -any,
         tasty -any,
         tasty-hunit -any,
         smallcheck -any,
+        hedgehog-quickcheck -any,
         tasty-hedgehog -any,
         tasty-smallcheck -any,
         tasty-quickcheck -any,

plutus-pab/src/Plutus/PAB/Arbitrary.hs

@@ -8,6 +8,7 @@
 -- across to the test suite.
 module Plutus.PAB.Arbitrary where
 
+import Control.Monad (replicateM)
 import Data.Aeson (Value)
 import Data.Aeson qualified as Aeson
 import Data.ByteString (ByteString)
@@ -29,7 +30,7 @@ import Plutus.Contract.StateMachine (ThreadToken)
 import PlutusTx qualified
 import PlutusTx.AssocMap qualified as AssocMap
 import PlutusTx.Prelude qualified as PlutusTx
-import Test.QuickCheck (Gen, oneof)
+import Test.QuickCheck (Gen, Positive (..), oneof, sized)
 import Test.QuickCheck.Arbitrary.Generic (Arbitrary, arbitrary, genericArbitrary, genericShrink, shrink)
 import Test.QuickCheck.Instances ()
 import Wallet (WalletAPIError)
@@ -156,7 +157,49 @@ instance Arbitrary ThreadToken where
     shrink = genericShrink
 
 instance Arbitrary PlutusTx.Data where
-    arbitrary = genericArbitrary
+    arbitrary = sized arbitraryData
+      where
+        arbitraryData :: Int -> Gen PlutusTx.Data
+        arbitraryData n =
+            oneof [ arbitraryConstr n
+                  , arbitraryMap n
+                  , arbitraryList n
+                  , arbitraryI
+                  , arbitraryB
+                  ]
+
+        arbitraryConstr n = do
+          (n', m) <- segmentRange (n - 1)
+          (Positive ix) <- arbitrary
+          args <- replicateM m (arbitraryData n')
+          pure $ PlutusTx.Constr ix args
+
+        arbitraryMap n = do
+           -- NOTE: A pair always has at least 2 constructors/nodes so we divide by 2
+          (n', m) <- segmentRange ((n - 1) `div` 2)
+          PlutusTx.Map <$> replicateM m (arbitraryPair $ n')
+
+        arbitraryPair n = do
+          (,) <$> arbitraryData half <*> arbitraryData half
+          where
+            half = n `div` 2
+
+        arbitraryList n = do
+          (n', m) <- segmentRange (n - 1)
+          PlutusTx.List <$> replicateM m (arbitraryData n')
+
+        arbitraryI =
+          PlutusTx.I <$> arbitrary
+
+        arbitraryB =
+          PlutusTx.B <$> arbitrary
+
+        -- Used to break the sized generator up more or less evenly
+        segmentRange n = do
+          (Positive m) <- arbitrary
+          let n' = n `div` (m + 1) -- Prevent division by 0
+          pure (n', if n' > 0 then m else 0) -- Prevent segments of 0
+
     shrink = genericShrink
 
 instance Arbitrary PlutusTx.BuiltinData where

plutus-pab/test/light/Plutus/PAB/ArbitrarySpec.hs

@@ -0,0 +1,32 @@
+{-# LANGUAGE LambdaCase #-}
+
+module Plutus.PAB.ArbitrarySpec where
+
+import Hedgehog (MonadGen, Property, forAll, property)
+import Hedgehog qualified
+import Hedgehog.Gen qualified as Gen
+import Hedgehog.Gen.QuickCheck qualified as Gen
+import Hedgehog.Range qualified as Range
+import Plutus.PAB.Arbitrary ()
+import PlutusTx (Data (..))
+import PlutusTx qualified
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.Hedgehog (testProperty)
+
+tests :: TestTree
+tests = testGroup "Plutus.PAB.ArbitrarySpec"
+  [ testProperty "arbitrary data is bounded by size parameter" dataBoundedBySizeProp ]
+
+dataBoundedBySizeProp :: Property
+dataBoundedBySizeProp = property $ do
+  maxNodes <- forAll $ Gen.integral_ $ Range.linear 0 10000
+  d <- forAll $ Gen.resize (fromInteger maxNodes) Gen.arbitrary
+  Hedgehog.assert $ countDataNodes d <= maxNodes + 1
+
+countDataNodes :: Data -> Integer
+countDataNodes = \case
+  Constr _ ds -> 1 + foldr ((+) . countDataNodes) 0 ds
+  Map pairs   -> 1 + foldr ((+) . (\(a, b) -> countDataNodes a + countDataNodes b)) 0 pairs
+  List ds     -> 1 + foldr ((+) . countDataNodes) 0 ds
+  I _         -> 1
+  B _         -> 1

plutus-pab/test/light/Spec.hs

@@ -6,6 +6,7 @@ import Cardano.Api.NetworkId.ExtraSpec qualified
 import Cardano.Wallet.RemoteClientSpec qualified
 import Cardano.Wallet.ServerSpec qualified
 import Control.Concurrent.STM.ExtrasSpec qualified
+import Plutus.PAB.ArbitrarySpec qualified
 import Test.Tasty (defaultMain, testGroup)
 
 main :: IO ()
@@ -17,4 +18,5 @@ main =
         , Cardano.Wallet.RemoteClientSpec.tests
         , Cardano.Wallet.ServerSpec.tests
         , Control.Concurrent.STM.ExtrasSpec.tests
+        , Plutus.PAB.ArbitrarySpec.tests
         ]