Rebase

Author: Soupstraw

cabal.project

@@ -18,12 +18,6 @@ source-repository-package
   -- MAKE SURE THIS POINTS TO A COMMIT IN `*-artifacts` BEFORE MERGE!
   tag: 5ed76f93a6c71ef7450d540d5a3ca836b67e5253
 
-source-repository-package
-  type: git
-  location: https://github.com/input-output-hk/cuddle.git
-  tag: 65c64867e4d4cdace105cbd1a5097701db2c5bac
-  --sha256: sha256-TS1qbTwLrJ+OQq/f+FqnmindvANnQf8mZbAqFDk5Kuo=
-
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/constrained-generators.git
@@ -108,10 +102,10 @@ if impl(ghc >=9.12)
 
 source-repository-package
   type: git
-  location: https://github.com/Soupstraw/cardano-cls.git
+  location: https://github.com/tweag/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-HqkjvqBwo8zZpKHZY7R21OVhP7VQtfoBwK0vawZtNfg=
+  tag: 98b29d8a866d4dd6658682e285a3d49c17039d0d
 
 if impl(ghc >=9.14)
   source-repository-package

eras/dijkstra/impl/test/Test/Cardano/Ledger/Dijkstra/Binary/CddlSpec.hs

@@ -13,6 +13,7 @@ import Cardano.Ledger.Conway.Governance (GovAction, ProposalProcedure, VotingPro
 import Cardano.Ledger.Core
 import Cardano.Ledger.Dijkstra (DijkstraEra)
 import Cardano.Ledger.Dijkstra.HuddleSpec (dijkstraCDDL)
+import Cardano.Ledger.Dijkstra.Scripts (AccountBalanceInterval, AccountBalanceIntervals)
 import Cardano.Ledger.Plutus.Data (Data, Datum)
 import Test.Cardano.Ledger.Binary.Cuddle (
   huddleDecoderEquivalenceSpec,
@@ -30,6 +31,9 @@ spec = do
   describe "CDDL" $ do
     let v = eraProtVerHigh @DijkstraEra
     describe "Huddle" $ specWithHuddle dijkstraCDDL $ do
+      huddleRoundTripCborSpec @(AccountBalanceInterval DijkstraEra) v "account_balance_interval"
+      huddleRoundTripCborSpec @(AccountBalanceIntervals DijkstraEra) v "account_balance_intervals"
+      huddleRoundTripArbitraryValidate @(AccountBalanceInterval DijkstraEra) v "account_balance_interval"
       huddleRoundTripCborSpec @(Value DijkstraEra) v "positive_coin"
       huddleRoundTripArbitraryValidate @(Value DijkstraEra) v "value"
       describe "MultiAsset" $ do

flake.lock

@@ -113,9 +113,9 @@ library testlib
     ghc-options:
       -Wredundant-constraints
   build-depends:
-    antigen >=0.3.1.0 && < 0.4,
     ImpSpec,
     QuickCheck,
+    antigen >=0.3.1.0 && <0.4,
     base,
     base16-bytestring,
     bytestring,
@@ -128,7 +128,7 @@ library testlib
     cardano-strict-containers,
     cborg,
     containers,
-    cuddle >=1.1 && <1.1.2,
+    cuddle >=1.2,
     directory,
     filepath,
     formatting,

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

@@ -56,6 +56,7 @@ import qualified Codec.CBOR.Pretty as CBOR
 import qualified Codec.CBOR.Term as CBOR
 import qualified Codec.CBOR.Write as C
 import qualified Codec.CBOR.Write as CBOR
+import Control.Monad (unless)
 import Data.Data (Proxy (..))
 import Data.Either (isLeft)
 import qualified Data.Text as T
@@ -85,11 +86,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,30 +268,20 @@ 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
               res = validateCBOR bs (Name ruleName) (mapIndex cddl)
-            if isValid res
-              then pure ()
-              else
-                expectationFailure $
-                  "CBOR Validation failed\nError:\n" <> showValidationTrace res
+            unless (isValid res) . expectationFailure $
+              "CBOR Validation failed\nError:\n" <> showValidationTrace res
 
 huddleRoundTripArbitraryValidate ::
   forall a.
@@ -297,7 +292,7 @@ huddleRoundTripArbitraryValidate ::
   ) =>
   Version ->
   T.Text ->
-  SpecWith CuddleData
+  SpecWith (CTreeRoot MonoReferenced)
 huddleRoundTripArbitraryValidate = huddleRoundTripGenValidate $ arbitrary @a
 
 --------------------------------------------------------------------------------

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

@@ -193,12 +193,13 @@ library cddl
     -Wunused-packages
 
   build-depends:
+    QuickCheck,
     base,
     bytestring,
     cardano-ledger-binary,
     cardano-ledger-core,
     cborg,
-    cuddle >=1.1,
+    cuddle >=1.2,
     heredoc,
     mempack,
     random,

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

@@ -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 ((/))
 
@@ -72,25 +68,23 @@ instance Era era => HuddleRule "unit_interval" era where
           |our encoders/decoders. Which means we cannot use the actual
           |definition here and we hard code the value to 1/2
           |]
-      . withGenerator generator
+      . withGenerator (const 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
@@ -209,21 +208,20 @@ instance Era era => HuddleRule "address" era where
           |     1111: account address: scripthash28
           |1001-1101: future formats
           |]
-      . withGenerator generator
+      . withGenerator (const 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
@@ -240,16 +238,16 @@ instance Era era => HuddleRule "address" era where
         pure $ S bytesTerm
 
 instance Era era => HuddleRule "reward_account" era where
-  huddleRuleNamed pname _ = withGenerator generator $ pname =.= VBytes
+  huddleRuleNamed pname _ = withGenerator (const 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/Core/HuddleSpec.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