Rebase

Author: Soupstraw

cabal.project

@@ -21,8 +21,8 @@ source-repository-package
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cuddle.git
-  tag: 65c64867e4d4cdace105cbd1a5097701db2c5bac
-  --sha256: sha256-TS1qbTwLrJ+OQq/f+FqnmindvANnQf8mZbAqFDk5Kuo=
+  tag: c2003efc96a803db5ba4835ad0c9df6d40c5e1d5
+  --sha256: sha256-RA94WedcLI00yJAgD2HhNzPFDyRcbXNOQ7S+/9ZhH50=
 
 source-repository-package
   type: git
@@ -107,5 +107,5 @@ source-repository-package
   type: git
   location: https://github.com/Soupstraw/cardano-cls.git
   subdir: merkle-tree-incremental mempack-scls scls-cbor scls-cardano scls-format scls-core
-  --sha256: sha256-POBr11BhEN6SFfc70ZD5saGBanyH/F2Is1TK7+xbk4s=
-  tag: c8414c077b8efd1a8818b147cc33b42504779e4e
+  --sha256: sha256-mK6D4+ZSI2SdclEzhbuWKKCvDseJS1A83rx4OZJlNgI=
+  tag: 37e6e707d6d46a691cbcebe925d0aaf51f0efd8c

libs/cardano-ledger-binary/cardano-ledger-binary.cabal

@@ -109,9 +109,9 @@ library testlib
     -Wunused-packages
 
   build-depends:
-    antigen >=0.3.1.0 && < 0.4,
     ImpSpec,
     QuickCheck,
+    antigen >=0.3.1.0 && <0.4,
     base,
     base16-bytestring,
     bytestring,

libs/cardano-ledger-binary/testlib/Test/Cardano/Ledger/Binary/Cuddle.hs

@@ -85,11 +85,15 @@ import Test.Hspec (
   it,
   shouldBe,
  )
-import Test.Hspec.Core.Spec (Example (..), paramsQuickCheckArgs)
-import Test.QuickCheck (Arbitrary (..), Args (replay), Gen, Testable (..), forAll)
-import Test.QuickCheck.Gen (Gen (..))
-import Test.QuickCheck.Random (QCGen, mkQCGen)
-import Text.Pretty.Simple (pShow)
+import Test.QuickCheck (
+  Arbitrary (..),
+  Gen,
+  Testable (..),
+  counterexample,
+  discard,
+  forAll,
+ )
+import Test.QuickCheck.Property (Property)
 
 huddleDecoderEquivalenceSpec ::
   forall a.
@@ -263,21 +267,14 @@ showValidationTrace (Evidenced _ t) =
   T.unpack . Ansi.renderStrict . layoutPretty defaultLayoutOptions $
     prettyValidationTrace defaultTraceOptions t
 
-huddleRoundTripArbitraryValidate ::
+huddleRoundTripGenValidate ::
   forall a.
-  ( DecCBOR a
-  , EncCBOR a
-  , Arbitrary a
-  , Show a
-  ) =>
-  Version ->
-  T.Text ->
-  SpecWith (CTreeRoot MonoReferenced)
-huddleRoundTripArbitraryValidate version ruleName =
+  (DecCBOR a, Show a, EncCBOR a) => Gen a -> Version -> T.Text -> SpecWith (CTreeRoot MonoReferenced)
+huddleRoundTripGenValidate gen version ruleName =
   let lbl = label $ Proxy @a
    in describe "Encode an arbitrary value and check against CDDL"
         . it (T.unpack ruleName <> ": " <> T.unpack lbl)
-        $ \cddl -> property $
+        $ \cddl -> property . forAll gen $
           \(val :: a) -> do
             let
               bs = serialize' version val
@@ -297,7 +294,7 @@ huddleRoundTripArbitraryValidate ::
   ) =>
   Version ->
   T.Text ->
-  SpecWith CuddleData
+  SpecWith (CTreeRoot MonoReferenced)
 huddleRoundTripArbitraryValidate = huddleRoundTripGenValidate $ arbitrary @a
 
 --------------------------------------------------------------------------------

libs/cardano-ledger-core/cardano-ledger-core.cabal

@@ -183,6 +183,7 @@ library cddl
     -Wunused-packages
 
   build-depends:
+    QuickCheck,
     base,
     bytestring,
     cardano-ledger-binary,

libs/cardano-ledger-core/cddl/Cardano/Ledger/Core/HuddleSpec.hs

@@ -23,18 +23,14 @@ import Codec.CBOR.Cuddle.CDDL (Name (..))
 import Codec.CBOR.Cuddle.CDDL.CBORGenerator (WrappedTerm (..))
 import Codec.CBOR.Cuddle.Huddle
 import Codec.CBOR.Term (Term (..))
-import Control.Monad (join)
 import Data.Bits (Bits (..))
+import Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
 import Data.MemPack (VarLen (..), packByteString)
 import Data.Proxy (Proxy (..))
 import qualified Data.Text as T
 import Data.Word (Word16, Word32, Word64)
-import System.Random.Stateful (
-  Uniform (..),
-  UniformRange (..),
-  uniformByteStringM,
- )
+import Test.QuickCheck (Arbitrary (..), Gen, choose, oneof, vector)
 import Text.Heredoc
 import Prelude hiding ((/))
 
@@ -75,22 +71,20 @@ instance Era era => HuddleRule "unit_interval" era where
       . withGenerator generator
       $ pname =.= tag 30 (arr [a VUInt, a VUInt])
     where
-      generator g = do
+      generator = do
         let genUnitInterval64 l u = do
-              d <- uniformRM (max 1 l, u) g
-              n <- uniformRM (l, d) g
+              d <- choose (max 1 l, u)
+              n <- choose (l, d)
               pure (n, d)
             max64 = toInteger (maxBound @Word64)
         (n, d) <-
-          join $
-            pickOne
-              [ genUnitInterval64 0 max64
-              , genUnitInterval64 0 1000
-              , genUnitInterval64 (max64 - 1000) max64
-              ]
-              g
+          oneof
+            [ genUnitInterval64 0 max64
+            , genUnitInterval64 0 1000
+            , genUnitInterval64 (max64 - 1000) max64
+            ]
         S . TTagged 30
-          <$> genArrayTerm [TInteger $ toInteger n, TInteger $ toInteger d] g
+          <$> genArrayTerm [TInteger $ toInteger n, TInteger $ toInteger d]
 
 instance Era era => HuddleRule "nonnegative_interval" era where
   huddleRuleNamed pname p =
@@ -175,6 +169,11 @@ instance Era era => HuddleRule "coin" era where
 instance Era era => HuddleRule "positive_coin" era where
   huddleRuleNamed pname p = pname =.= (1 :: Integer) ... huddleRule @"max_word64" p
 
+genHash28 :: Gen ByteString
+genHash28 =
+  -- TODO better implementation
+  BS.pack <$> vector 28
+
 instance Era era => HuddleRule "address" era where
   huddleRuleNamed pname _ =
     comment
@@ -212,18 +211,17 @@ instance Era era => HuddleRule "address" era where
       . withGenerator generator
       $ pname =.= VBytes
     where
-      generator g = do
-        stakeRef <- uniformRM (0, 0b11) g
+      generator = do
+        stakeRef <- choose (0, 0b11)
         let
           stakeRefMask = stakeRef `shiftL` 5 -- 0b0xx00000
           mkMask mask isMask = if isMask then mask else 0
-        isPaymentScriptMask <- mkMask 0b00010000 <$> uniformM g
-        isMainnetMask <- mkMask 0b00000001 <$> uniformM g
+        isPaymentScriptMask <- mkMask 0b00010000 <$> arbitrary
+        isMainnetMask <- mkMask 0b00000001 <$> arbitrary
         let
           header = stakeRefMask .|. isPaymentScriptMask .|. isMainnetMask
-          genHash28 = uniformByteStringM 28 g
-          genVar32 = VarLen <$> uniformM @Word32 g
-          genVar16 = VarLen <$> uniformM @Word16 g
+          genVar32 = VarLen <$> arbitrary @Word32
+          genVar16 = VarLen <$> arbitrary @Word16
         stakeCred <- case stakeRef of
           0b00 -> genHash28 -- staking payment hash
           0b01 -> genHash28 -- staking script hash
@@ -242,14 +240,14 @@ instance Era era => HuddleRule "address" era where
 instance Era era => HuddleRule "reward_account" era where
   huddleRuleNamed pname _ = withGenerator generator $ pname =.= VBytes
     where
-      generator g = do
-        isMainnet <- uniformM g
-        isScript <- uniformM g
+      generator = do
+        isMainnet <- arbitrary
+        isScript <- arbitrary
         let
           mainnetMask | isMainnet = 0b00000001 | otherwise = 0x00
           scriptMask | isScript = 0b00010000 | otherwise = 0x00
           header = 0b11100000 .|. mainnetMask .|. scriptMask
-        payload <- uniformByteStringM 28 g
+        payload <- genHash28
         let term = TBytes $ BS.cons header payload
         pure $ S term
 

libs/cardano-ledger-core/cddl/Cardano/Ledger/Huddle.hs

@@ -42,6 +42,7 @@ import qualified Data.Text as T
 import qualified Data.Text.Lazy as LT
 import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
 import System.Random.Stateful (StatefulGen, UniformRange (..))
+import Test.QuickCheck (Gen, elements)
 
 class (KnownSymbol name, Era era) => HuddleRule (name :: Symbol) era where
   huddleRuleNamed :: Proxy name -> Proxy era -> Rule
@@ -77,8 +78,8 @@ infixr 0 =.=
 
 infixr 0 =.~
 
-genArrayTerm :: StatefulGen g m => [Term] -> g -> m Term
-genArrayTerm es = pickOne [TList es, TListI es]
+genArrayTerm :: [Term] -> Gen Term
+genArrayTerm es = elements [TList es, TListI es]
 
 pickOne :: StatefulGen g m => NonEmpty a -> g -> m a
 pickOne es g = do