From a5aa6184f292681c1e4b2689124f95ee71383b62 Mon Sep 17 00:00:00 2001 From: t4ccer Date: Thu, 31 Oct 2024 17:20:16 -0600 Subject: [PATCH 01/16] Add V1 PlutusLedgerApi QuickCheck instances --- plutus-ledger-api/plutus-ledger-api.cabal | 17 + .../Test/Common/QuickCheck/Utils.hs | 110 +++++ .../testlib/PlutusLedgerApi/Test/Orphans.hs | 4 + .../PlutusLedgerApi/Test/Orphans/PlutusTx.hs | 216 ++++++++++ .../PlutusLedgerApi/Test/Orphans/V1.hs | 12 + .../Test/Orphans/V1/Address.hs | 33 ++ .../Test/Orphans/V1/Contexts.hs | 191 +++++++++ .../Test/Orphans/V1/Credential.hs | 90 ++++ .../PlutusLedgerApi/Test/Orphans/V1/Crypto.hs | 18 + .../PlutusLedgerApi/Test/Orphans/V1/DCert.hs | 108 +++++ .../Test/Orphans/V1/Interval.hs | 229 ++++++++++ .../Test/Orphans/V1/Scripts.hs | 57 +++ .../PlutusLedgerApi/Test/Orphans/V1/Time.hs | 17 + .../PlutusLedgerApi/Test/Orphans/V1/Tx.hs | 73 ++++ .../PlutusLedgerApi/Test/Orphans/V1/Value.hs | 399 ++++++++++++++++++ 15 files changed, 1574 insertions(+) create mode 100644 plutus-ledger-api/testlib/PlutusLedgerApi/Test/Common/QuickCheck/Utils.hs create mode 100644 plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans.hs create mode 100644 plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/PlutusTx.hs create mode 100644 plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1.hs create mode 100644 plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Address.hs create mode 100644 plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Contexts.hs create mode 100644 plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Credential.hs create mode 100644 plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Crypto.hs create mode 100644 plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/DCert.hs create mode 100644 plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Interval.hs create mode 100644 plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Scripts.hs create mode 100644 plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Time.hs create mode 100644 plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Tx.hs create mode 100644 plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Value.hs diff --git a/plutus-ledger-api/plutus-ledger-api.cabal b/plutus-ledger-api/plutus-ledger-api.cabal index 4f0231b3463..684392e7814 100644 --- a/plutus-ledger-api/plutus-ledger-api.cabal +++ b/plutus-ledger-api/plutus-ledger-api.cabal @@ -125,6 +125,7 @@ library plutus-ledger-api-testlib PlutusLedgerApi.Test.Common.EvaluationContext PlutusLedgerApi.Test.EvaluationEvent PlutusLedgerApi.Test.Examples + PlutusLedgerApi.Test.Orphans PlutusLedgerApi.Test.Scripts PlutusLedgerApi.Test.V1.Data.EvaluationContext PlutusLedgerApi.Test.V1.Data.Value @@ -136,6 +137,21 @@ library plutus-ledger-api-testlib PlutusLedgerApi.Test.V3.EvaluationContext PlutusLedgerApi.Test.V3.MintValue + other-modules: + PlutusLedgerApi.Test.Common.QuickCheck.Utils + PlutusLedgerApi.Test.Orphans.PlutusTx + PlutusLedgerApi.Test.Orphans.V1 + PlutusLedgerApi.Test.Orphans.V1.Address + PlutusLedgerApi.Test.Orphans.V1.Contexts + PlutusLedgerApi.Test.Orphans.V1.Credential + PlutusLedgerApi.Test.Orphans.V1.Crypto + PlutusLedgerApi.Test.Orphans.V1.DCert + PlutusLedgerApi.Test.Orphans.V1.Interval + PlutusLedgerApi.Test.Orphans.V1.Scripts + PlutusLedgerApi.Test.Orphans.V1.Time + PlutusLedgerApi.Test.Orphans.V1.Tx + PlutusLedgerApi.Test.Orphans.V1.Value + build-depends: , barbies , base >=4.9 && <5 @@ -149,6 +165,7 @@ library plutus-ledger-api-testlib , plutus-tx ^>=1.36 , prettyprinter , QuickCheck + , quickcheck-instances , serialise , text diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Common/QuickCheck/Utils.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Common/QuickCheck/Utils.hs new file mode 100644 index 00000000000..6a5e9d86acf --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Common/QuickCheck/Utils.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +module PlutusLedgerApi.Test.Common.QuickCheck.Utils ( + SizedByteString (SizedByteString), + unSizedByteString, + AsWord64 (AsWord64), + fromAsWord64, +) where + +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.Coerce (coerce) +import Data.Proxy (Proxy (Proxy)) +import Data.Word (Word64) +import GHC.TypeNats (KnownNat, Natural, natVal) +import Test.QuickCheck (Arbitrary (arbitrary, shrink), CoArbitrary, Function (function), + functionMap, vectorOf) +import Test.QuickCheck.Instances.ByteString () + +{- | Helper for 'ByteString's of a fixed length. We don't expose the +constructor, instead providing a read-only pattern, as well as an accessor +function, to ensure that the size invariant is maintained. +-} +newtype SizedByteString (n :: Natural) = UnsafeSizedByteString ByteString + deriving + (Eq + ,Ord + ) + via ByteString + deriving stock + (Show + ) + +type role SizedByteString nominal + +instance KnownNat n => Arbitrary (SizedByteString n) where + {-# INLINEABLE arbitrary #-} + arbitrary = + UnsafeSizedByteString . BS.pack <$> do + let !len = fromIntegral . natVal $ Proxy @n + vectorOf len arbitrary + {-# INLINEABLE shrink #-} + shrink = + fmap (UnsafeSizedByteString . BS.pack) + . traverse shrink + . BS.unpack + . unSizedByteString + +deriving via ByteString instance CoArbitrary (SizedByteString n) + + +instance Function (SizedByteString n) where + {-# INLINEABLE function #-} + function = functionMap coerce UnsafeSizedByteString + +{- | Read-only pattern for accessing the underlying 'ByteString'. Use it just +like you would use a data constructor in a pattern match. +-} +pattern SizedByteString :: forall (n :: Natural). ByteString -> SizedByteString n +pattern SizedByteString bs <- UnsafeSizedByteString bs + +{-# COMPLETE SizedByteString #-} + +{- | Get the underlying 'ByteString'. It is guaranteed to have the length +specified in its type. +-} +unSizedByteString :: + forall (n :: Natural). + SizedByteString n -> + ByteString +unSizedByteString = coerce + +{- | Plutus' ledger API often has to \'fake\' 'Word64' using the much larger +'Integer' type. This helper is designed to generate 'Integer's that fit into +'Word64'. + +We don't expose the constructor directly; instead, we provide a read-only +pattern and an accessor function. +-} +newtype AsWord64 = UnsafeAsWord64 Word64 + deriving + (Eq + ,Ord + ,Arbitrary + ,CoArbitrary + ) + via Word64 + deriving stock + (Show + ) + +instance Function AsWord64 where + {-# INLINEABLE function #-} + function = functionMap coerce UnsafeAsWord64 + +{- | Read-only pattern for accessing the underlying 'Integer'. Use it just like +you would use a data constructor in a pattern match. +-} +pattern AsWord64 :: Integer -> AsWord64 +pattern AsWord64 i <- (fromAsWord64 -> i) + +fromAsWord64 :: AsWord64 -> Integer +fromAsWord64 = fromIntegral . coerce @_ @Word64 diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans.hs new file mode 100644 index 00000000000..3dd90191d7c --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans.hs @@ -0,0 +1,4 @@ +module PlutusLedgerApi.Test.Orphans () where + +import PlutusLedgerApi.Test.Orphans.PlutusTx () +import PlutusLedgerApi.Test.Orphans.V1 () diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/PlutusTx.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/PlutusTx.hs new file mode 100644 index 00000000000..f857c861285 --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/PlutusTx.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module PlutusLedgerApi.Test.Orphans.PlutusTx ( + Blake2b256Hash (..), + Blake2b244Hash (..), + getBlake2b256Hash, + getBlake2b244Hash, + ) where + +import Data.ByteString (ByteString) +import Data.Coerce (coerce) +import Data.Kind (Type) +import Data.Set qualified as Set +import PlutusLedgerApi.Test.Common.QuickCheck.Utils (unSizedByteString) +import PlutusTx.AssocMap qualified as AssocMap +import PlutusTx.Builtins qualified as Builtins +import PlutusTx.Prelude qualified as PlutusTx +import Test.QuickCheck (Arbitrary (arbitrary, shrink), Arbitrary1 (liftArbitrary, liftShrink), + CoArbitrary (coarbitrary), Function (function), Gen, + NonNegative (NonNegative), functionMap, getNonNegative, liftArbitrary, + oneof, scale, sized, variant) +import Test.QuickCheck.Instances.ByteString () + +instance Arbitrary PlutusTx.BuiltinByteString where + {-# INLINEABLE arbitrary #-} + arbitrary = PlutusTx.toBuiltin @ByteString <$> arbitrary + {-# INLINEABLE shrink #-} + shrink = fmap (PlutusTx.toBuiltin @ByteString) . shrink . PlutusTx.fromBuiltin + +instance CoArbitrary PlutusTx.BuiltinByteString where + {-# INLINEABLE coarbitrary #-} + coarbitrary = coarbitrary . PlutusTx.fromBuiltin + +instance Function PlutusTx.BuiltinByteString where + {-# INLINEABLE function #-} + function = functionMap PlutusTx.fromBuiltin (PlutusTx.toBuiltin @ByteString) + +{- | Wrapper for BLAKE2b-244 hashes for convenience. +-} +newtype Blake2b244Hash = Blake2b244Hash PlutusTx.BuiltinByteString + deriving (Eq, Ord) via PlutusTx.BuiltinByteString + deriving stock (Show) + +-- No shrinker, as it doesn't make much sense to. +instance Arbitrary Blake2b244Hash where + {-# INLINEABLE arbitrary #-} + arbitrary = + Blake2b244Hash . PlutusTx.toBuiltin @ByteString . unSizedByteString @28 <$> arbitrary + +deriving via PlutusTx.BuiltinByteString instance CoArbitrary Blake2b244Hash + +getBlake2b244Hash :: Blake2b244Hash -> PlutusTx.BuiltinByteString +getBlake2b244Hash = coerce + +-- Wrapper for BLAKE2b-256 hashes for convenience. +newtype Blake2b256Hash = Blake2b256Hash PlutusTx.BuiltinByteString + deriving (Eq, Ord) via PlutusTx.BuiltinByteString + deriving stock (Show) + +-- No shrinker, as it doesn't make much sense to. +instance Arbitrary Blake2b256Hash where + {-# INLINEABLE arbitrary #-} + arbitrary = + Blake2b256Hash . PlutusTx.toBuiltin @ByteString . unSizedByteString @32 <$> arbitrary + +deriving via PlutusTx.BuiltinByteString instance CoArbitrary Blake2b256Hash + +getBlake2b256Hash :: Blake2b256Hash -> PlutusTx.BuiltinByteString +getBlake2b256Hash = coerce + +{- | This is a very general instance, able to produce 'PlutusTx.BuiltinData' of +basically any shape. You probably want something more focused than this. +-} +instance Arbitrary PlutusTx.BuiltinData where + {-# INLINEABLE arbitrary #-} + arbitrary = sized $ \size -> go size + where + scaleDown :: forall (a :: Type). Gen a -> Gen a + scaleDown = scale (`quot` 4) + go :: Int -> Gen PlutusTx.BuiltinData + go size + | size <= 0 = oneof [genB, genI] + | otherwise = oneof [genB, genI, genConstr, genList, genMap] + genB :: Gen PlutusTx.BuiltinData + genB = Builtins.mkB <$> arbitrary + genI :: Gen PlutusTx.BuiltinData + genI = Builtins.mkI <$> arbitrary + genConstr :: Gen PlutusTx.BuiltinData + genConstr = + Builtins.mkConstr . getNonNegative + <$> arbitrary + <*> scaleDown (liftArbitrary arbitrary) + genList :: Gen PlutusTx.BuiltinData + genList = + Builtins.mkList <$> scaleDown (liftArbitrary arbitrary) + genMap :: Gen PlutusTx.BuiltinData + genMap = + Builtins.mkMap <$> scaleDown (liftArbitrary ((,) <$> arbitrary <*> arbitrary)) + {-# INLINEABLE shrink #-} + shrink dat = + Builtins.matchData + dat + shrinkConstr + shrinkMap + shrinkList + (fmap (Builtins.mkI . getNonNegative) . shrink . NonNegative) + (fmap Builtins.mkB . shrink) + where + shrinkConstr :: Integer -> [PlutusTx.BuiltinData] -> [PlutusTx.BuiltinData] + shrinkConstr ix dats = do + NonNegative ix' <- shrink (NonNegative ix) + dats' <- shrink dats + pure . Builtins.mkConstr ix' $ dats' + shrinkMap :: [(PlutusTx.BuiltinData, PlutusTx.BuiltinData)] -> [PlutusTx.BuiltinData] + shrinkMap kvs = Builtins.mkMap <$> shrink kvs + shrinkList :: [PlutusTx.BuiltinData] -> [PlutusTx.BuiltinData] + shrinkList ell = Builtins.mkList <$> shrink ell + +instance CoArbitrary PlutusTx.BuiltinData where + {-# INLINEABLE coarbitrary #-} + coarbitrary dat = + Builtins.matchData + dat + (\ix dats -> variant (0 :: Int) . coarbitrary ix . coarbitrary dats) + (\kvs -> variant (1 :: Int) . coarbitrary kvs) + (\ell -> variant (2 :: Int) . coarbitrary ell) + (\i -> variant (3 :: Int) . coarbitrary i) + (\bs -> variant (4 :: Int) . coarbitrary bs) + +instance Function PlutusTx.BuiltinData where + {-# INLINEABLE function #-} + function = functionMap into outOf + where + into :: + PlutusTx.BuiltinData -> + Either + (Integer, [PlutusTx.BuiltinData]) + ( Either + [(PlutusTx.BuiltinData, PlutusTx.BuiltinData)] + ( Either + [PlutusTx.BuiltinData] + ( Either Integer PlutusTx.BuiltinByteString + ) + ) + ) + into dat = + Builtins.matchData + dat + (\ix -> Left . (ix,)) + (Right . Left) + (Right . Right . Left) + (Right . Right . Right . Left) + (Right . Right . Right . Right) + outOf :: + Either + (Integer, [PlutusTx.BuiltinData]) + ( Either + [(PlutusTx.BuiltinData, PlutusTx.BuiltinData)] + ( Either + [PlutusTx.BuiltinData] + ( Either Integer PlutusTx.BuiltinByteString + ) + ) + ) -> + PlutusTx.BuiltinData + outOf = \case + Left (ix, dats) -> Builtins.mkConstr ix dats + Right (Left kvs) -> Builtins.mkMap kvs + Right (Right (Left ell)) -> Builtins.mkList ell + Right (Right (Right (Left i))) -> Builtins.mkI i + Right (Right (Right (Right bs))) -> Builtins.mkB bs + +{- | This generates well-defined maps: specifically, there are no duplicate +keys. To ensure that this is preserved, we do not shrink keys: we only drop +whole entries, or shrink values associated with keys. + +In order to make this instance even moderately efficient, we require an 'Ord' +constraint on keys. In practice, this isn't a significant limitation, as +basically all Plutus types have such an instance. + +-} +instance (Arbitrary k, Ord k) => Arbitrary1 (AssocMap.Map k) where + {-# INLINEABLE liftArbitrary #-} + liftArbitrary genVal = + AssocMap.unsafeFromList <$> do + -- First, generate a Set of keys to ensure no duplication + keyList <- Set.toList <$> arbitrary + -- Then generate a value for each + traverse (\key -> (key,) <$> genVal) keyList + {-# INLINEABLE liftShrink #-} + liftShrink shrinkVal aMap = + AssocMap.unsafeFromList <$> do + let asList = AssocMap.toList aMap + liftShrink (\(key, val) -> (key,) <$> shrinkVal val) asList + +instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (AssocMap.Map k v) where + {-# INLINEABLE arbitrary #-} + arbitrary = liftArbitrary arbitrary + {-# INLINEABLE shrink #-} + shrink = liftShrink shrink + +instance (CoArbitrary k, CoArbitrary v) => CoArbitrary (AssocMap.Map k v) where + {-# INLINEABLE coarbitrary #-} + coarbitrary = coarbitrary . AssocMap.toList + +instance (Function k, Function v) => Function (AssocMap.Map k v) where + {-# INLINEABLE function #-} + function = functionMap AssocMap.toList AssocMap.unsafeFromList diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1.hs new file mode 100644 index 00000000000..755bb4ceaab --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1.hs @@ -0,0 +1,12 @@ +module PlutusLedgerApi.Test.Orphans.V1 () where + +import PlutusLedgerApi.Test.Orphans.V1.Address () +import PlutusLedgerApi.Test.Orphans.V1.Contexts () +import PlutusLedgerApi.Test.Orphans.V1.Credential () +import PlutusLedgerApi.Test.Orphans.V1.Crypto () +import PlutusLedgerApi.Test.Orphans.V1.DCert () +import PlutusLedgerApi.Test.Orphans.V1.Interval () +import PlutusLedgerApi.Test.Orphans.V1.Scripts () +import PlutusLedgerApi.Test.Orphans.V1.Time () +import PlutusLedgerApi.Test.Orphans.V1.Tx () +import PlutusLedgerApi.Test.Orphans.V1.Value () diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Address.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Address.hs new file mode 100644 index 00000000000..7a720db07f4 --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Address.hs @@ -0,0 +1,33 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module PlutusLedgerApi.Test.Orphans.V1.Address () where + +import PlutusLedgerApi.Test.Orphans.V1.Credential () +import PlutusLedgerApi.V1.Address (Address (Address)) +import PlutusLedgerApi.V1.Credential (Credential, StakingCredential) +import Test.QuickCheck (Arbitrary (arbitrary, shrink), CoArbitrary (coarbitrary), + Function (function), functionMap) + +instance Arbitrary Address where + {-# INLINEABLE arbitrary #-} + arbitrary = Address <$> arbitrary <*> arbitrary + + {-# INLINEABLE shrink #-} + -- As Credential does not shrink, we just pass it through. + shrink (Address cred scred) = Address cred <$> shrink scred + +instance CoArbitrary Address where + {-# INLINEABLE coarbitrary #-} + coarbitrary (Address cred scred) = + coarbitrary cred . coarbitrary scred + +instance Function Address where + {-# INLINEABLE function #-} + function = functionMap into outOf + where + into :: Address -> (Credential, Maybe StakingCredential) + into (Address cred scred) = (cred, scred) + + outOf :: (Credential, Maybe StakingCredential) -> Address + outOf (cred, scred) = Address cred scred + diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Contexts.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Contexts.hs new file mode 100644 index 00000000000..181a80515bb --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Contexts.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE LambdaCase #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module PlutusLedgerApi.Test.Orphans.V1.Contexts () where + +import Data.Set qualified as Set +import PlutusLedgerApi.Test.Orphans.V1.DCert () +import PlutusLedgerApi.Test.Orphans.V1.Interval () +import PlutusLedgerApi.Test.Orphans.V1.Tx () +import PlutusLedgerApi.Test.Orphans.V1.Value qualified as Value +import PlutusLedgerApi.V1.Contexts (ScriptContext (ScriptContext), + ScriptPurpose (Certifying, Minting, Rewarding, Spending), + TxInInfo (TxInInfo), TxInfo (TxInfo)) +import PlutusLedgerApi.V1.Credential (StakingCredential) +import PlutusLedgerApi.V1.Crypto (PubKeyHash) +import PlutusLedgerApi.V1.DCert (DCert) +import PlutusLedgerApi.V1.Scripts (Datum, DatumHash) +import PlutusLedgerApi.V1.Time (POSIXTimeRange) +import PlutusLedgerApi.V1.Tx (TxId, TxOut, TxOutRef) +import PlutusLedgerApi.V1.Value (CurrencySymbol, Value) +import Test.QuickCheck (Arbitrary (arbitrary, shrink), CoArbitrary (coarbitrary), + Function (function), NonEmptyList (NonEmpty), functionMap, getNonEmpty, + oneof, variant) + +instance Arbitrary ScriptContext where + {-# INLINEABLE arbitrary #-} + arbitrary = ScriptContext <$> arbitrary <*> arbitrary + + {-# INLINEABLE shrink #-} + shrink (ScriptContext tinfo p) = + ScriptContext <$> shrink tinfo <*> shrink p + +instance CoArbitrary ScriptContext where + {-# INLINEABLE coarbitrary #-} + coarbitrary (ScriptContext tinfo p) = + coarbitrary tinfo . coarbitrary p + +instance Function ScriptContext where + {-# INLINEABLE function #-} + function = + functionMap + (\(ScriptContext tinfo p) -> (tinfo, p)) + (uncurry ScriptContext) + + +instance Arbitrary TxInInfo where + {-# INLINEABLE arbitrary #-} + arbitrary = TxInInfo <$> arbitrary <*> arbitrary + + {-# INLINEABLE shrink #-} + shrink (TxInInfo outref resolved) = + TxInInfo <$> shrink outref <*> shrink resolved + +instance CoArbitrary TxInInfo where + {-# INLINEABLE coarbitrary #-} + coarbitrary (TxInInfo outref resolved) = + coarbitrary outref . coarbitrary resolved + +instance Function TxInInfo where + {-# INLINEABLE function #-} + function = + functionMap + (\(TxInInfo outref resolved) -> (outref, resolved)) + (uncurry TxInInfo) + + +instance Arbitrary TxInfo where + {-# INLINEABLE arbitrary #-} + arbitrary = + TxInfo . getNonEmpty + <$> arbitrary -- inputs + <*> (getNonEmpty <$> arbitrary) -- outputs + <*> (Value.getFeeValue <$> arbitrary) -- fee + <*> (Value.getMintValue <$> arbitrary) -- mint + <*> arbitrary -- dcert + <*> arbitrary -- withdrawals + <*> arbitrary -- valid time range + <*> (Set.toList <$> arbitrary) -- signatories + <*> arbitrary -- data + <*> arbitrary -- tid + + {-# INLINEABLE shrink #-} + shrink (TxInfo ins outs fee mint dcert wdrl validRange sigs dats tid) = do + NonEmpty ins' <- shrink (NonEmpty ins) + NonEmpty outs' <- shrink (NonEmpty outs) + Value.FeeValue fee' <- shrink (Value.FeeValue fee) + Value.MintValue mint' <- shrink (Value.MintValue mint) + dcert' <- shrink dcert + wdrl' <- shrink wdrl + validRange' <- shrink validRange + sigs' <- Set.toList <$> shrink (Set.fromList sigs) + dats' <- shrink dats + tid' <- shrink tid + pure . TxInfo ins' outs' fee' mint' dcert' wdrl' validRange' sigs' dats' $ tid' + +instance CoArbitrary TxInfo where + {-# INLINEABLE coarbitrary #-} + coarbitrary (TxInfo ins outs fee mint dcert wdrl validRange sigs dats tid) = + coarbitrary ins + . coarbitrary outs + . coarbitrary fee + . coarbitrary mint + . coarbitrary dcert + . coarbitrary wdrl + . coarbitrary validRange + . coarbitrary sigs + . coarbitrary dats + . coarbitrary tid + +instance Function TxInfo where + {-# INLINEABLE function #-} + function = functionMap into outOf + where + -- We have to nest tuples as Function doesn't have instances for anything + -- bigger than a 6-tuple. + into :: + TxInfo -> + ([TxInInfo] + , [TxOut] + , Value + , Value + , [DCert] + , ( [(StakingCredential, Integer)] + , POSIXTimeRange, [PubKeyHash] + , [(DatumHash, Datum)] + , TxId)) + into (TxInfo ins outs fee mint dcert wdrl validRange sigs dats tid) = + (ins, outs, fee, mint, dcert, (wdrl, validRange, sigs, dats, tid)) + + outOf :: + ([TxInInfo] + , [TxOut] + , Value + , Value + , [DCert] + , ( [(StakingCredential, Integer)] + , POSIXTimeRange, [PubKeyHash] + , [(DatumHash, Datum)] + , TxId)) -> + TxInfo + outOf (ins, outs, fee, mint, dcert, (wdrl, validRange, sigs, dats, tid)) = + TxInfo ins outs fee mint dcert wdrl validRange sigs dats tid + + +instance Arbitrary ScriptPurpose where + {-# INLINEABLE arbitrary #-} + arbitrary = + oneof + [ Minting <$> arbitrary + , Spending <$> arbitrary + , Rewarding <$> arbitrary + , Certifying <$> arbitrary + ] + + {-# INLINEABLE shrink #-} + shrink = \case + Minting cs -> Minting <$> shrink cs + Spending txo -> Spending <$> shrink txo + Rewarding scred -> Rewarding <$> shrink scred + Certifying dcert -> Certifying <$> shrink dcert + +instance CoArbitrary ScriptPurpose where + {-# INLINEABLE coarbitrary #-} + coarbitrary = \case + Minting cs -> variant (0 :: Int) . coarbitrary cs + Spending txo -> variant (1 :: Int) . coarbitrary txo + Rewarding scred -> variant (2 :: Int) . coarbitrary scred + Certifying dcert -> variant (3 :: Int) . coarbitrary dcert + +instance Function ScriptPurpose where + {-# INLINEABLE function #-} + function = functionMap into outOf + where + into :: + ScriptPurpose -> + Either CurrencySymbol (Either TxOutRef (Either StakingCredential DCert)) + into = \case + Minting cs -> Left cs + Spending txo -> Right (Left txo) + Rewarding scred -> Right (Right (Left scred)) + Certifying dcert -> Right (Right (Right dcert)) + + outOf :: + Either CurrencySymbol (Either TxOutRef (Either StakingCredential DCert)) -> + ScriptPurpose + outOf = \case + Left cs -> Minting cs + Right (Left txo) -> Spending txo + Right (Right (Left scred)) -> Rewarding scred + Right (Right (Right dcert)) -> Certifying dcert diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Credential.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Credential.hs new file mode 100644 index 00000000000..e55acb1433c --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Credential.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE LambdaCase #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module PlutusLedgerApi.Test.Orphans.V1.Credential () where + +import PlutusLedgerApi.Test.Common.QuickCheck.Utils (fromAsWord64) +import PlutusLedgerApi.Test.Orphans.V1.Crypto () +import PlutusLedgerApi.Test.Orphans.V1.Scripts () +import PlutusLedgerApi.V1.Credential (Credential (PubKeyCredential, ScriptCredential), + StakingCredential (StakingHash, StakingPtr)) +import PlutusLedgerApi.V1.Crypto (PubKeyHash) +import PlutusLedgerApi.V1.Scripts (ScriptHash) +import Test.QuickCheck (Arbitrary (arbitrary, shrink), CoArbitrary (coarbitrary), + Function (function), NonNegative (NonNegative), functionMap, oneof, variant) + +{- | As 'Credential' is just a wrapper around a hash with a tag, shrinking +this type doesn't make much sense. Therefore we don't do it. +-} +instance Arbitrary Credential where + {-# INLINEABLE arbitrary #-} + arbitrary = + oneof + [ PubKeyCredential <$> arbitrary + , ScriptCredential <$> arbitrary + ] + +instance CoArbitrary Credential where + {-# INLINEABLE coarbitrary #-} + coarbitrary = \case + PubKeyCredential pkh -> variant (0 :: Int) . coarbitrary pkh + ScriptCredential sh -> variant (1 :: Int) . coarbitrary sh + +instance Function Credential where + {-# INLINEABLE function #-} + function = functionMap into outOf + where + into :: Credential -> Either PubKeyHash ScriptHash + into = \case + PubKeyCredential pkh -> Left pkh + ScriptCredential sh -> Right sh + + outOf :: Either PubKeyHash ScriptHash -> Credential + outOf = \case + Left pkh -> PubKeyCredential pkh + Right sh -> ScriptCredential sh + + +instance Arbitrary StakingCredential where + {-# INLINEABLE arbitrary #-} + arbitrary = + oneof + [ StakingHash <$> arbitrary + , StakingPtr . fromAsWord64 + <$> arbitrary + <*> (fromAsWord64 <$> arbitrary) + <*> (fromAsWord64 <$> arbitrary) + ] + + {-# INLINEABLE shrink #-} + shrink = \case + -- Since Credentials don't shrink, we don't shrink this case + StakingHash _ -> [] + StakingPtr i j k -> do + NonNegative i' <- shrink (NonNegative i) + NonNegative j' <- shrink (NonNegative j) + NonNegative k' <- shrink (NonNegative k) + pure . StakingPtr i' j' $ k' + +instance CoArbitrary StakingCredential where + {-# INLINEABLE coarbitrary #-} + coarbitrary = \case + StakingHash cred -> variant (0 :: Int) . coarbitrary cred + StakingPtr i j k -> + variant (1 :: Int) . coarbitrary i . coarbitrary j . coarbitrary k + +instance Function StakingCredential where + {-# INLINEABLE function #-} + function = functionMap into outOf + where + into :: StakingCredential -> Either Credential (Integer, Integer, Integer) + into = \case + StakingHash cred -> Left cred + StakingPtr i j k -> Right (i, j, k) + + outOf :: Either Credential (Integer, Integer, Integer) -> StakingCredential + outOf = \case + Left cred -> StakingHash cred + Right (i, j, k) -> StakingPtr i j k + diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Crypto.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Crypto.hs new file mode 100644 index 00000000000..bcc589547d2 --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Crypto.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE DerivingVia #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module PlutusLedgerApi.Test.Orphans.V1.Crypto () where + +import Data.Coerce (coerce) +import PlutusLedgerApi.Test.Orphans.PlutusTx (Blake2b244Hash (Blake2b244Hash)) +import PlutusLedgerApi.V1.Crypto (PubKeyHash (PubKeyHash)) +import Test.QuickCheck (Arbitrary, CoArbitrary, Function (function), functionMap) + +-- | BLAKE2b-244 hash. This does not shrink. +deriving via Blake2b244Hash instance Arbitrary PubKeyHash + +deriving via Blake2b244Hash instance CoArbitrary PubKeyHash + +instance Function PubKeyHash where + {-# INLINEABLE function #-} + function = functionMap coerce PubKeyHash diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/DCert.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/DCert.hs new file mode 100644 index 00000000000..b9a25455649 --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/DCert.hs @@ -0,0 +1,108 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE LambdaCase #-} + +module PlutusLedgerApi.Test.Orphans.V1.DCert () where + +import PlutusLedgerApi.Test.Common.QuickCheck.Utils (fromAsWord64) +import PlutusLedgerApi.Test.Orphans.V1.Credential () +import PlutusLedgerApi.V1.Credential (StakingCredential) +import PlutusLedgerApi.V1.Crypto (PubKeyHash) +-- unqualified improt because formatter + line limit makes it impossible +import PlutusLedgerApi.V1.DCert (DCert (..)) +import Test.QuickCheck (Arbitrary (arbitrary, shrink), CoArbitrary (coarbitrary), + Function (function), NonNegative (NonNegative), functionMap, getNonNegative, + oneof, variant) + +instance Arbitrary DCert where + {-# INLINEABLE arbitrary #-} + arbitrary = + oneof + [ DCertDelegRegKey <$> arbitrary + , DCertDelegDeRegKey <$> arbitrary + , DCertDelegDelegate <$> arbitrary <*> arbitrary + , DCertPoolRegister <$> arbitrary <*> arbitrary + , DCertPoolRetire <$> arbitrary <*> (fromAsWord64 <$> arbitrary) + , pure DCertGenesis + , pure DCertMir + ] + + {-# INLINEABLE shrink #-} + shrink = \case + DCertDelegRegKey sc -> DCertDelegRegKey <$> shrink sc + DCertDelegDeRegKey sc -> DCertDelegDeRegKey <$> shrink sc + -- PubKeyHash can't shrink, so we just pass it through, as otherwise, the + -- semantics of shrinking would mean the whole think can't shrink. + DCertDelegDelegate sc pkh -> DCertDelegDelegate <$> shrink sc <*> pure pkh + -- PubKeyHash can't shrink, so neither can this. + DCertPoolRegister _ _ -> [] + -- PubKeyHash can't shrink, so we just pass it through, as otherwise, the + -- semantics of shrinking would mean the whole think can't shrink. + DCertPoolRetire pkh e -> + DCertPoolRetire pkh . getNonNegative <$> shrink (NonNegative e) + -- None of the other constructors have any data, so we don't shrink them. + _ -> [] + +instance CoArbitrary DCert where + {-# INLINEABLE coarbitrary #-} + coarbitrary = \case + DCertDelegRegKey sc -> variant (0 :: Int) . coarbitrary sc + DCertDelegDeRegKey sc -> variant (1 :: Int) . coarbitrary sc + DCertDelegDelegate sc pkh -> variant (2 :: Int) . coarbitrary sc . coarbitrary pkh + DCertPoolRegister pkh pkh' -> variant (3 :: Int) . coarbitrary pkh . coarbitrary pkh' + DCertPoolRetire pkh e -> variant (4 :: Int) . coarbitrary pkh . coarbitrary e + DCertGenesis -> variant (5 :: Int) + DCertMir -> variant (6 :: Int) + +instance Function DCert where + {-# INLINEABLE function #-} + function = functionMap into outOf + where + into :: + DCert -> + Maybe + ( Maybe + ( Either + StakingCredential + ( Either + StakingCredential + ( Either + (StakingCredential, PubKeyHash) + ( Either (PubKeyHash, PubKeyHash) (PubKeyHash, Integer) + ) + ) + ) + ) + ) + into = \case + DCertGenesis -> Nothing + DCertMir -> Just Nothing + DCertDelegRegKey sc -> Just (Just (Left sc)) + DCertDelegDeRegKey sc -> Just (Just (Right (Left sc))) + DCertDelegDelegate sc pkh -> Just (Just (Right (Right (Left (sc, pkh))))) + DCertPoolRegister pkh pkh' -> Just (Just (Right (Right (Right (Left (pkh, pkh')))))) + DCertPoolRetire pkh e -> Just (Just (Right (Right (Right (Right (pkh, e)))))) + + outOf :: + Maybe + ( Maybe + ( Either + StakingCredential + ( Either + StakingCredential + ( Either + (StakingCredential, PubKeyHash) + ( Either (PubKeyHash, PubKeyHash) (PubKeyHash, Integer) + ) + ) + ) + ) + ) -> + DCert + outOf = \case + Nothing -> DCertGenesis + Just Nothing -> DCertMir + Just (Just (Left sc)) -> DCertDelegRegKey sc + Just (Just (Right (Left sc))) -> DCertDelegDeRegKey sc + Just (Just (Right (Right (Left (sc, pkh))))) -> DCertDelegDelegate sc pkh + Just (Just (Right (Right (Right (Left (pkh, pkh')))))) -> DCertPoolRegister pkh pkh' + Just (Just (Right (Right (Right (Right (pkh, e)))))) -> DCertPoolRetire pkh e diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Interval.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Interval.hs new file mode 100644 index 00000000000..b9a05171038 --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Interval.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module PlutusLedgerApi.Test.Orphans.V1.Interval () where + +import Data.Word (Word32) +import PlutusLedgerApi.Test.Orphans.V1.Time () +import PlutusLedgerApi.V1.Interval (Extended (Finite, NegInf, PosInf), Interval (Interval), + LowerBound (LowerBound), UpperBound (UpperBound), always, never, + singleton) +import PlutusLedgerApi.V1.Time (POSIXTime) +import Test.QuickCheck (Arbitrary (arbitrary, shrink), Arbitrary1 (liftArbitrary, liftShrink), + CoArbitrary (coarbitrary), Function (function), frequency, functionMap, + getNonNegative, oneof, variant) + +{- | This instance does not bias the constructor choice: it is equally likely to +produce 'Finite', 'NegInf' and 'PosInf'. Bear this in mind when +using: in particular, the instance for 'Interval' /does not/ make use of +this instance. +-} +instance Arbitrary1 Extended where + {-# INLINEABLE liftArbitrary #-} + liftArbitrary genInner = + oneof + [ pure NegInf + , Finite <$> genInner + , pure PosInf + ] + + {-# INLINEABLE liftShrink #-} + liftShrink shrinkInner = \case + NegInf -> [] + Finite x -> Finite <$> shrinkInner x + PosInf -> [] + +{- | This makes use of the 'Arbitrary1' instance of 'Extended' internally, +and thus is subject to the same caveats. +-} +instance Arbitrary a => Arbitrary (Extended a) where + {-# INLINEABLE arbitrary #-} + arbitrary = liftArbitrary arbitrary + + {-# INLINEABLE shrink #-} + shrink = liftShrink shrink + +instance CoArbitrary a => CoArbitrary (Extended a) where + {-# INLINEABLE coarbitrary #-} + coarbitrary = \case + NegInf -> variant (0 :: Int) + Finite x -> variant (1 :: Int) . coarbitrary x + PosInf -> variant (2 :: Int) + +instance Function a => Function (Extended a) where + {-# INLINEABLE function #-} + function = functionMap into outOf + where + into :: Extended a -> Maybe (Maybe a) + into = \case + NegInf -> Nothing + PosInf -> Just Nothing + Finite x -> Just (Just x) + + outOf :: Maybe (Maybe a) -> Extended a + outOf = \case + Nothing -> NegInf + Just Nothing -> PosInf + Just (Just x) -> Finite x + + +{- | This makes use of the 'Arbitrary1' instance of 'Extended' internally, +and thus is subject to the same caveats. Furthermore, in cases where it makes +sense to talk about open and closed bounds, this instance produces open and +closed bounds with equal probability. Keep these in mind when using this +instance; in particular, the instance for 'Interval' /does not/ make use +of this instance. +-} +instance Arbitrary (LowerBound POSIXTime) where + {-# INLINEABLE arbitrary #-} + arbitrary = do + e <- arbitrary + case e of + -- For a finite bound, it makes sense to talk about it being open or + -- closed. + Finite _ -> LowerBound e <$> arbitrary + -- If the bound is infinite, it _must_ be open. + _ -> pure . LowerBound e $ False + + {-# INLINEABLE shrink #-} + shrink (LowerBound e c) = case e of + Finite _ -> LowerBound <$> shrink e <*> shrink c + -- Negative or positive infinity bounds can't really shrink sensibly + _ -> [] + +instance CoArbitrary a => CoArbitrary (LowerBound a) where + {-# INLINEABLE coarbitrary #-} + coarbitrary (LowerBound e c) = coarbitrary e . coarbitrary c + +instance Function a => Function (LowerBound a) where + {-# INLINEABLE function #-} + function = functionMap (\(LowerBound e c) -> (e, c)) (uncurry LowerBound) + + +{- | This makes use of the 'Arbitrary1' instance of 'Extended' internally, +and thus is subject to the same caveats. Furthermore, in cases where it makes +sense to talk about open and closed bounds, this instance produces open and +closed bounds with equal probability. Keep these in mind when using this +instance; in particular, the instance for 'Interval' /does not/ make use +of this instance. +-} +instance Arbitrary (UpperBound POSIXTime) where + {-# INLINEABLE arbitrary #-} + arbitrary = do + e <- arbitrary + case e of + -- For a finite bound, it makes sense to talk about it being open or + -- closed. + Finite _ -> UpperBound e <$> arbitrary + -- If the bound is infinite, it _must_ be open. + _ -> pure . UpperBound e $ False + + {-# INLINEABLE shrink #-} + shrink (UpperBound e c) = case e of + Finite _ -> UpperBound <$> shrink e <*> shrink c + -- Negative or positive infinity bounds can't really shrink sensibly + _ -> [] + +instance CoArbitrary a => CoArbitrary (UpperBound a) where + {-# INLINEABLE coarbitrary #-} + coarbitrary (UpperBound e c) = coarbitrary e . coarbitrary c + +instance Function a => Function (UpperBound a) where + {-# INLINEABLE function #-} + function = functionMap (\(UpperBound e c) -> (e, c)) (uncurry UpperBound) + + +{- | We provide an instance specialized to 'POSIXTime', rather than a more +general one, as it doesn't make much sense to talk about 'Interval's of +arbitrary types in general. Furthermore, this is the only instance we +actually use, so there's no real loss there. + +This instance tries to make time intervals as fairly as possible, while also +ensuring that they're sensibly formed. We work under the assumption of a +32-bit epoch: while this is _technically_ not going to last much longer, +we're safe until about 2030 on that basis, which should be enough for now. + +We choose not to shrink intervals, as this is surprisingly complex: in at +least one common case, it's not even possible to write a shrinker that will +ever 'bottom out', due to us having infinite bounds! +-} +instance Arbitrary (Interval POSIXTime) where + {-# INLINEABLE arbitrary #-} + arbitrary = do + let epochSize = fromIntegral (maxBound :: Word32) + lowerBound <- + frequency + [ (1, pure NegInf) + , (1, pure PosInf) + , (epochSize, Finite . getNonNegative <$> arbitrary) + ] + case lowerBound of + -- With a finite lower bound, it makes sense to talk about an upper one + Finite x -> do + lowerClosure <- arbitrary + let lower = LowerBound lowerBound lowerClosure + -- To ensure we generate something sensible for the upper bound, we + -- either generate a 'diff', or positive infinity. + whatUpper <- + frequency + [ (1, pure . Left $ PosInf) + , (epochSize, Right . getNonNegative <$> arbitrary) + ] + case whatUpper of + -- If we have an infinite upper bound, we know it will be open. + Left _ -> do + let upper = UpperBound PosInf False + pure . Interval lower $ upper + Right diff -> case (diff, lowerClosure) of + -- A diff of 0 means we can only have a singleton closure sensibly. + (0, _) -> pure . singleton $ x + -- A diff of 1 with an open lower bound means we either have a + -- singleton closure or an empty one. + (1, False) -> do + upperClosure <- arbitrary + pure $ + if upperClosure + then singleton x + else never + -- A diff of 1 with a closed lower bound is either a singleton + -- closure or one with two values. + (1, True) -> do + upperClosure <- arbitrary + pure $ + if upperClosure + then Interval lower . UpperBound (Finite (x + diff)) $ upperClosure + else singleton x + -- A diff bigger than 1 can be treated uniformly. + (_, _) -> Interval lower . UpperBound (Finite (x + diff)) <$> arbitrary + -- With an negative infinite lower bound, we know it will be open. + NegInf -> do + let lower = LowerBound lowerBound False + -- To ensure we generate something sensible for the upper bound, we + -- do not attempt to generate NegInf + upperBound <- + frequency + [ (1, pure PosInf) + , (epochSize, Finite . getNonNegative <$> arbitrary) + ] + case upperBound of + -- With a finite upper bound, we just choose a closure and move on. + Finite _ -> do + upper <- UpperBound upperBound <$> arbitrary + pure . Interval lower $ upper + -- With an infinite upper bound, we have the range that includes + -- everything. We use the canonical choice provided by + -- always. + _ -> pure always + -- With an positive infinite lower bound, we have the empty interval, and + -- can choose any representation of such that we like. We use the + -- canonical choice provided by never. + PosInf -> pure never + +instance CoArbitrary a => CoArbitrary (Interval a) where + {-# INLINEABLE coarbitrary #-} + coarbitrary (Interval lower upper) = coarbitrary lower . coarbitrary upper + +instance Function a => Function (Interval a) where + {-# INLINEABLE function #-} + function = functionMap (\(Interval lower upper) -> (lower, upper)) (uncurry Interval) diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Scripts.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Scripts.hs new file mode 100644 index 00000000000..b04ea4b0b2c --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Scripts.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE DerivingVia #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module PlutusLedgerApi.Test.Orphans.V1.Scripts () where + +import Data.Coerce (coerce) +import PlutusLedgerApi.Test.Orphans.PlutusTx (Blake2b244Hash (Blake2b244Hash), + Blake2b256Hash (Blake2b256Hash)) +import PlutusLedgerApi.V1.Scripts (Datum (Datum), DatumHash (DatumHash), Redeemer (Redeemer), + RedeemerHash (RedeemerHash), ScriptHash (ScriptHash)) +import PlutusTx.Prelude +import Test.QuickCheck (Arbitrary, CoArbitrary, Function (function), functionMap) + +deriving via BuiltinData instance Arbitrary Redeemer + +deriving via BuiltinData instance CoArbitrary Redeemer + +instance Function Redeemer where + {-# INLINEABLE function #-} + function = functionMap coerce Redeemer + + +deriving via BuiltinData instance Arbitrary Datum + +deriving via BuiltinData instance CoArbitrary Datum + +instance Function Datum where + {-# INLINEABLE function #-} + function = functionMap coerce Datum + + +deriving via Blake2b256Hash instance Arbitrary DatumHash + +deriving via Blake2b256Hash instance CoArbitrary DatumHash + +instance Function DatumHash where + {-# INLINEABLE function #-} + function = functionMap coerce DatumHash + + +deriving via DatumHash instance Arbitrary RedeemerHash + +deriving via DatumHash instance CoArbitrary RedeemerHash + +instance Function RedeemerHash where + {-# INLINEABLE function #-} + function = functionMap coerce RedeemerHash + + +-- | BLAKE2b-244 hash. This does not shrink. +deriving via Blake2b244Hash instance Arbitrary ScriptHash + +deriving via Blake2b244Hash instance CoArbitrary ScriptHash + +instance Function ScriptHash where + {-# INLINEABLE function #-} + function = functionMap coerce ScriptHash diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Time.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Time.hs new file mode 100644 index 00000000000..bdfd15c7389 --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Time.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DerivingVia #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module PlutusLedgerApi.Test.Orphans.V1.Time () where + +import Data.Coerce (coerce) +import PlutusLedgerApi.V1.Time (POSIXTime (POSIXTime)) +import Test.QuickCheck (Arbitrary, CoArbitrary, Function (function), functionMap) + +deriving via Integer instance Arbitrary POSIXTime + +deriving via Integer instance CoArbitrary POSIXTime + +instance Function POSIXTime where + {-# INLINEABLE function #-} + function = functionMap coerce POSIXTime diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Tx.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Tx.hs new file mode 100644 index 00000000000..15178033cb6 --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Tx.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE DerivingVia #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module PlutusLedgerApi.Test.Orphans.V1.Tx () where + +import Data.Coerce (coerce) +import PlutusLedgerApi.Test.Orphans.PlutusTx (Blake2b256Hash (Blake2b256Hash)) +import PlutusLedgerApi.Test.Orphans.V1.Address () +import PlutusLedgerApi.Test.Orphans.V1.Value qualified as Value +import PlutusLedgerApi.V1.Address (Address) +import PlutusLedgerApi.V1.Scripts (DatumHash) +import PlutusLedgerApi.V1.Tx (TxId (TxId), TxOut (TxOut), TxOutRef (TxOutRef)) +import PlutusLedgerApi.V1.Value (Value) +import Test.QuickCheck (Arbitrary (arbitrary, shrink), CoArbitrary (coarbitrary), + Function (function), NonNegative (NonNegative), functionMap, getNonNegative) + +-- | BLAKE2b-256 hash (32 bytes) of a transaction ID. +deriving via Blake2b256Hash instance Arbitrary TxId + +deriving via Blake2b256Hash instance CoArbitrary TxId + +instance Function TxId where + {-# INLINEABLE function #-} + function = functionMap coerce TxId + + +instance Arbitrary TxOutRef where + {-# INLINEABLE arbitrary #-} + arbitrary = TxOutRef <$> arbitrary <*> (getNonNegative <$> arbitrary) + + {-# INLINEABLE shrink #-} + shrink (TxOutRef tid ix) = + TxOutRef <$> shrink tid <*> (fmap getNonNegative . shrink . NonNegative $ ix) + +instance CoArbitrary TxOutRef where + {-# INLINEABLE coarbitrary #-} + coarbitrary (TxOutRef tid ix) = + coarbitrary tid . coarbitrary ix + +instance Function TxOutRef where + {-# INLINEABLE function #-} + function = functionMap (\(TxOutRef tid ix) -> (tid, ix)) (uncurry TxOutRef) + + +instance Arbitrary TxOut where + {-# INLINEABLE arbitrary #-} + arbitrary = + TxOut + <$> arbitrary -- address + <*> (Value.getUtxoValue <$> arbitrary) -- value + <*> arbitrary -- maybe datum hash + + {-# INLINEABLE shrink #-} + shrink (TxOut addr val mdh) = do + addr' <- shrink addr + val' <- Value.getUtxoValue <$> shrink (Value.UTxOValue val) + mdh' <- shrink mdh + pure . TxOut addr' val' $ mdh' + +instance CoArbitrary TxOut where + {-# INLINEABLE coarbitrary #-} + coarbitrary (TxOut addr val mdh) = + coarbitrary addr . coarbitrary val . coarbitrary mdh + +instance Function TxOut where + {-# INLINEABLE function #-} + function = functionMap into outOf + where + into :: TxOut -> (Address, Value, Maybe DatumHash) + into (TxOut addr val mdh) = (addr, val, mdh) + outOf :: (Address, Value, Maybe DatumHash) -> TxOut + outOf (addr, val, mdh) = TxOut addr val mdh diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Value.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Value.hs new file mode 100644 index 00000000000..1374ef04833 --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Value.hs @@ -0,0 +1,399 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module PlutusLedgerApi.Test.Orphans.V1.Value ( + -- * Specialized Value wrappers + FeeValue (..), + getFeeValue, + UTxOValue (..), + getUtxoValue, + ZeroAdaValue (..), + getZeroAdaValue, + MintValue (..), + getMintValue, +) where + +import Control.Monad (guard) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.Coerce (coerce) +import Data.Set qualified as Set +import PlutusLedgerApi.Test.Orphans.PlutusTx (getBlake2b244Hash) +import PlutusLedgerApi.V1.Value (AssetClass (AssetClass), CurrencySymbol (CurrencySymbol), + Lovelace (Lovelace), TokenName (TokenName), Value (Value), + adaSymbol, adaToken, getValue, singleton, valueOf) +import PlutusTx.AssocMap qualified as AssocMap +import PlutusTx.Prelude qualified as PlutusTx +import Test.QuickCheck (Arbitrary (arbitrary, shrink), Arbitrary1 (liftArbitrary, liftShrink), + CoArbitrary, Function (function), Gen, NonEmptyList (NonEmpty), + NonZero (NonZero), Positive (Positive), chooseBoundedIntegral, chooseInt, + frequency, functionMap, getNonEmpty, getNonZero, getPositive, resize, scale, + sized, vectorOf) + +deriving via (CurrencySymbol, TokenName) instance Arbitrary AssetClass + +deriving via (CurrencySymbol, TokenName) instance CoArbitrary AssetClass + +instance Function AssetClass where + {-# INLINEABLE function #-} + function = functionMap into outOf + where + into :: AssetClass -> (CurrencySymbol, TokenName) + into = coerce + + outOf :: (CurrencySymbol, TokenName) -> AssetClass + outOf = coerce + + +deriving via Integer instance Arbitrary Lovelace + +deriving via Integer instance CoArbitrary Lovelace + +instance Function Lovelace where + {-# INLINEABLE function #-} + function = functionMap coerce Lovelace + + +{- | A 'CurrencySymbol' is either a BLAKE2b-244 hash or empty (representing the +Ada symbol). In a fully-fair generator, this makes it vanishingly unlikely +that the Ada symbol will be produced naturally (1 in 2^8^28 = 2^244) odds. +QuickCheck doesn't give us the ability to represent these odds faithfully: +thus, we merely make the Ada symbol as unlikely as we can. If you want to +ensure that the Ada symbol is covered by your tests, you need to make +dedicated tests for this. For this reason, we also don't shrink into the Ada +symbol (indeed, we don't shrink at all). +-} +instance Arbitrary CurrencySymbol where + {-# INLINEABLE arbitrary #-} + arbitrary = + CurrencySymbol + <$> frequency + [ (1, pure "") + , (maxBound, getBlake2b244Hash <$> arbitrary) + ] + +deriving via PlutusTx.BuiltinByteString instance CoArbitrary CurrencySymbol + +instance Function CurrencySymbol where + {-# INLINEABLE function #-} + function = functionMap coerce CurrencySymbol + + +{- | A 'Value' suitable for 'TxOut'. Specifically: + +* The `Value` is sorted by both keys (meaning 'CurrencySymbol' and + 'TokenName'); +* There exists an Ada amount; and +* All amounts are positive. + += Note + +This is designed to act as a modifier, and thus, we expose the constructor +even though it preserves invariants. If you use the constructor directly, +be /very/ certain that the Value being wrapped satisfies the invariants +described above: failing to do so means all guarantees of this type are off +the table. +-} +newtype UTxOValue = UTxOValue Value + deriving (Eq) via Value + deriving stock (Show) + +instance Arbitrary UTxOValue where + {-# INLINEABLE arbitrary #-} + arbitrary = + UTxOValue <$> do + Positive adaQuantity <- arbitrary + -- Set of non-Ada currency symbols + csSet <- Set.fromList <$> liftArbitrary (CurrencySymbol . getBlake2b244Hash <$> arbitrary) + let cses = Set.toList csSet + -- For each key, generate a set of token names that aren't Ada, and a + -- positive value + table <- traverse (scale (`quot` 8) . mkInner) cses + -- Jam the Ada value in there + let table' = (adaSymbol, [(adaToken, adaQuantity)]) : table + pure . Value . AssocMap.unsafeFromList . fmap (fmap AssocMap.unsafeFromList) $ table' + where + mkInner :: CurrencySymbol -> Gen (CurrencySymbol, [(TokenName, Integer)]) + mkInner cs = + (cs,) <$> do + -- Set of non-Ada token names + tnSet <- Set.fromList <$> liftArbitrary genNonAdaTokenName + let asList = Set.toList tnSet + traverse (\tn -> (tn,) . getPositive <$> arbitrary) asList + + genNonAdaTokenName :: Gen TokenName + genNonAdaTokenName = + TokenName . PlutusTx.toBuiltin @ByteString . BS.pack <$> do + len <- chooseInt (1, 32) + -- ASCII printable range + vectorOf len . chooseBoundedIntegral $ (33, 126) + + {-# INLINEABLE shrink #-} + shrink (UTxOValue (Value v)) = + UTxOValue . Value <$> do + -- To ensure we don't break anything, we shrink in only two ways: + -- + -- 1. Dropping keys (outer or inner) + -- 2. Shrinking amounts + -- + -- To make this a bit easier on ourselves, we first 'unpack' the Value + -- completely, shrink the resulting (nested) list, then 'repack'. As neither + -- of these changes affect order or uniqueness, we're safe. + let asList = fmap AssocMap.toList <$> AssocMap.toList v + shrunk <- liftShrink + (\(cs, inner) -> + (cs,) <$> liftShrink + (\(tn, amount) -> (tn,) . getPositive <$> shrink (Positive amount)) + inner) asList + pure . AssocMap.unsafeFromList . fmap (fmap AssocMap.unsafeFromList) $ shrunk + +deriving via Value instance CoArbitrary UTxOValue + +instance Function UTxOValue where + {-# INLINEABLE function #-} + function = functionMap coerce UTxOValue + +getUtxoValue :: UTxOValue -> Value +getUtxoValue = coerce + +{- | A 'Value' that contains zero Ada. + += Note + +This is designed to act as a modifier, and thus, we expose the constructor +even though it preserves invariants. If you use the constructor directly, +be /very/ certain that the Value being wrapped satisfies the invariants +described above: failing to do so means all guarantees of this type are off +the table. +-} +newtype ZeroAdaValue = ZeroAdaValue Value + deriving (Eq) via Value + deriving stock (Show) + +instance Arbitrary ZeroAdaValue where + {-# INLINEABLE arbitrary #-} + arbitrary = + ZeroAdaValue <$> do + -- Generate a set of currency symbols that aren't Ada + keySet <- fmap + Set.fromList + (liftArbitrary (CurrencySymbol . getBlake2b244Hash <$> arbitrary)) + let keyList = Set.toList keySet + -- For each key, generate a set of token name keys that aren't Ada + keyVals <- traverse (scale (`quot` 8) . mkInner) keyList + pure + . withZeroAda + . foldMap (\(cs, vals) -> foldMap (uncurry (singleton cs)) vals) + $ keyVals + where + mkInner :: CurrencySymbol -> Gen (CurrencySymbol, [(TokenName, Integer)]) + mkInner cs = + (cs,) + . Set.toList + . Set.fromList + . getNonEmpty <$> liftArbitrary ((,) <$> genNonAdaTokenName <*> arbitrary) + + genNonAdaTokenName :: Gen TokenName + genNonAdaTokenName = + fmap (TokenName . PlutusTx.toBuiltin @ByteString . BS.pack) . sized $ \size -> do + len <- resize size . chooseInt $ (1, 32) + vectorOf len . chooseBoundedIntegral $ (33, 126) + + {-# INLINEABLE shrink #-} + -- Since we can't shrink keys anyway, we just borrow the stock shrinker + shrink (ZeroAdaValue v) = ZeroAdaValue . withZeroAda <$> shrink v + +deriving via Value instance CoArbitrary ZeroAdaValue + +instance Function ZeroAdaValue where + {-# INLINEABLE function #-} + function = functionMap coerce ZeroAdaValue + +getZeroAdaValue :: ZeroAdaValue -> Value +getZeroAdaValue = coerce + + +{- | This is the most general possible instance for 'Value'. In particular, +this can have zero values, and does not treat the Ada symbol or token name +specially. +-} +instance Arbitrary Value where + {-# INLINEABLE arbitrary #-} + arbitrary = Value <$> liftArbitrary (scale (`quot` 4) arbitrary) + {-# INLINEABLE shrink #-} + shrink = fmap Value . shrink . getValue + +deriving via + (AssocMap.Map CurrencySymbol (AssocMap.Map TokenName Integer)) + instance + CoArbitrary Value + +instance Function Value where + {-# INLINEABLE function #-} + function = functionMap coerce Value + + +{- | This instance can generate the Ada token name, with faithful odds. It is +limited to generating printable ASCII names, rather than the full UTF-8 +range. We did this for two reasons: + +1. For testing purposes, we should prioritize readability, hence our choice + of a textual representation; and +2. It is difficult to work within the size limit (32 bytes) when generating + UTF-8. +-} +instance Arbitrary TokenName where + {-# INLINEABLE arbitrary #-} + arbitrary = + fmap (TokenName . PlutusTx.toBuiltin @ByteString . BS.pack) . sized $ \size -> do + -- We want the length to be size-dependent + len <- resize size . chooseInt $ (0, 32) + -- But the bytes themselves should not be: the whole ASCII printable range + -- should be available always + vectorOf len . chooseBoundedIntegral $ (33, 126) + + {-# INLINEABLE shrink #-} + shrink tn = + TokenName . PlutusTx.toBuiltin @ByteString <$> do + let asList = BS.unpack . PlutusTx.fromBuiltin @PlutusTx.BuiltinByteString . coerce $ tn + bs <- BS.pack <$> shrink asList + guard (BS.all (\w8 -> w8 >= 33 && w8 <= 126) bs) + pure bs + +deriving via PlutusTx.BuiltinByteString instance CoArbitrary TokenName + +instance Function TokenName where + {-# INLINEABLE function #-} + function = functionMap coerce TokenName + +-- Helpers + +-- This is frankly a bizarre omission +instance Arbitrary1 NonEmptyList where + {-# INLINEABLE liftArbitrary #-} + liftArbitrary genInner = + NonEmpty <$> do + x <- genInner + xs <- liftArbitrary genInner + pure $ x : xs + + {-# INLINEABLE liftShrink #-} + liftShrink shrinkInner (NonEmpty ell) = + NonEmpty <$> case ell of + [] -> [] + (x : xs) -> (:) <$> shrinkInner x <*> liftShrink shrinkInner xs + +{- | A 'Value' containing only Ada, suitable for fees. Furthermore, the +Ada quantity is positive. + += Note + +This is designed to act as a modifier, and thus, we expose the constructor +even though it preserves invariants. If you use the constructor directly, +be /very/ certain that the Value being wrapped satisfies the invariants +described above: failing to do so means all guarantees of this type are off +the table. +-} +newtype FeeValue = FeeValue Value + deriving (Eq) via Value + deriving stock (Show) + +instance Arbitrary FeeValue where + {-# INLINEABLE arbitrary #-} + arbitrary = FeeValue . singleton adaSymbol adaToken . getPositive <$> arbitrary + + {-# INLINEABLE shrink #-} + shrink (FeeValue v) = + FeeValue . singleton adaSymbol adaToken <$> do + let adaAmount = valueOf v adaSymbol adaToken + Positive adaAmount' <- shrink (Positive adaAmount) + pure adaAmount' + +deriving via Value instance CoArbitrary FeeValue + +instance Function FeeValue where + {-# INLINEABLE function #-} + function = functionMap coerce FeeValue + +getFeeValue :: FeeValue -> Value +getFeeValue = coerce + + +{- | Similar to 'ZeroAdaValue', but also does not have nonzero amounts. + += Note + +This is designed to act as a modifier, and thus, we expose the constructor +even though it preserves invariants. If you use the constructor directly, +be /very/ certain that the Value being wrapped satisfies the invariants +described above: failing to do so means all guarantees of this type are off +the table. +-} +newtype MintValue = MintValue Value + deriving (Eq) via Value + deriving stock (Show) + +instance Arbitrary MintValue where + {-# INLINEABLE arbitrary #-} + arbitrary = + MintValue <$> do + -- Generate a set of currency symbols that aren't Ada + keySet <- fmap + Set.fromList + (liftArbitrary (CurrencySymbol . getBlake2b244Hash <$> arbitrary)) + let keyList = Set.toList keySet + -- For each key, generate a set of token name keys that aren't Ada + keyVals <- traverse (scale (`quot` 8) . mkInner) keyList + pure + . withZeroAda + . foldMap (\(cs, vals) -> foldMap (uncurry (singleton cs)) vals) + $ keyVals + where + mkInner :: CurrencySymbol -> Gen (CurrencySymbol, [(TokenName, Integer)]) + mkInner cs = + (cs,) + . Set.toList + . Set.fromList + . getNonEmpty + <$> liftArbitrary ((,) <$> genNonAdaTokenName <*> (getNonZero <$> arbitrary)) + + genNonAdaTokenName :: Gen TokenName + genNonAdaTokenName = + fmap (TokenName . PlutusTx.toBuiltin @ByteString . BS.pack) . sized $ \size -> do + len <- resize size . chooseInt $ (1, 32) + vectorOf len . chooseBoundedIntegral $ (33, 126) + + {-# INLINEABLE shrink #-} + shrink (MintValue (Value v)) = + MintValue . withZeroAda . Value <$> do + -- To ensure we don't break anything, we shrink in only two ways: + -- + -- 1. Dropping keys (outer or inner) + -- 2. Shrinking amounts + -- + -- To make this a bit easier on ourselves, we first 'unpack' the Value + -- completely, shrink the resulting (nested) list, then 'repack'. As neither + -- of these changes affect order or uniqueness, we're safe. + let asList = fmap AssocMap.toList <$> AssocMap.toList v + shrunk <- liftShrink + (\(cs, inner) -> + (cs,) <$> liftShrink + (\(tn, amount) -> (tn,) . getNonZero <$> shrink (NonZero amount)) + inner) asList + pure . AssocMap.unsafeFromList . fmap (fmap AssocMap.unsafeFromList) $ shrunk + +deriving via Value instance CoArbitrary MintValue + +instance Function MintValue where + {-# INLINEABLE function #-} + function = functionMap coerce MintValue + +getMintValue :: MintValue -> Value +getMintValue = coerce + +withZeroAda :: Value -> Value +withZeroAda = (singleton adaSymbol adaToken 0 <>) From 6029d3167b98d1864b001a5f87819787193e617d Mon Sep 17 00:00:00 2001 From: t4ccer Date: Fri, 1 Nov 2024 10:48:00 -0600 Subject: [PATCH 02/16] Add V2 PlutusLedgerApi QuickCheck instances --- plutus-ledger-api/plutus-ledger-api.cabal | 3 + .../testlib/PlutusLedgerApi/Test/Orphans.hs | 1 + .../PlutusLedgerApi/Test/Orphans/V2.hs | 4 + .../Test/Orphans/V2/Contexts.hs | 132 ++++++++++++++++++ .../PlutusLedgerApi/Test/Orphans/V2/Tx.hs | 92 ++++++++++++ 5 files changed, 232 insertions(+) create mode 100644 plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V2.hs create mode 100644 plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V2/Contexts.hs create mode 100644 plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V2/Tx.hs diff --git a/plutus-ledger-api/plutus-ledger-api.cabal b/plutus-ledger-api/plutus-ledger-api.cabal index 684392e7814..be974f409bf 100644 --- a/plutus-ledger-api/plutus-ledger-api.cabal +++ b/plutus-ledger-api/plutus-ledger-api.cabal @@ -151,6 +151,9 @@ library plutus-ledger-api-testlib PlutusLedgerApi.Test.Orphans.V1.Time PlutusLedgerApi.Test.Orphans.V1.Tx PlutusLedgerApi.Test.Orphans.V1.Value + PlutusLedgerApi.Test.Orphans.V2 + PlutusLedgerApi.Test.Orphans.V2.Contexts + PlutusLedgerApi.Test.Orphans.V2.Tx build-depends: , barbies diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans.hs index 3dd90191d7c..4b54f8a5832 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans.hs @@ -2,3 +2,4 @@ module PlutusLedgerApi.Test.Orphans () where import PlutusLedgerApi.Test.Orphans.PlutusTx () import PlutusLedgerApi.Test.Orphans.V1 () +import PlutusLedgerApi.Test.Orphans.V2 () diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V2.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V2.hs new file mode 100644 index 00000000000..e4bb807c111 --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V2.hs @@ -0,0 +1,4 @@ +module PlutusLedgerApi.Test.Orphans.V2 () where + +import PlutusLedgerApi.Test.Orphans.V2.Contexts () +import PlutusLedgerApi.Test.Orphans.V2.Tx () diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V2/Contexts.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V2/Contexts.hs new file mode 100644 index 00000000000..a55cd4cde90 --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V2/Contexts.hs @@ -0,0 +1,132 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module PlutusLedgerApi.Test.Orphans.V2.Contexts () where + +import Data.Set qualified as Set +import PlutusLedgerApi.Test.Orphans.V1.Contexts () +import PlutusLedgerApi.Test.Orphans.V1.Value qualified as Value +import PlutusLedgerApi.Test.Orphans.V2.Tx () +import PlutusLedgerApi.V1.Credential (StakingCredential) +import PlutusLedgerApi.V1.Crypto (PubKeyHash) +import PlutusLedgerApi.V1.DCert (DCert) +import PlutusLedgerApi.V1.Scripts (Datum, DatumHash, Redeemer) +import PlutusLedgerApi.V1.Time (POSIXTimeRange) +import PlutusLedgerApi.V1.Tx (TxId) +import PlutusLedgerApi.V1.Value (Value) +import PlutusLedgerApi.V2.Contexts (ScriptPurpose, TxInInfo (TxInInfo), TxInfo (TxInfo)) +import PlutusLedgerApi.V2.Tx (TxOut) +import PlutusTx.AssocMap (Map) +import Test.QuickCheck (Arbitrary (arbitrary, shrink), CoArbitrary (coarbitrary), + Function (function), NonEmptyList (NonEmpty), functionMap, getNonEmpty) + +instance Arbitrary TxInInfo where + {-# INLINEABLE arbitrary #-} + arbitrary = TxInInfo <$> arbitrary <*> arbitrary + + {-# INLINEABLE shrink #-} + shrink (TxInInfo outref resolved) = + TxInInfo <$> shrink outref <*> shrink resolved + +instance CoArbitrary TxInInfo where + {-# INLINEABLE coarbitrary #-} + coarbitrary (TxInInfo outref resolved) = + coarbitrary outref . coarbitrary resolved + +instance Function TxInInfo where + {-# INLINEABLE function #-} + function = + functionMap + (\(TxInInfo outref resolved) -> (outref, resolved)) + (uncurry TxInInfo) + + +instance Arbitrary TxInfo where + {-# INLINEABLE arbitrary #-} + arbitrary = + TxInfo . getNonEmpty + <$> arbitrary -- inputs + <*> arbitrary -- reference inputs + <*> (getNonEmpty <$> arbitrary) -- outputs + <*> (Value.getFeeValue <$> arbitrary) -- fee + <*> (Value.getMintValue <$> arbitrary) -- mint + <*> arbitrary -- dcert + <*> arbitrary -- withdrawals + <*> arbitrary -- valid range + <*> (Set.toList <$> arbitrary) -- signatures + <*> arbitrary -- redeemers + <*> arbitrary -- datums + <*> arbitrary -- tid + + {-# INLINEABLE shrink #-} + shrink (TxInfo ins routs outs fee mint dcert wdrl validRange sigs reds dats tid) = do + NonEmpty ins' <- shrink (NonEmpty ins) + routs' <- shrink routs + NonEmpty outs' <- shrink (NonEmpty outs) + Value.FeeValue fee' <- shrink (Value.FeeValue fee) + Value.ZeroAdaValue mint' <- shrink (Value.ZeroAdaValue mint) + dcert' <- shrink dcert + wdrl' <- shrink wdrl + validRange' <- shrink validRange + sigs' <- Set.toList <$> shrink (Set.fromList sigs) + reds' <- shrink reds + dats' <- shrink dats + tid' <- shrink tid + pure . TxInfo ins' routs' outs' fee' mint' dcert' wdrl' validRange' sigs' reds' dats' $ tid' + +instance CoArbitrary TxInfo where + {-# INLINEABLE coarbitrary #-} + coarbitrary (TxInfo ins routs outs fee mint dcert wdrl validRange sigs reds dats tid) = + coarbitrary ins + . coarbitrary routs + . coarbitrary outs + . coarbitrary fee + . coarbitrary mint + . coarbitrary dcert + . coarbitrary wdrl + . coarbitrary validRange + . coarbitrary sigs + . coarbitrary reds + . coarbitrary dats + . coarbitrary tid + +instance Function TxInfo where + {-# INLINEABLE function #-} + function = functionMap into outOf + where + into :: + TxInfo -> + ([TxInInfo] + , [TxInInfo] + , [TxOut] + , Value + , Value + , ([DCert] + , Map StakingCredential Integer + , POSIXTimeRange + , [PubKeyHash] + , Map ScriptPurpose Redeemer + , Map DatumHash Datum + , TxId + ) + ) + into (TxInfo ins routs outs fee mint dcert wdrl validRange sigs reds dats tid) = + (ins, routs, outs, fee, mint, (dcert, wdrl, validRange, sigs, reds, dats, tid)) + + outOf :: + ([TxInInfo] + , [TxInInfo] + , [TxOut] + , Value + , Value + , ([DCert] + , Map StakingCredential Integer + , POSIXTimeRange + , [PubKeyHash] + , Map ScriptPurpose Redeemer + , Map DatumHash Datum + , TxId + ) + ) -> + TxInfo + outOf (ins, routs, outs, fee, mint, (dcert, wdrl, validRange, sigs, reds, dats, tid)) = + TxInfo ins routs outs fee mint dcert wdrl validRange sigs reds dats tid diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V2/Tx.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V2/Tx.hs new file mode 100644 index 00000000000..bf8490d869b --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V2/Tx.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE LambdaCase #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module PlutusLedgerApi.Test.Orphans.V2.Tx () where + +import PlutusLedgerApi.Test.Orphans.V1.Address () +import PlutusLedgerApi.Test.Orphans.V1.Scripts () +import PlutusLedgerApi.Test.Orphans.V1.Value qualified as Value +import PlutusLedgerApi.V1.Address (Address) +import PlutusLedgerApi.V1.Scripts (Datum, DatumHash, ScriptHash) +import PlutusLedgerApi.V1.Value (Value) +import PlutusLedgerApi.V2.Tx (OutputDatum (NoOutputDatum, OutputDatum, OutputDatumHash), + TxOut (TxOut)) +import Test.QuickCheck (Arbitrary (arbitrary, shrink), CoArbitrary (coarbitrary), + Function (function), functionMap, oneof, variant) + +instance Arbitrary OutputDatum where + {-# INLINEABLE arbitrary #-} + arbitrary = + oneof + [ pure NoOutputDatum + , OutputDatumHash <$> arbitrary + , OutputDatum <$> arbitrary + ] + + {-# INLINEABLE shrink #-} + -- We only shrink the OutputDatum case, since the others wouldn't shrink + -- anyway. + shrink = \case + OutputDatum d -> OutputDatum <$> shrink d + _ -> [] + +instance CoArbitrary OutputDatum where + {-# INLINEABLE coarbitrary #-} + coarbitrary = \case + NoOutputDatum -> variant (0 :: Int) + OutputDatumHash dh -> variant (1 :: Int) . coarbitrary dh + OutputDatum d -> variant (2 :: Int) . coarbitrary d + +instance Function OutputDatum where + {-# INLINEABLE function #-} + function = functionMap into outOf + where + into :: OutputDatum -> Maybe (Either DatumHash Datum) + into = \case + NoOutputDatum -> Nothing + OutputDatumHash dh -> Just (Left dh) + OutputDatum d -> Just (Right d) + + outOf :: Maybe (Either DatumHash Datum) -> OutputDatum + outOf = \case + Nothing -> NoOutputDatum + Just (Left dh) -> OutputDatumHash dh + Just (Right d) -> OutputDatum d + + +instance Arbitrary TxOut where + {-# INLINEABLE arbitrary #-} + arbitrary = + TxOut + <$> arbitrary + <*> (Value.getUtxoValue <$> arbitrary) + <*> arbitrary + <*> arbitrary + + {-# INLINEABLE shrink #-} + shrink (TxOut addr val od msh) = + TxOut + <$> shrink addr + <*> (Value.getUtxoValue <$> shrink (Value.UTxOValue val)) + <*> shrink od + <*> shrink msh + +instance CoArbitrary TxOut where + {-# INLINEABLE coarbitrary #-} + coarbitrary (TxOut addr val od msh) = + coarbitrary addr . coarbitrary val . coarbitrary od . coarbitrary msh + +instance Function TxOut where + {-# INLINEABLE function #-} + function = functionMap into outOf + where + into :: + TxOut -> + (Address, Value, OutputDatum, Maybe ScriptHash) + into (TxOut addr val od msh) = (addr, val, od, msh) + + outOf :: + (Address, Value, OutputDatum, Maybe ScriptHash) -> + TxOut + outOf (addr, val, od, msh) = TxOut addr val od msh From 4bda6e1f342edebcb3da6f0d31d8a34d2291fcc4 Mon Sep 17 00:00:00 2001 From: t4ccer Date: Fri, 1 Nov 2024 11:14:02 -0600 Subject: [PATCH 03/16] Add V3 PlutusLedgerApi QuickCheck instances --- plutus-ledger-api/plutus-ledger-api.cabal | 4 + .../testlib/PlutusLedgerApi/Test/Orphans.hs | 1 + .../PlutusLedgerApi/Test/Orphans/V3.hs | 5 + .../Test/Orphans/V3/Contexts.hs | 1061 +++++++++++++++++ .../Test/Orphans/V3/MintValue.hs | 77 ++ .../PlutusLedgerApi/Test/Orphans/V3/Tx.hs | 37 + 6 files changed, 1185 insertions(+) create mode 100644 plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V3.hs create mode 100644 plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V3/Contexts.hs create mode 100644 plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V3/MintValue.hs create mode 100644 plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V3/Tx.hs diff --git a/plutus-ledger-api/plutus-ledger-api.cabal b/plutus-ledger-api/plutus-ledger-api.cabal index be974f409bf..6fa438a7c2b 100644 --- a/plutus-ledger-api/plutus-ledger-api.cabal +++ b/plutus-ledger-api/plutus-ledger-api.cabal @@ -154,6 +154,10 @@ library plutus-ledger-api-testlib PlutusLedgerApi.Test.Orphans.V2 PlutusLedgerApi.Test.Orphans.V2.Contexts PlutusLedgerApi.Test.Orphans.V2.Tx + PlutusLedgerApi.Test.Orphans.V3 + PlutusLedgerApi.Test.Orphans.V3.Contexts + PlutusLedgerApi.Test.Orphans.V3.MintValue + PlutusLedgerApi.Test.Orphans.V3.Tx build-depends: , barbies diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans.hs index 4b54f8a5832..944cf44bdc1 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans.hs @@ -3,3 +3,4 @@ module PlutusLedgerApi.Test.Orphans () where import PlutusLedgerApi.Test.Orphans.PlutusTx () import PlutusLedgerApi.Test.Orphans.V1 () import PlutusLedgerApi.Test.Orphans.V2 () +import PlutusLedgerApi.Test.Orphans.V3 () diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V3.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V3.hs new file mode 100644 index 00000000000..daa5287e0bf --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V3.hs @@ -0,0 +1,5 @@ +module PlutusLedgerApi.Test.Orphans.V3 () where + +import PlutusLedgerApi.Test.Orphans.V3.Contexts () +import PlutusLedgerApi.Test.Orphans.V3.MintValue () +import PlutusLedgerApi.Test.Orphans.V3.Tx () diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V3/Contexts.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V3/Contexts.hs new file mode 100644 index 00000000000..00090ebc01f --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V3/Contexts.hs @@ -0,0 +1,1061 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} + +module PlutusLedgerApi.Test.Orphans.V3.Contexts () where + +import Control.Monad (guard) +import Data.Coerce (coerce) +import Data.Set qualified as Set +import PlutusLedgerApi.Test.Orphans.PlutusTx (Blake2b256Hash (Blake2b256Hash)) +import PlutusLedgerApi.Test.Orphans.V1.Interval () +import PlutusLedgerApi.Test.Orphans.V2.Tx () +import PlutusLedgerApi.Test.Orphans.V3.MintValue () +import PlutusLedgerApi.V1.Credential (Credential) +import PlutusLedgerApi.V1.Crypto (PubKeyHash) +import PlutusLedgerApi.V1.Scripts (Datum, DatumHash, Redeemer, ScriptHash) +import PlutusLedgerApi.V1.Time (POSIXTimeRange) +import PlutusLedgerApi.V1.Value (CurrencySymbol, Lovelace) +import PlutusLedgerApi.V2.Tx (TxOut) +import PlutusLedgerApi.V3.Contexts (ChangedParameters (ChangedParameters), + ColdCommitteeCredential (ColdCommitteeCredential), + Committee (Committee), Constitution (Constitution), + DRep (DRep, DRepAlwaysAbstain, DRepAlwaysNoConfidence), + DRepCredential (DRepCredential), + Delegatee (DelegStake, DelegStakeVote, DelegVote), + GovernanceAction (..), GovernanceActionId (GovernanceActionId), + HotCommitteeCredential (HotCommitteeCredential), + ProposalProcedure (ProposalProcedure), + ProtocolVersion (ProtocolVersion), + ScriptContext (ScriptContext), ScriptInfo (..), + ScriptPurpose (..), TxCert (..), TxInInfo (TxInInfo), + TxInfo (TxInfo), Vote (Abstain, VoteNo, VoteYes), + Voter (CommitteeVoter, DRepVoter, StakePoolVoter)) +import PlutusLedgerApi.V3.MintValue (MintValue) +import PlutusLedgerApi.V3.Tx (TxId (TxId), TxOutRef (TxOutRef)) +import PlutusTx.AssocMap (Map) +import PlutusTx.AssocMap qualified as AssocMap +import PlutusTx.Builtins qualified as Builtins +import PlutusTx.Prelude qualified as PlutusTx +import PlutusTx.Ratio qualified as Ratio +import Test.QuickCheck (Arbitrary (arbitrary, shrink), Arbitrary1 (liftArbitrary, liftShrink), + CoArbitrary (coarbitrary), Function (function), NonEmptyList (NonEmpty), + NonNegative (NonNegative), Positive (Positive), chooseInt, elements, + functionMap, getNonEmpty, getNonNegative, getPositive, oneof, variant) +import Test.QuickCheck.Instances.Containers () + +deriving via Credential instance Arbitrary ColdCommitteeCredential + +deriving via Credential instance CoArbitrary ColdCommitteeCredential + +instance Function ColdCommitteeCredential where + {-# INLINEABLE function #-} + function = functionMap coerce ColdCommitteeCredential + + +deriving via Credential instance Arbitrary HotCommitteeCredential + +deriving via Credential instance CoArbitrary HotCommitteeCredential + +instance Function HotCommitteeCredential where + {-# INLINEABLE function #-} + function = functionMap coerce HotCommitteeCredential + + +deriving via Credential instance Arbitrary DRepCredential + +deriving via Credential instance CoArbitrary DRepCredential + +instance Function DRepCredential where + {-# INLINEABLE function #-} + function = functionMap coerce DRepCredential + + +{- | This instance has equal chance of generating always-abstain, +always-no-confidence and credential \'arms\'. Use this instance with this in +mind. +-} +instance Arbitrary DRep where + {-# INLINEABLE arbitrary #-} + arbitrary = + oneof + [ DRep <$> arbitrary + , pure DRepAlwaysAbstain + , pure DRepAlwaysNoConfidence + ] + + {-# INLINEABLE shrink #-} + shrink = \case + DRep cred -> DRep <$> shrink cred + _ -> [] + +instance CoArbitrary DRep where + {-# INLINEABLE coarbitrary #-} + coarbitrary = \case + DRep cred -> variant (0 :: Int) . coarbitrary cred + DRepAlwaysAbstain -> variant (1 :: Int) + DRepAlwaysNoConfidence -> variant (2 :: Int) + +instance Function DRep where + {-# INLINEABLE function #-} + function = functionMap into outOf + where + into :: DRep -> Maybe (Maybe DRepCredential) + into = \case + DRep cred -> Just (Just cred) + DRepAlwaysAbstain -> Nothing + DRepAlwaysNoConfidence -> Just Nothing + + outOf :: Maybe (Maybe DRepCredential) -> DRep + outOf = \case + Nothing -> DRepAlwaysAbstain + Just Nothing -> DRepAlwaysNoConfidence + Just (Just cred) -> DRep cred + + +instance Arbitrary Delegatee where + {-# INLINEABLE arbitrary #-} + arbitrary = + oneof + [ DelegStake <$> arbitrary + , DelegVote <$> arbitrary + , DelegStakeVote <$> arbitrary <*> arbitrary + ] + + {-# INLINEABLE shrink #-} + shrink = \case + DelegStake _ -> [] -- PubKeyHashes don't shrink anyway + DelegVote drep -> DelegVote <$> shrink drep + DelegStakeVote pkh drep -> DelegStakeVote pkh <$> shrink drep + +instance CoArbitrary Delegatee where + {-# INLINEABLE coarbitrary #-} + coarbitrary = \case + DelegStake pkh -> variant (0 :: Int) . coarbitrary pkh + DelegVote drep -> variant (1 :: Int) . coarbitrary drep + DelegStakeVote pkh drep -> variant (2 :: Int) . coarbitrary pkh . coarbitrary drep + +instance Function Delegatee where + {-# INLINEABLE function #-} + function = functionMap into outOf + where + into :: + Delegatee -> + Either PubKeyHash (Either DRep (PubKeyHash, DRep)) + into = \case + DelegStake pkh -> Left pkh + DelegVote drep -> Right (Left drep) + DelegStakeVote pkh drep -> Right (Right (pkh, drep)) + + outOf :: + Either PubKeyHash (Either DRep (PubKeyHash, DRep)) -> + Delegatee + outOf = \case + Left pkh -> DelegStake pkh + Right (Left drep) -> DelegVote drep + Right (Right (pkh, drep)) -> DelegStakeVote pkh drep + + +instance Arbitrary TxCert where + {-# INLINEABLE arbitrary #-} + arbitrary = + oneof + [ TxCertRegStaking <$> arbitrary <*> arbitrary + , TxCertUnRegStaking <$> arbitrary <*> arbitrary + , TxCertDelegStaking <$> arbitrary <*> arbitrary + , TxCertRegDeleg <$> arbitrary <*> arbitrary <*> arbitrary + , TxCertRegDRep <$> arbitrary <*> arbitrary + , TxCertUpdateDRep <$> arbitrary + , TxCertUnRegDRep <$> arbitrary <*> arbitrary + , TxCertPoolRegister <$> arbitrary <*> arbitrary + , -- epoch must be positive for this to make any sense + TxCertPoolRetire <$> arbitrary <*> (getPositive <$> arbitrary) + , TxCertAuthHotCommittee <$> arbitrary <*> arbitrary + , TxCertResignColdCommittee <$> arbitrary + ] + + {-# INLINEABLE shrink #-} + shrink = \case + TxCertRegStaking cred mLovelace -> + TxCertRegStaking <$> shrink cred <*> shrink mLovelace + TxCertUnRegStaking cred mLovelace -> + TxCertUnRegStaking <$> shrink cred <*> shrink mLovelace + TxCertDelegStaking cred deleg -> + TxCertDelegStaking <$> shrink cred <*> shrink deleg + TxCertRegDeleg cred deleg lovelace -> + TxCertRegDeleg <$> shrink cred <*> shrink deleg <*> shrink lovelace + TxCertRegDRep drepCred lovelace -> + TxCertRegDRep <$> shrink drepCred <*> shrink lovelace + TxCertUpdateDRep drepCred -> TxCertUpdateDRep <$> shrink drepCred + TxCertUnRegDRep drepCred lovelace -> + TxCertUnRegDRep <$> shrink drepCred <*> shrink lovelace + -- PubKeyHash doesn't shrink, so we don't bother either + TxCertPoolRegister _ _ -> [] + TxCertPoolRetire pkh epoch -> + TxCertPoolRetire pkh . getPositive <$> shrink (Positive epoch) + TxCertAuthHotCommittee cold hot -> + TxCertAuthHotCommittee <$> shrink cold <*> shrink hot + TxCertResignColdCommittee cold -> TxCertResignColdCommittee <$> shrink cold + +instance CoArbitrary TxCert where + {-# INLINEABLE coarbitrary #-} + coarbitrary = \case + TxCertRegStaking cred mLovelace -> + variant (0 :: Int) . coarbitrary cred . coarbitrary mLovelace + TxCertUnRegStaking cred mLovelace -> + variant (1 :: Int) . coarbitrary cred . coarbitrary mLovelace + TxCertDelegStaking cred deleg -> + variant (2 :: Int) . coarbitrary cred . coarbitrary deleg + TxCertRegDeleg cred deleg lovelace -> + variant (3 :: Int) . coarbitrary cred . coarbitrary deleg . coarbitrary lovelace + TxCertRegDRep drepCred lovelace -> + variant (4 :: Int) . coarbitrary drepCred . coarbitrary lovelace + TxCertUpdateDRep drepCred -> + variant (5 :: Int) . coarbitrary drepCred + TxCertUnRegDRep drepCred lovelace -> + variant (6 :: Int) . coarbitrary drepCred . coarbitrary lovelace + TxCertPoolRegister pkh pkh' -> + variant (7 :: Int) . coarbitrary pkh . coarbitrary pkh' + TxCertPoolRetire pkh epoch -> + variant (8 :: Int) . coarbitrary pkh . coarbitrary epoch + TxCertAuthHotCommittee cold hot -> + variant (9 :: Int) . coarbitrary cold . coarbitrary hot + TxCertResignColdCommittee cold -> + variant (10 :: Int) . coarbitrary cold + +instance Function TxCert where + {-# INLINEABLE function #-} + function = functionMap into outOf + where + into :: + TxCert -> + Either + (Credential, Maybe Lovelace) + ( Either + (Credential, Maybe Lovelace) + ( Either + (Credential, Delegatee) + ( Either + (Credential, Delegatee, Lovelace) + ( Either + (DRepCredential, Lovelace) + ( Either + DRepCredential + ( Either + (DRepCredential, Lovelace) + ( Either + (PubKeyHash, PubKeyHash) + ( Either + (PubKeyHash, Integer) + ( Either (ColdCommitteeCredential, HotCommitteeCredential) + ColdCommitteeCredential + ) + ) + ) + ) + ) + ) + ) + ) + ) + into = \case + TxCertRegStaking cred mLovelace -> + Left (cred, mLovelace) + TxCertUnRegStaking cred mLovelace -> + Right (Left (cred, mLovelace)) + TxCertDelegStaking cred deleg -> + Right (Right (Left (cred, deleg))) + TxCertRegDeleg cred deleg lovelace -> + Right (Right (Right (Left (cred, deleg, lovelace)))) + TxCertRegDRep drepCred lovelace -> + Right (Right (Right (Right (Left (drepCred, lovelace))))) + TxCertUpdateDRep drepCred -> + Right (Right (Right (Right (Right (Left drepCred))))) + TxCertUnRegDRep drepCred lovelace -> + Right (Right (Right (Right (Right (Right (Left (drepCred, lovelace))))))) + TxCertPoolRegister pkh pkh' -> + Right (Right (Right (Right (Right (Right (Right (Left (pkh, pkh')))))))) + TxCertPoolRetire pkh epoch -> + Right (Right (Right (Right (Right (Right (Right (Right (Left (pkh, epoch))))))))) + TxCertAuthHotCommittee hot cold -> + Right (Right (Right (Right (Right (Right (Right (Right (Right (Left (hot, cold)))))))))) + TxCertResignColdCommittee cold -> + Right (Right (Right (Right (Right (Right (Right (Right (Right (Right cold))))))))) + + outOf :: + Either + (Credential, Maybe Lovelace) + ( Either + (Credential, Maybe Lovelace) + ( Either + (Credential, Delegatee) + ( Either + (Credential, Delegatee, Lovelace) + ( Either + (DRepCredential, Lovelace) + ( Either + DRepCredential + ( Either + (DRepCredential, Lovelace) + ( Either + (PubKeyHash, PubKeyHash) + ( Either + (PubKeyHash, Integer) + ( Either (ColdCommitteeCredential, HotCommitteeCredential) + ColdCommitteeCredential + ) + ) + ) + ) + ) + ) + ) + ) + ) -> + TxCert + outOf = \case + Left (cred, mLovelace) -> + TxCertRegStaking cred mLovelace + Right (Left (cred, mLovelace)) -> + TxCertUnRegStaking cred mLovelace + Right (Right (Left (cred, deleg))) -> + TxCertDelegStaking cred deleg + Right (Right (Right (Left (cred, deleg, lovelace)))) -> + TxCertRegDeleg cred deleg lovelace + Right (Right (Right (Right (Left (drepCred, lovelace))))) -> + TxCertRegDRep drepCred lovelace + Right (Right (Right (Right (Right (Left drepCred))))) -> + TxCertUpdateDRep drepCred + Right (Right (Right (Right (Right (Right (Left (drepCred, lovelace))))))) -> + TxCertUnRegDRep drepCred lovelace + Right (Right (Right (Right (Right (Right (Right (Left (pkh, pkh')))))))) -> + TxCertPoolRegister pkh pkh' + Right (Right (Right (Right (Right (Right (Right (Right (Left (pkh, epoch))))))))) -> + TxCertPoolRetire pkh epoch + Right (Right (Right (Right (Right (Right (Right (Right (Right (Left (hot, cold)))))))))) -> + TxCertAuthHotCommittee hot cold + Right (Right (Right (Right (Right (Right (Right (Right (Right (Right cold))))))))) -> + TxCertResignColdCommittee cold + + +instance Arbitrary Voter where + {-# INLINEABLE arbitrary #-} + arbitrary = + oneof + [ CommitteeVoter <$> arbitrary + , DRepVoter <$> arbitrary + , StakePoolVoter <$> arbitrary + ] + + {-# INLINEABLE shrink #-} + shrink = \case + CommitteeVoter hcc -> CommitteeVoter <$> shrink hcc + DRepVoter drepCred -> DRepVoter <$> shrink drepCred + -- PubKeyHashes don't shrink so we don't bother either + _ -> [] + +instance CoArbitrary Voter where + {-# INLINEABLE coarbitrary #-} + coarbitrary = \case + CommitteeVoter hcc -> variant (0 :: Int) . coarbitrary hcc + DRepVoter drepCred -> variant (1 :: Int) . coarbitrary drepCred + StakePoolVoter pkh -> variant (2 :: Int) . coarbitrary pkh + +instance Function Voter where + {-# INLINEABLE function #-} + function = functionMap into outOf + where + into :: + Voter -> + Either HotCommitteeCredential (Either DRepCredential PubKeyHash) + into = \case + CommitteeVoter hcc -> Left hcc + DRepVoter drepCred -> Right (Left drepCred) + StakePoolVoter pkh -> Right (Right pkh) + + outOf :: + Either HotCommitteeCredential (Either DRepCredential PubKeyHash) -> + Voter + outOf = \case + Left hcc -> CommitteeVoter hcc + Right (Left drepCred) -> DRepVoter drepCred + Right (Right pkh) -> StakePoolVoter pkh + + +-- | Does not shrink (as there's not much point). +instance Arbitrary Vote where + {-# INLINEABLE arbitrary #-} + arbitrary = elements [VoteNo, VoteYes, Abstain] + +instance CoArbitrary Vote where + {-# INLINEABLE coarbitrary #-} + coarbitrary = \case + VoteNo -> variant (0 :: Int) + VoteYes -> variant (1 :: Int) + Abstain -> variant (2 :: Int) + +instance Function Vote where + {-# INLINEABLE function #-} + function = functionMap into outOf + where + into :: Vote -> Int + into = \case + VoteNo -> 0 + VoteYes -> 1 + _ -> 2 + + outOf :: Int -> Vote + outOf = \case + 0 -> VoteNo + 1 -> VoteYes + _ -> Abstain + + +deriving via Blake2b256Hash instance Arbitrary TxId + +deriving via Blake2b256Hash instance CoArbitrary TxId + +instance Function TxId where + {-# INLINEABLE function #-} + function = functionMap coerce TxId + + +instance Arbitrary GovernanceActionId where + {-# INLINEABLE arbitrary #-} + arbitrary = + GovernanceActionId + <$> arbitrary + <*> (getNonNegative <$> arbitrary) + {-# INLINEABLE shrink #-} + shrink (GovernanceActionId tid ix) = + -- Hashes don't shrink, so we don't bother either + GovernanceActionId tid . getNonNegative <$> shrink (NonNegative ix) + +instance CoArbitrary GovernanceActionId where + {-# INLINEABLE coarbitrary #-} + coarbitrary (GovernanceActionId tid ix) = + coarbitrary tid . coarbitrary ix + +instance Function GovernanceActionId where + {-# INLINEABLE function #-} + function = functionMap (\(GovernanceActionId tid ix) -> (tid, ix)) (uncurry GovernanceActionId) + + +{- | Does not shrink the quorum, as this is surprisingly hard to do sensibly. We +assume the quorum is in the interval @(0, 1]@ (meaning anywhere from a single +voice to unanimity). +-} +instance Arbitrary Committee where + {-# INLINEABLE arbitrary #-} + arbitrary = do + committee <- liftArbitrary (getPositive <$> arbitrary) + -- We can't have a quorum of 0.0 + num <- chooseInt (1, 100) + let quorum = Ratio.unsafeRatio (fromIntegral num) 100 + pure . Committee committee $ quorum + {-# INLINEABLE shrink #-} + shrink (Committee committee quorum) = do + committee' <- liftShrink (fmap getPositive . shrink . Positive) committee + guard (not . AssocMap.null $ committee') + pure . Committee committee' $ quorum + +instance CoArbitrary Committee where + {-# INLINEABLE coarbitrary #-} + coarbitrary (Committee committee quorum) = + coarbitrary committee + . coarbitrary (Ratio.numerator quorum) + . coarbitrary (Ratio.denominator quorum) + +instance Function Committee where + {-# INLINEABLE function #-} + function = functionMap into outOf + where + into :: + Committee -> + (Map ColdCommitteeCredential Integer, Integer, Integer) + into (Committee committee quorum) = + (committee, Ratio.numerator quorum, Ratio.denominator quorum) + outOf :: + (Map ColdCommitteeCredential Integer, Integer, Integer) -> + Committee + outOf (committee, num, den) = + Committee committee . Ratio.unsafeRatio num $ den + + +deriving via (Maybe ScriptHash) instance Arbitrary Constitution + +deriving via (Maybe ScriptHash) instance CoArbitrary Constitution + +instance Function Constitution where + {-# INLINEABLE function #-} + function = functionMap coerce Constitution + + +instance Arbitrary ProtocolVersion where + {-# INLINEABLE arbitrary #-} + arbitrary = do + NonNegative major <- arbitrary + NonNegative minor <- arbitrary + pure . ProtocolVersion major $ minor + {-# INLINEABLE shrink #-} + shrink (ProtocolVersion major minor) = do + NonNegative major' <- shrink (NonNegative major) + NonNegative minor' <- shrink (NonNegative minor) + pure . ProtocolVersion major' $ minor' + +instance CoArbitrary ProtocolVersion where + {-# INLINEABLE coarbitrary #-} + coarbitrary (ProtocolVersion major minor) = + coarbitrary major . coarbitrary minor + +instance Function ProtocolVersion where + {-# INLINEABLE function #-} + function = + functionMap + (\(ProtocolVersion maj' min') -> (maj', min')) + (uncurry ProtocolVersion) + +{- | Currently only generates a map with integer keys in the range 0-33, with random values. +Does not shrink. +-} +instance Arbitrary ChangedParameters where + {-# INLINEABLE arbitrary #-} + arbitrary = + ChangedParameters . Builtins.mkMap <$> do + keyList <- liftArbitrary (chooseInt (0, 33)) + let keySet = Set.fromList keyList + traverse (\k -> (Builtins.mkI . fromIntegral $ k,) <$> arbitrary) . Set.toList $ keySet + +deriving via PlutusTx.BuiltinData instance CoArbitrary ChangedParameters + +instance Function ChangedParameters where + {-# INLINEABLE function #-} + function = functionMap coerce ChangedParameters + + +-- TODO: Technically this can generate nonsensical instances (such as committee +-- members without keys), and we need to fix this. + +instance Arbitrary GovernanceAction where + {-# INLINEABLE arbitrary #-} + arbitrary = + oneof + [ ParameterChange <$> arbitrary <*> arbitrary <*> arbitrary + , HardForkInitiation <$> arbitrary <*> arbitrary + , TreasuryWithdrawals <$> arbitrary <*> arbitrary + , NoConfidence <$> arbitrary + , UpdateCommittee + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> (Ratio.unsafeRatio . fromIntegral <$> chooseInt (1, 100) <*> pure 100) + , NewConstitution <$> arbitrary <*> arbitrary + , pure InfoAction + ] + + {-# INLINEABLE shrink #-} + shrink = \case + ParameterChange mgid cp msh -> + ParameterChange + <$> shrink mgid + <*> shrink cp + <*> shrink msh + HardForkInitiation mgid v -> + HardForkInitiation + <$> shrink mgid + <*> shrink v + TreasuryWithdrawals wdrls msh -> + TreasuryWithdrawals + <$> shrink wdrls + <*> shrink msh + NoConfidence msh -> NoConfidence <$> shrink msh + -- No quorum shrinking + UpdateCommittee mgid creds mems quorum -> do + mgid' <- shrink mgid + creds' <- shrink creds + mems' <- shrink mems + pure . UpdateCommittee mgid' creds' mems' $ quorum + NewConstitution mgid c -> NewConstitution <$> shrink mgid <*> shrink c + _ -> [] + +instance CoArbitrary GovernanceAction where + {-# INLINEABLE coarbitrary #-} + coarbitrary = \case + ParameterChange mgid cp msh -> + variant (0 :: Int) . coarbitrary mgid . coarbitrary cp . coarbitrary msh + HardForkInitiation mgid v -> + variant (1 :: Int) . coarbitrary mgid . coarbitrary v + TreasuryWithdrawals wdrls msh -> + variant (2 :: Int) . coarbitrary wdrls . coarbitrary msh + NoConfidence msh -> + variant (3 :: Int) . coarbitrary msh + UpdateCommittee mgid creds mems quorum -> + variant (4 :: Int) + . coarbitrary mgid + . coarbitrary creds + . coarbitrary mems + . coarbitrary (Ratio.numerator quorum) + . coarbitrary (Ratio.denominator quorum) + NewConstitution mgid c -> + variant (5 :: Int) . coarbitrary mgid . coarbitrary c + InfoAction -> variant (6 :: Int) + +instance Function GovernanceAction where + {-# INLINEABLE function #-} + function = functionMap into outOf + where + into :: + GovernanceAction -> + Maybe + ( Either + (Maybe GovernanceActionId, ChangedParameters, Maybe ScriptHash) + ( Either + (Maybe GovernanceActionId, ProtocolVersion) + ( Either + (Map Credential Lovelace, Maybe ScriptHash) + ( Either + (Maybe GovernanceActionId) + ( Either + (Maybe GovernanceActionId, [ColdCommitteeCredential] + , Map ColdCommitteeCredential Integer, Integer, Integer) + (Maybe GovernanceActionId, Constitution) + ) + ) + ) + ) + ) + into = \case + InfoAction -> Nothing + ParameterChange mgid cp msh -> Just (Left (mgid, cp, msh)) + HardForkInitiation mgid v -> Just (Right (Left (mgid, v))) + TreasuryWithdrawals wdrls msh -> Just (Right (Right (Left (wdrls, msh)))) + NoConfidence msh -> Just (Right (Right (Right (Left msh)))) + UpdateCommittee mgid creds mems quorum -> + Just (Right (Right (Right (Right (Left ( mgid + , creds + , mems + , Ratio.numerator quorum + , Ratio.denominator quorum)))))) + NewConstitution mgid c -> + Just (Right (Right (Right (Right (Right (mgid, c)))))) + + outOf :: + Maybe + ( Either + (Maybe GovernanceActionId, ChangedParameters, Maybe ScriptHash) + ( Either + (Maybe GovernanceActionId, ProtocolVersion) + ( Either + (Map Credential Lovelace, Maybe ScriptHash) + ( Either + (Maybe GovernanceActionId) + ( Either + ( Maybe GovernanceActionId + , [ColdCommitteeCredential] + , Map ColdCommitteeCredential Integer + , Integer + , Integer + ) + (Maybe GovernanceActionId, Constitution) + ) + ) + ) + ) + ) -> + GovernanceAction + outOf = \case + Nothing -> InfoAction + Just (Left (mgid, cp, msh)) -> ParameterChange mgid cp msh + Just (Right (Left (mgid, v))) -> HardForkInitiation mgid v + Just (Right (Right (Left (wdrls, msh)))) -> TreasuryWithdrawals wdrls msh + Just (Right (Right (Right (Left msh)))) -> NoConfidence msh + Just (Right (Right (Right (Right (Left (mgid, creds, mems, n, d)))))) -> + UpdateCommittee mgid creds mems (Ratio.unsafeRatio n d) + Just (Right (Right (Right (Right (Right (mgid, c)))))) -> + NewConstitution mgid c + + +instance Arbitrary ProposalProcedure where + {-# INLINEABLE arbitrary #-} + arbitrary = ProposalProcedure <$> arbitrary <*> arbitrary <*> arbitrary + + {-# INLINEABLE shrink #-} + shrink (ProposalProcedure dep raddr ga) = + ProposalProcedure <$> shrink dep <*> shrink raddr <*> shrink ga + +instance CoArbitrary ProposalProcedure where + {-# INLINEABLE coarbitrary #-} + coarbitrary (ProposalProcedure dep raddr ga) = + coarbitrary dep . coarbitrary raddr . coarbitrary ga + +instance Function ProposalProcedure where + {-# INLINEABLE function #-} + function = functionMap into outOf + where + into :: + ProposalProcedure -> + (Lovelace, Credential, GovernanceAction) + into (ProposalProcedure dep raddr ga) = (dep, raddr, ga) + + outOf :: + (Lovelace, Credential, GovernanceAction) -> + ProposalProcedure + outOf (dep, raddr, ga) = ProposalProcedure dep raddr ga + + +instance Arbitrary TxOutRef where + {-# INLINEABLE arbitrary #-} + arbitrary = TxOutRef <$> arbitrary <*> (getNonNegative <$> arbitrary) + {-# INLINEABLE shrink #-} + shrink (TxOutRef tid ix) = + TxOutRef <$> shrink tid <*> (fmap getNonNegative . shrink . NonNegative $ ix) + +instance CoArbitrary TxOutRef where + {-# INLINEABLE coarbitrary #-} + coarbitrary (TxOutRef tid ix) = + coarbitrary tid . coarbitrary ix + +instance Function TxOutRef where + {-# INLINEABLE function #-} + function = functionMap (\(TxOutRef tid ix) -> (tid, ix)) (uncurry TxOutRef) + + +instance Arbitrary ScriptPurpose where + {-# INLINEABLE arbitrary #-} + arbitrary = + oneof + [ Minting <$> arbitrary + , Spending <$> arbitrary + , Rewarding <$> arbitrary + , Certifying . getNonNegative <$> arbitrary <*> arbitrary + , Voting <$> arbitrary + , Proposing . getNonNegative <$> arbitrary <*> arbitrary + ] + + {-# INLINEABLE shrink #-} + shrink = \case + Minting cs -> Minting <$> shrink cs + Spending txo -> Spending <$> shrink txo + Rewarding cred -> Rewarding <$> shrink cred + Certifying ix cert -> do + cert' <- shrink cert + NonNegative ix' <- shrink (NonNegative ix) + pure . Certifying ix' $ cert' + Voting voter -> Voting <$> shrink voter + Proposing ix pp -> do + pp' <- shrink pp + NonNegative ix' <- shrink (NonNegative ix) + pure . Proposing ix' $ pp' + +instance CoArbitrary ScriptPurpose where + {-# INLINEABLE coarbitrary #-} + coarbitrary = \case + Minting cs -> variant (0 :: Int) . coarbitrary cs + Spending txo -> variant (1 :: Int) . coarbitrary txo + Rewarding cred -> variant (2 :: Int) . coarbitrary cred + Certifying ix cert -> variant (3 :: Int) . coarbitrary ix . coarbitrary cert + Voting voter -> variant (4 :: Int) . coarbitrary voter + Proposing ix pp -> variant (5 :: Int) . coarbitrary ix . coarbitrary pp + +instance Function ScriptPurpose where + {-# INLINEABLE function #-} + function = functionMap into outOf + where + into :: + ScriptPurpose -> + Either + CurrencySymbol + ( Either + TxOutRef + ( Either + Credential + ( Either + (Integer, TxCert) + ( Either Voter (Integer, ProposalProcedure) + ) + ) + ) + ) + into = \case + Minting cs -> Left cs + Spending txo -> Right (Left txo) + Rewarding cred -> Right (Right (Left cred)) + Certifying ix cert -> Right (Right (Right (Left (ix, cert)))) + Voting voter -> Right (Right (Right (Right (Left voter)))) + Proposing ix pp -> Right (Right (Right (Right (Right (ix, pp))))) + + outOf :: + Either + CurrencySymbol + ( Either + TxOutRef + ( Either + Credential + ( Either + (Integer, TxCert) + ( Either Voter (Integer, ProposalProcedure) + ) + ) + ) + ) -> + ScriptPurpose + outOf = \case + Left cs -> Minting cs + Right (Left txo) -> Spending txo + Right (Right (Left cred)) -> Rewarding cred + Right (Right (Right (Left (ix, cert)))) -> Certifying ix cert + Right (Right (Right (Right (Left voter)))) -> Voting voter + Right (Right (Right (Right (Right (ix, pp))))) -> Proposing ix pp + +instance Arbitrary ScriptInfo where + {-# INLINEABLE arbitrary #-} + arbitrary = + oneof + [ MintingScript <$> arbitrary + , SpendingScript <$> arbitrary <*> arbitrary + , RewardingScript <$> arbitrary + , CertifyingScript . getNonNegative <$> arbitrary <*> arbitrary + , VotingScript <$> arbitrary + , ProposingScript . getNonNegative <$> arbitrary <*> arbitrary + ] + + {-# INLINEABLE shrink #-} + shrink = \case + MintingScript cs -> MintingScript <$> shrink cs + SpendingScript outRef mdat -> SpendingScript <$> shrink outRef <*> shrink mdat + RewardingScript cred -> RewardingScript <$> shrink cred + CertifyingScript ix cert -> do + NonNegative ix' <- shrink (NonNegative ix) + CertifyingScript ix' <$> shrink cert + VotingScript voter -> VotingScript <$> shrink voter + ProposingScript ix pp -> do + NonNegative ix' <- shrink (NonNegative ix) + ProposingScript ix' <$> shrink pp + +instance CoArbitrary ScriptInfo where + {-# INLINEABLE coarbitrary #-} + coarbitrary = \case + MintingScript cs -> variant (0 :: Int) . coarbitrary cs + SpendingScript txo dat -> variant (1 :: Int) . coarbitrary txo . coarbitrary dat + RewardingScript cred -> variant (2 :: Int) . coarbitrary cred + CertifyingScript idx cert -> variant (3 :: Int) . coarbitrary idx . coarbitrary cert + VotingScript voter -> variant (4 :: Int) . coarbitrary voter + ProposingScript idx prc -> variant (5 :: Int) . coarbitrary idx . coarbitrary prc + +instance Function ScriptInfo where + {-# INLINEABLE function #-} + function = functionMap into outOf + where + into :: + ScriptInfo -> + Either CurrencySymbol + (Either (TxOutRef, Maybe Datum) + (Either Credential + (Either (Integer, TxCert) + (Either Voter (Integer, ProposalProcedure))))) + into = \case + MintingScript cs -> Left cs + SpendingScript txo dat -> Right (Left (txo, dat)) + RewardingScript cred -> Right (Right (Left cred)) + CertifyingScript idx cert -> Right (Right (Right (Left (idx, cert)))) + VotingScript voter -> Right (Right (Right (Right (Left voter)))) + ProposingScript idx prc -> Right (Right (Right (Right (Right (idx, prc))))) + + outOf :: + Either CurrencySymbol + (Either (TxOutRef, Maybe Datum) + (Either Credential + (Either (Integer, TxCert) + (Either Voter (Integer, ProposalProcedure))))) -> + ScriptInfo + outOf = \case + Left cs -> MintingScript cs + Right (Left (txo, dat)) -> SpendingScript txo dat + Right (Right (Left cred)) -> RewardingScript cred + Right (Right (Right (Left (idx, cert)))) -> CertifyingScript idx cert + Right (Right (Right (Right (Left voter)))) -> VotingScript voter + Right (Right (Right (Right (Right (idx, prc))))) -> ProposingScript idx prc + +instance Arbitrary TxInInfo where + {-# INLINEABLE arbitrary #-} + arbitrary = TxInInfo <$> arbitrary <*> arbitrary + + {-# INLINEABLE shrink #-} + shrink (TxInInfo toutref tout) = + TxInInfo <$> shrink toutref <*> shrink tout + +instance CoArbitrary TxInInfo where + {-# INLINEABLE coarbitrary #-} + coarbitrary (TxInInfo toutref tout) = coarbitrary toutref . coarbitrary tout + +instance Function TxInInfo where + {-# INLINEABLE function #-} + function = functionMap into outOf + where + into :: TxInInfo -> (TxOutRef, TxOut) + into (TxInInfo toutref tout) = (toutref, tout) + + outOf :: (TxOutRef, TxOut) -> TxInInfo + outOf (toutref, tout) = TxInInfo toutref tout + +-- TODO: invariants + +instance Arbitrary TxInfo where + {-# INLINEABLE arbitrary #-} + arbitrary = do + ins <- getNonEmpty <$> arbitrary + routs <- arbitrary + outs <- getNonEmpty <$> arbitrary + fee <- arbitrary + mint <- arbitrary + cert <- arbitrary + wdrl <- arbitrary + valid <- arbitrary + sigs <- Set.toList <$> arbitrary + reds <- arbitrary + dats <- arbitrary + tid <- arbitrary + votes <- arbitrary + pps <- arbitrary + currT <- arbitrary + tDonation <- arbitrary + pure + . TxInfo ins routs outs fee mint cert wdrl valid sigs reds dats tid votes pps currT + $ tDonation + + {-# INLINEABLE shrink #-} + shrink (TxInfo ins routs outs fee mint cert wdrl val sigs rds dats tid votes pps cur don) = do + NonEmpty ins' <- shrink (NonEmpty ins) + routs' <- shrink routs + NonEmpty outs' <- shrink (NonEmpty outs) + fee' <- shrink fee + mint' <- shrink mint + cert' <- shrink cert + wdrl' <- shrink wdrl + valid' <- shrink val + sigs' <- shrink sigs + reds' <- shrink rds + dats' <- shrink dats + tid' <- shrink tid + votes' <- shrink votes + pps' <- shrink pps + currT' <- shrink cur + tDonation' <- shrink don + pure $ + TxInfo + ins' + routs' + outs' + fee' + mint' + cert' + wdrl' + valid' + sigs' + reds' + dats' + tid' + votes' + pps' + currT' + tDonation' + +instance CoArbitrary TxInfo where + {-# INLINEABLE coarbitrary #-} + coarbitrary (TxInfo ins routs outs fee mint cert wdrl val sigs rds dats tid votes pps cur don) = + coarbitrary ins + . coarbitrary routs + . coarbitrary outs + . coarbitrary fee + . coarbitrary mint + . coarbitrary cert + . coarbitrary wdrl + . coarbitrary val + . coarbitrary sigs + . coarbitrary rds + . coarbitrary dats + . coarbitrary tid + . coarbitrary votes + . coarbitrary pps + . coarbitrary cur + . coarbitrary don + +instance Function TxInfo where + {-# INLINEABLE function #-} + function = functionMap into outOf + where + into :: + TxInfo -> + ( [TxInInfo] + , [TxInInfo] + , [TxOut] + , Lovelace + , MintValue + , [TxCert] + , ( Map Credential Lovelace + , POSIXTimeRange + , [PubKeyHash] + , Map ScriptPurpose Redeemer + , Map DatumHash Datum + , TxId + , ( Map Voter (Map GovernanceActionId Vote) + , [ProposalProcedure] + , Maybe Lovelace + , Maybe Lovelace + ) + ) + ) + into (TxInfo ins routs outs fee mint cert wdrl val sigs rds dats tid votes pps cur don) = + (ins, routs, outs, fee, mint, cert, + (wdrl, val, sigs, rds, dats, tid, (votes, pps, cur, don))) + + outOf :: + ( [TxInInfo] + , [TxInInfo] + , [TxOut] + , Lovelace + , MintValue + , [TxCert] + , ( Map Credential Lovelace + , POSIXTimeRange + , [PubKeyHash] + , Map ScriptPurpose Redeemer + , Map DatumHash Datum + , TxId + , ( Map Voter (Map GovernanceActionId Vote) + , [ProposalProcedure] + , Maybe Lovelace + , Maybe Lovelace + ) + ) + ) -> + TxInfo + outOf + (ins, routs, outs, fee, mint, cert, + (wdrl, val, sigs, rds, dats, tid, (votes, pps, cur, don))) = + TxInfo ins routs outs fee mint cert wdrl val sigs rds dats tid votes pps cur don + + +instance Arbitrary ScriptContext where + {-# INLINEABLE arbitrary #-} + arbitrary = ScriptContext <$> arbitrary <*> arbitrary <*> arbitrary + + {-# INLINEABLE shrink #-} + shrink (ScriptContext tinfo red sinfo) = + ScriptContext <$> shrink tinfo <*> shrink red <*> shrink sinfo + +instance CoArbitrary ScriptContext where + {-# INLINEABLE coarbitrary #-} + coarbitrary (ScriptContext tinfo red sinfo) = + coarbitrary tinfo . coarbitrary red . coarbitrary sinfo + +instance Function ScriptContext where + {-# INLINEABLE function #-} + function = functionMap into outOf + where + into :: ScriptContext -> (TxInfo, Redeemer, ScriptInfo) + into (ScriptContext tinfo red sinfo) = (tinfo, red, sinfo) + + outOf :: (TxInfo, Redeemer, ScriptInfo) -> ScriptContext + outOf (tinfo, red, sinfo) = ScriptContext tinfo red sinfo diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V3/MintValue.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V3/MintValue.hs new file mode 100644 index 00000000000..e024704d491 --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V3/MintValue.hs @@ -0,0 +1,77 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +module PlutusLedgerApi.Test.Orphans.V3.MintValue () where + +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.Coerce (coerce) +import Data.Set qualified as Set +import PlutusLedgerApi.Test.Orphans.PlutusTx (getBlake2b244Hash) +import PlutusLedgerApi.Test.Orphans.V1.Value () +import PlutusLedgerApi.V1.Value (CurrencySymbol (CurrencySymbol), TokenName (TokenName), + Value (getValue)) +import PlutusLedgerApi.V1.Value qualified as Value +import PlutusLedgerApi.V3.MintValue (MintValue (UnsafeMintValue)) +import PlutusTx.AssocMap qualified as AssocMap +import PlutusTx.Prelude (toBuiltin) +import Test.QuickCheck (Arbitrary (arbitrary, shrink), Arbitrary1 (liftArbitrary, liftShrink), + CoArbitrary, Function (function), Gen, NonZero (NonZero), + chooseBoundedIntegral, chooseInt, functionMap, getNonEmpty, getNonZero, + resize, scale, sized, vectorOf) + +instance Arbitrary MintValue where + {-# INLINEABLE arbitrary #-} + arbitrary = + UnsafeMintValue <$> do + -- Generate a set of currency symbols that aren't Ada + keySet <- Set.fromList + <$> liftArbitrary (CurrencySymbol . getBlake2b244Hash <$> arbitrary) + let keyList = Set.toList keySet + -- For each key, generate a set of token name keys that aren't Ada + keyVals <- traverse (scale (`quot` 8) . mkInner) keyList + pure + . getValue + . foldMap (\(cs, vals) -> foldMap (uncurry (Value.singleton cs)) vals) + $ keyVals + where + mkInner :: CurrencySymbol -> Gen (CurrencySymbol, [(TokenName, Integer)]) + mkInner cs = + (cs,) + . Set.toList + . Set.fromList + . getNonEmpty + <$> liftArbitrary ((,) <$> genNonAdaTokenName <*> (getNonZero <$> arbitrary)) + + genNonAdaTokenName :: Gen TokenName + genNonAdaTokenName = + fmap (TokenName . toBuiltin @ByteString . BS.pack) . sized $ \size -> do + len <- resize size . chooseInt $ (1, 32) + vectorOf len . chooseBoundedIntegral $ (33, 126) + + {-# INLINEABLE shrink #-} + shrink (UnsafeMintValue v) = + UnsafeMintValue <$> do + -- To ensure we don't break anything, we shrink in only two ways: + -- + -- 1. Dropping keys (outer or inner) + -- 2. Shrinking amounts + -- + -- To make this a bit easier on ourselves, we first 'unpack' the Value + -- completely, shrink the resulting (nested) list, then 'repack'. As neither + -- of these changes affect order or uniqueness, we're safe. + let asList = fmap AssocMap.toList <$> AssocMap.toList v + shrunk <- liftShrink + (\(cs, inner) -> + (cs,) <$> liftShrink + (\(tn, amount) -> (tn,) . getNonZero <$> shrink (NonZero amount)) + inner) asList + pure . AssocMap.unsafeFromList . fmap (fmap AssocMap.unsafeFromList) $ shrunk + +deriving via Value instance CoArbitrary MintValue + +instance Function MintValue where + {-# INLINEABLE function #-} + function = functionMap coerce UnsafeMintValue diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V3/Tx.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V3/Tx.hs new file mode 100644 index 00000000000..ba50bc26fc0 --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V3/Tx.hs @@ -0,0 +1,37 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE DerivingVia #-} + +module PlutusLedgerApi.Test.Orphans.V3.Tx () where + +import Data.Coerce (coerce) +import PlutusLedgerApi.Test.Orphans.PlutusTx (Blake2b256Hash (Blake2b256Hash)) +import PlutusLedgerApi.V3.Tx (TxId (TxId), TxOutRef (TxOutRef)) +import Test.QuickCheck (Arbitrary (arbitrary, shrink), CoArbitrary (coarbitrary), + Function (function), NonNegative (NonNegative), functionMap, getNonNegative) + +-- | BLAKE2b-256 hash (32 bytes) of a transaction ID. +deriving via Blake2b256Hash instance Arbitrary TxId + +deriving via Blake2b256Hash instance CoArbitrary TxId + +instance Function TxId where + {-# INLINEABLE function #-} + function = functionMap coerce TxId + + +instance Arbitrary TxOutRef where + {-# INLINEABLE arbitrary #-} + arbitrary = TxOutRef <$> arbitrary <*> (getNonNegative <$> arbitrary) + + {-# INLINEABLE shrink #-} + shrink (TxOutRef tid ix) = + TxOutRef <$> shrink tid <*> (fmap getNonNegative . shrink . NonNegative $ ix) + +instance CoArbitrary TxOutRef where + {-# INLINEABLE coarbitrary #-} + coarbitrary (TxOutRef tid ix) = + coarbitrary tid . coarbitrary ix + +instance Function TxOutRef where + {-# INLINEABLE function #-} + function = functionMap (\(TxOutRef tid ix) -> (tid, ix)) (uncurry TxOutRef) From 6ed9dd392ea0dc9a9839040c53d29fb1c5b4f567 Mon Sep 17 00:00:00 2001 From: t4ccer Date: Fri, 1 Nov 2024 11:57:21 -0600 Subject: [PATCH 04/16] Remove obsolete `Arbitrary` instances --- plutus-ledger-api/CHANGELOG.md | 10 +++++++ plutus-ledger-api/test/Spec/V1/Data/Value.hs | 1 + plutus-ledger-api/test/Spec/V1/Value.hs | 1 + .../testlib/PlutusLedgerApi/Test/V1/Value.hs | 29 +------------------ .../PlutusLedgerApi/Test/V3/MintValue.hs | 23 +-------------- 5 files changed, 14 insertions(+), 50 deletions(-) diff --git a/plutus-ledger-api/CHANGELOG.md b/plutus-ledger-api/CHANGELOG.md index 6585f0b5f04..09d62a3ef2d 100644 --- a/plutus-ledger-api/CHANGELOG.md +++ b/plutus-ledger-api/CHANGELOG.md @@ -1,3 +1,13 @@ +# WIP + +## Added + +- `PlutusLedgerApi.Test.Orphans` module to testlib with quickcheck instances for all ledger types. + +## Removed + +- `Arbitrary` instances from `PlutusLedgerApi.Test.V1.Value` and `PlutusLedgerApi.Test.V3.MintValue`. Import `PlutusLedgerApi.Test.Orphans` instead. + # 1.34.0.0 — 2024-09-09 diff --git a/plutus-ledger-api/test/Spec/V1/Data/Value.hs b/plutus-ledger-api/test/Spec/V1/Data/Value.hs index 81a5326cbdb..1e417471154 100644 --- a/plutus-ledger-api/test/Spec/V1/Data/Value.hs +++ b/plutus-ledger-api/test/Spec/V1/Data/Value.hs @@ -2,6 +2,7 @@ module Spec.V1.Data.Value where +import PlutusLedgerApi.Test.Orphans () import PlutusLedgerApi.Test.V1.Data.Value as Value -- TODO: import a new PlutusLedgerApi.Data.V1 module instead import PlutusLedgerApi.V1.Data.Value diff --git a/plutus-ledger-api/test/Spec/V1/Value.hs b/plutus-ledger-api/test/Spec/V1/Value.hs index 1f817bbed15..f15d221c80f 100644 --- a/plutus-ledger-api/test/Spec/V1/Value.hs +++ b/plutus-ledger-api/test/Spec/V1/Value.hs @@ -1,5 +1,6 @@ module Spec.V1.Value where +import PlutusLedgerApi.Test.Orphans () import PlutusLedgerApi.Test.V1.Value as Value import PlutusLedgerApi.V1 import PlutusLedgerApi.V1.Value diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V1/Value.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V1/Value.hs index 90afa8a1ee4..670a35d5cc2 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V1/Value.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V1/Value.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -9,11 +8,10 @@ import PlutusLedgerApi.V1 import PlutusTx.AssocMap qualified as AssocMap import PlutusTx.List qualified as ListTx -import PlutusCore.Generators.QuickCheck.Utils (multiSplit0, uniqueVectorOf) +import PlutusCore.Generators.QuickCheck.Utils (uniqueVectorOf) import Data.ByteString.Base16 qualified as Base16 import Data.ByteString.Char8 qualified as BS8 -import Data.Coerce import Test.QuickCheck -- | Convert a list representation of a 'Value' to the 'Value'. @@ -68,28 +66,3 @@ instance Arbitrary FaceValue where [ (2, pure $ FaceValue 0) , (1, FaceValue . fromIntegral <$> arbitrary @Int) ] - --- | A wrapper for satisfying an @Arbitrary a@ constraint without implementing an 'Arbitrary' --- instance for @a@. -newtype NoArbitrary a = NoArbitrary - { unNoArbitrary :: a - } - --- | 'arbitrary' throws, 'shrink' neither throws nor shrinks. -instance Arbitrary (NoArbitrary a) where - arbitrary = error "No such 'Arbitrary' instance" - shrink _ = [] - -instance Arbitrary Value where - arbitrary = do - -- Generate values for all of the 'TokenName's in the final 'Value' and split them into a - -- list of lists. - faceValues <- multiSplit0 0.2 . map unFaceValue =<< arbitrary - -- Generate 'TokenName's and 'CurrencySymbol's. - currencies <- uniqueNames CurrencySymbol =<< traverse (uniqueNames TokenName) faceValues - pure $ listsToValue currencies - - shrink - = map listsToValue - . coerce (shrink @[(NoArbitrary CurrencySymbol, [(NoArbitrary TokenName, Integer)])]) - . valueToLists diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V3/MintValue.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V3/MintValue.hs index f8f87b39ad9..8a6ea2eb23c 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V3/MintValue.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V3/MintValue.hs @@ -1,36 +1,15 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wno-orphans #-} module PlutusLedgerApi.Test.V3.MintValue where import Data.Coerce (coerce) -import PlutusCore.Generators.QuickCheck.Split (multiSplit0) -import PlutusLedgerApi.Test.V1.Value (NoArbitrary (..), uniqueNames) import PlutusLedgerApi.V1.Value (CurrencySymbol (..), TokenName (..)) import PlutusLedgerApi.V3.MintValue (MintValue (..)) import PlutusTx.AssocMap qualified as Map import PlutusTx.List qualified as List -import Test.QuickCheck (Arbitrary (..)) - -instance Arbitrary MintValue where - arbitrary = do - -- Generate values for all of the 'TokenName's in the final 'MintValue' - -- and split them into a list of lists. - faceValues <- multiSplit0 0.2 . map unQuantity =<< arbitrary - -- Generate 'TokenName's and 'CurrencySymbol's. - currencies <- - uniqueNames CurrencySymbol - =<< traverse (uniqueNames TokenName) faceValues - pure $ listsToMintValue currencies - - shrink = - map listsToMintValue - . coerce - (shrink @[(NoArbitrary CurrencySymbol, [(NoArbitrary TokenName, Integer)])]) - . mintValueToLists +import Test.QuickCheck (Arbitrary) -- | Convert a list representation of a 'MintValue' to the 'MintValue'. listsToMintValue :: [(CurrencySymbol, [(TokenName, Integer)])] -> MintValue From 33de71e4535099bd68c56f3ac0a408275162beaa Mon Sep 17 00:00:00 2001 From: t4ccer Date: Fri, 1 Nov 2024 12:54:16 -0600 Subject: [PATCH 05/16] Fix build with GHC8 --- .../PlutusLedgerApi/Test/Common/QuickCheck/Utils.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Common/QuickCheck/Utils.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Common/QuickCheck/Utils.hs index 6a5e9d86acf..3cfc381b8fb 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Common/QuickCheck/Utils.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Common/QuickCheck/Utils.hs @@ -19,7 +19,7 @@ import Data.ByteString qualified as BS import Data.Coerce (coerce) import Data.Proxy (Proxy (Proxy)) import Data.Word (Word64) -import GHC.TypeNats (KnownNat, Natural, natVal) +import GHC.TypeNats (KnownNat, Nat, natVal) import Test.QuickCheck (Arbitrary (arbitrary, shrink), CoArbitrary, Function (function), functionMap, vectorOf) import Test.QuickCheck.Instances.ByteString () @@ -28,7 +28,7 @@ import Test.QuickCheck.Instances.ByteString () constructor, instead providing a read-only pattern, as well as an accessor function, to ensure that the size invariant is maintained. -} -newtype SizedByteString (n :: Natural) = UnsafeSizedByteString ByteString +newtype SizedByteString (n :: Nat) = UnsafeSizedByteString ByteString deriving (Eq ,Ord @@ -63,7 +63,7 @@ instance Function (SizedByteString n) where {- | Read-only pattern for accessing the underlying 'ByteString'. Use it just like you would use a data constructor in a pattern match. -} -pattern SizedByteString :: forall (n :: Natural). ByteString -> SizedByteString n +pattern SizedByteString :: forall (n :: Nat). ByteString -> SizedByteString n pattern SizedByteString bs <- UnsafeSizedByteString bs {-# COMPLETE SizedByteString #-} @@ -72,7 +72,7 @@ pattern SizedByteString bs <- UnsafeSizedByteString bs specified in its type. -} unSizedByteString :: - forall (n :: Natural). + forall (n :: Nat). SizedByteString n -> ByteString unSizedByteString = coerce From 7f28295d096b88243500753af9ff86253a23dd09 Mon Sep 17 00:00:00 2001 From: t4ccer Date: Fri, 1 Nov 2024 12:55:18 -0600 Subject: [PATCH 06/16] Add changelog fragment --- .../changelog.d/20241101_125455_t4ccer_quickcheck.md | 7 +++++++ 1 file changed, 7 insertions(+) create mode 100644 plutus-ledger-api/changelog.d/20241101_125455_t4ccer_quickcheck.md diff --git a/plutus-ledger-api/changelog.d/20241101_125455_t4ccer_quickcheck.md b/plutus-ledger-api/changelog.d/20241101_125455_t4ccer_quickcheck.md new file mode 100644 index 00000000000..b634d7e3d01 --- /dev/null +++ b/plutus-ledger-api/changelog.d/20241101_125455_t4ccer_quickcheck.md @@ -0,0 +1,7 @@ +### Removed + +- `Arbitrary` instances from `PlutusLedgerApi.Test.V1.Value` and `PlutusLedgerApi.Test.V3.MintValue`. Import `PlutusLedgerApi.Test.Orphans` instead. + +### Added + +- `PlutusLedgerApi.Test.Orphans` module to testlib with quickcheck instances for all ledger types. From b2ad5e8a532243cfe98899ecd332881fe2dc4e60 Mon Sep 17 00:00:00 2001 From: t4ccer Date: Fri, 1 Nov 2024 12:57:16 -0600 Subject: [PATCH 07/16] Remove main changelog entry --- plutus-ledger-api/CHANGELOG.md | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/plutus-ledger-api/CHANGELOG.md b/plutus-ledger-api/CHANGELOG.md index 09d62a3ef2d..6585f0b5f04 100644 --- a/plutus-ledger-api/CHANGELOG.md +++ b/plutus-ledger-api/CHANGELOG.md @@ -1,13 +1,3 @@ -# WIP - -## Added - -- `PlutusLedgerApi.Test.Orphans` module to testlib with quickcheck instances for all ledger types. - -## Removed - -- `Arbitrary` instances from `PlutusLedgerApi.Test.V1.Value` and `PlutusLedgerApi.Test.V3.MintValue`. Import `PlutusLedgerApi.Test.Orphans` instead. - # 1.34.0.0 — 2024-09-09 From 79d543ccfb797b2bd9e8b36e8ab400f54eed3d1a Mon Sep 17 00:00:00 2001 From: t4ccer Date: Sun, 10 Nov 2024 16:31:56 -0700 Subject: [PATCH 08/16] Add UnsortedAssocMap --- .../20241101_125455_t4ccer_quickcheck.md | 4 +- plutus-ledger-api/plutus-ledger-api.cabal | 2 +- plutus-ledger-api/test/Spec/V1/Data/Value.hs | 2 +- plutus-ledger-api/test/Spec/V1/Value.hs | 2 +- .../testlib/PlutusLedgerApi/Test/Orphans.hs | 6 --- .../PlutusLedgerApi/Test/Orphans/PlutusTx.hs | 54 ++++++++++++++++--- .../PlutusLedgerApi/Test/QuickCheck.hs | 6 +++ 7 files changed, 59 insertions(+), 17 deletions(-) delete mode 100644 plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans.hs create mode 100644 plutus-ledger-api/testlib/PlutusLedgerApi/Test/QuickCheck.hs diff --git a/plutus-ledger-api/changelog.d/20241101_125455_t4ccer_quickcheck.md b/plutus-ledger-api/changelog.d/20241101_125455_t4ccer_quickcheck.md index b634d7e3d01..c4ba7fabe4a 100644 --- a/plutus-ledger-api/changelog.d/20241101_125455_t4ccer_quickcheck.md +++ b/plutus-ledger-api/changelog.d/20241101_125455_t4ccer_quickcheck.md @@ -1,7 +1,7 @@ ### Removed -- `Arbitrary` instances from `PlutusLedgerApi.Test.V1.Value` and `PlutusLedgerApi.Test.V3.MintValue`. Import `PlutusLedgerApi.Test.Orphans` instead. +- `Arbitrary` instances from `PlutusLedgerApi.Test.V1.Value` and `PlutusLedgerApi.Test.V3.MintValue`. Import `PlutusLedgerApi.Test.QuickCheck` instead. ### Added -- `PlutusLedgerApi.Test.Orphans` module to testlib with quickcheck instances for all ledger types. +- `PlutusLedgerApi.Test.QuickCheck` module to testlib with quickcheck instances for all ledger types. diff --git a/plutus-ledger-api/plutus-ledger-api.cabal b/plutus-ledger-api/plutus-ledger-api.cabal index 6fa438a7c2b..3677bd9ae20 100644 --- a/plutus-ledger-api/plutus-ledger-api.cabal +++ b/plutus-ledger-api/plutus-ledger-api.cabal @@ -125,7 +125,7 @@ library plutus-ledger-api-testlib PlutusLedgerApi.Test.Common.EvaluationContext PlutusLedgerApi.Test.EvaluationEvent PlutusLedgerApi.Test.Examples - PlutusLedgerApi.Test.Orphans + PlutusLedgerApi.Test.QuickCheck PlutusLedgerApi.Test.Scripts PlutusLedgerApi.Test.V1.Data.EvaluationContext PlutusLedgerApi.Test.V1.Data.Value diff --git a/plutus-ledger-api/test/Spec/V1/Data/Value.hs b/plutus-ledger-api/test/Spec/V1/Data/Value.hs index 1e417471154..f964fb54582 100644 --- a/plutus-ledger-api/test/Spec/V1/Data/Value.hs +++ b/plutus-ledger-api/test/Spec/V1/Data/Value.hs @@ -2,7 +2,7 @@ module Spec.V1.Data.Value where -import PlutusLedgerApi.Test.Orphans () +import PlutusLedgerApi.Test.QuickCheck () import PlutusLedgerApi.Test.V1.Data.Value as Value -- TODO: import a new PlutusLedgerApi.Data.V1 module instead import PlutusLedgerApi.V1.Data.Value diff --git a/plutus-ledger-api/test/Spec/V1/Value.hs b/plutus-ledger-api/test/Spec/V1/Value.hs index f15d221c80f..ceaca1a9d87 100644 --- a/plutus-ledger-api/test/Spec/V1/Value.hs +++ b/plutus-ledger-api/test/Spec/V1/Value.hs @@ -1,6 +1,6 @@ module Spec.V1.Value where -import PlutusLedgerApi.Test.Orphans () +import PlutusLedgerApi.Test.QuickCheck () import PlutusLedgerApi.Test.V1.Value as Value import PlutusLedgerApi.V1 import PlutusLedgerApi.V1.Value diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans.hs deleted file mode 100644 index 944cf44bdc1..00000000000 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans.hs +++ /dev/null @@ -1,6 +0,0 @@ -module PlutusLedgerApi.Test.Orphans () where - -import PlutusLedgerApi.Test.Orphans.PlutusTx () -import PlutusLedgerApi.Test.Orphans.V1 () -import PlutusLedgerApi.Test.Orphans.V2 () -import PlutusLedgerApi.Test.Orphans.V3 () diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/PlutusTx.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/PlutusTx.hs index f857c861285..89e52a8c5e0 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/PlutusTx.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/PlutusTx.hs @@ -13,8 +13,11 @@ module PlutusLedgerApi.Test.Orphans.PlutusTx ( Blake2b244Hash (..), getBlake2b256Hash, getBlake2b244Hash, + UnsortedAssocMap, + getUnsortedAssocMap, ) where + import Data.ByteString (ByteString) import Data.Coerce (coerce) import Data.Kind (Type) @@ -23,10 +26,11 @@ import PlutusLedgerApi.Test.Common.QuickCheck.Utils (unSizedByteString) import PlutusTx.AssocMap qualified as AssocMap import PlutusTx.Builtins qualified as Builtins import PlutusTx.Prelude qualified as PlutusTx +import Prettyprinter (Pretty) import Test.QuickCheck (Arbitrary (arbitrary, shrink), Arbitrary1 (liftArbitrary, liftShrink), CoArbitrary (coarbitrary), Function (function), Gen, NonNegative (NonNegative), functionMap, getNonNegative, liftArbitrary, - oneof, scale, sized, variant) + oneof, scale, shuffle, sized, variant) import Test.QuickCheck.Instances.ByteString () instance Arbitrary PlutusTx.BuiltinByteString where @@ -172,10 +176,10 @@ instance Function PlutusTx.BuiltinData where ) -> PlutusTx.BuiltinData outOf = \case - Left (ix, dats) -> Builtins.mkConstr ix dats - Right (Left kvs) -> Builtins.mkMap kvs - Right (Right (Left ell)) -> Builtins.mkList ell - Right (Right (Right (Left i))) -> Builtins.mkI i + Left (ix, dats) -> Builtins.mkConstr ix dats + Right (Left kvs) -> Builtins.mkMap kvs + Right (Right (Left ell)) -> Builtins.mkList ell + Right (Right (Right (Left i))) -> Builtins.mkI i Right (Right (Right (Right bs))) -> Builtins.mkB bs {- | This generates well-defined maps: specifically, there are no duplicate @@ -185,7 +189,6 @@ whole entries, or shrink values associated with keys. In order to make this instance even moderately efficient, we require an 'Ord' constraint on keys. In practice, this isn't a significant limitation, as basically all Plutus types have such an instance. - -} instance (Arbitrary k, Ord k) => Arbitrary1 (AssocMap.Map k) where {-# INLINEABLE liftArbitrary #-} @@ -195,6 +198,7 @@ instance (Arbitrary k, Ord k) => Arbitrary1 (AssocMap.Map k) where keyList <- Set.toList <$> arbitrary -- Then generate a value for each traverse (\key -> (key,) <$> genVal) keyList + {-# INLINEABLE liftShrink #-} liftShrink shrinkVal aMap = AssocMap.unsafeFromList <$> do @@ -204,6 +208,7 @@ instance (Arbitrary k, Ord k) => Arbitrary1 (AssocMap.Map k) where instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (AssocMap.Map k v) where {-# INLINEABLE arbitrary #-} arbitrary = liftArbitrary arbitrary + {-# INLINEABLE shrink #-} shrink = liftShrink shrink @@ -214,3 +219,40 @@ instance (CoArbitrary k, CoArbitrary v) => CoArbitrary (AssocMap.Map k v) where instance (Function k, Function v) => Function (AssocMap.Map k v) where {-# INLINEABLE function #-} function = functionMap AssocMap.toList AssocMap.unsafeFromList + + +-- | Unsorted AssocMap with no duplicate keys +newtype UnsortedAssocMap k v = UnsortedAssocMap (AssocMap.Map k v) + deriving newtype (Show, Eq, Ord, Pretty) + +instance (Arbitrary k, Ord k) => Arbitrary1 (UnsortedAssocMap k) where + {-# INLINEABLE liftArbitrary #-} + liftArbitrary genVal = + UnsortedAssocMap . AssocMap.unsafeFromList <$> do + keyList <- Set.toList <$> arbitrary + unsortedKeyList <- shuffle keyList + traverse (\key -> (key,) <$> genVal) unsortedKeyList + + {-# INLINEABLE liftShrink #-} + liftShrink shrinkVal (UnsortedAssocMap aMap) = + UnsortedAssocMap . AssocMap.unsafeFromList <$> do + let asList = AssocMap.toList aMap + liftShrink (\(key, val) -> (key,) <$> shrinkVal val) asList + +instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (UnsortedAssocMap k v) where + {-# INLINEABLE arbitrary #-} + arbitrary = liftArbitrary arbitrary + + {-# INLINEABLE shrink #-} + shrink = liftShrink shrink + +instance (CoArbitrary k, CoArbitrary v) => CoArbitrary (UnsortedAssocMap k v) where + {-# INLINEABLE coarbitrary #-} + coarbitrary (UnsortedAssocMap aMap) = coarbitrary aMap + +instance (Function k, Function v) => Function (UnsortedAssocMap k v) where + {-# INLINEABLE function #-} + function = functionMap @(AssocMap.Map k v) coerce coerce + +getUnsortedAssocMap :: UnsortedAssocMap k v -> AssocMap.Map k v +getUnsortedAssocMap = coerce diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/QuickCheck.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/QuickCheck.hs new file mode 100644 index 00000000000..d2f2d50c66e --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/QuickCheck.hs @@ -0,0 +1,6 @@ +module PlutusLedgerApi.Test.QuickCheck (UnsortedAssocMap, getUnsortedAssocMap) where + +import PlutusLedgerApi.Test.Orphans.PlutusTx (UnsortedAssocMap, getUnsortedAssocMap) +import PlutusLedgerApi.Test.Orphans.V1 () +import PlutusLedgerApi.Test.Orphans.V2 () +import PlutusLedgerApi.Test.Orphans.V3 () From 9597cf902496b6e28765719836fe3f372c118a42 Mon Sep 17 00:00:00 2001 From: t4ccer Date: Wed, 13 Nov 2024 12:50:33 -0700 Subject: [PATCH 09/16] Shrink hashes towards all zeros --- .../PlutusLedgerApi/Test/Orphans/PlutusTx.hs | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/PlutusTx.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/PlutusTx.hs index 89e52a8c5e0..c8e2578022f 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/PlutusTx.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/PlutusTx.hs @@ -19,9 +19,11 @@ module PlutusLedgerApi.Test.Orphans.PlutusTx ( import Data.ByteString (ByteString) +import Data.ByteString qualified as BS import Data.Coerce (coerce) import Data.Kind (Type) import Data.Set qualified as Set +import Data.Word (Word8) import PlutusLedgerApi.Test.Common.QuickCheck.Utils (unSizedByteString) import PlutusTx.AssocMap qualified as AssocMap import PlutusTx.Builtins qualified as Builtins @@ -53,12 +55,21 @@ newtype Blake2b244Hash = Blake2b244Hash PlutusTx.BuiltinByteString deriving (Eq, Ord) via PlutusTx.BuiltinByteString deriving stock (Show) +bytestringWrite :: ByteString -> Int -> Word8 -> ByteString +bytestringWrite bs i w = BS.take i bs <> BS.singleton w <> BS.drop (i + 1) bs + -- No shrinker, as it doesn't make much sense to. instance Arbitrary Blake2b244Hash where {-# INLINEABLE arbitrary #-} arbitrary = Blake2b244Hash . PlutusTx.toBuiltin @ByteString . unSizedByteString @28 <$> arbitrary + {-# INLINEABLE shrink #-} + shrink (Blake2b244Hash bs) = + let bs' = PlutusTx.fromBuiltin bs + in foldMap (\i -> [Blake2b244Hash . PlutusTx.toBuiltin $ bytestringWrite bs' i b + | b <- shrink (BS.index bs' i)]) [0..27] + deriving via PlutusTx.BuiltinByteString instance CoArbitrary Blake2b244Hash getBlake2b244Hash :: Blake2b244Hash -> PlutusTx.BuiltinByteString @@ -69,12 +80,17 @@ newtype Blake2b256Hash = Blake2b256Hash PlutusTx.BuiltinByteString deriving (Eq, Ord) via PlutusTx.BuiltinByteString deriving stock (Show) --- No shrinker, as it doesn't make much sense to. instance Arbitrary Blake2b256Hash where {-# INLINEABLE arbitrary #-} arbitrary = Blake2b256Hash . PlutusTx.toBuiltin @ByteString . unSizedByteString @32 <$> arbitrary + {-# INLINEABLE shrink #-} + shrink (Blake2b256Hash bs) = + let bs' = PlutusTx.fromBuiltin bs + in foldMap (\i -> [Blake2b256Hash . PlutusTx.toBuiltin $ bytestringWrite bs' i b + | b <- shrink (BS.index bs' i)]) [0..31] + deriving via PlutusTx.BuiltinByteString instance CoArbitrary Blake2b256Hash getBlake2b256Hash :: Blake2b256Hash -> PlutusTx.BuiltinByteString From 2deda45fa6d1200ee10d424efd2780f9328251a0 Mon Sep 17 00:00:00 2001 From: t4ccer Date: Wed, 13 Nov 2024 12:40:25 -0700 Subject: [PATCH 10/16] Shrink fields one by one --- .../Test/Orphans/V1/Address.hs | 4 +- .../Test/Orphans/V1/Contexts.hs | 39 ++-- .../Test/Orphans/V1/Credential.hs | 17 +- .../PlutusLedgerApi/Test/Orphans/V1/DCert.hs | 13 +- .../Test/Orphans/V1/Interval.hs | 8 +- .../Test/Orphans/V1/Scripts.hs | 2 - .../PlutusLedgerApi/Test/Orphans/V1/Tx.hs | 12 +- .../Test/Orphans/V2/Contexts.hs | 42 ++-- .../PlutusLedgerApi/Test/Orphans/V2/Tx.hs | 14 +- .../Test/Orphans/V3/Contexts.hs | 192 ++++++++++-------- .../PlutusLedgerApi/Test/Orphans/V3/Tx.hs | 3 +- 11 files changed, 194 insertions(+), 152 deletions(-) diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Address.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Address.hs index 7a720db07f4..8d587dd05b5 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Address.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Address.hs @@ -14,7 +14,9 @@ instance Arbitrary Address where {-# INLINEABLE shrink #-} -- As Credential does not shrink, we just pass it through. - shrink (Address cred scred) = Address cred <$> shrink scred + shrink (Address cred scred) = + [ Address cred' scred | cred' <- shrink cred ] ++ + [ Address cred scred' | scred' <- shrink scred ] instance CoArbitrary Address where {-# INLINEABLE coarbitrary #-} diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Contexts.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Contexts.hs index 181a80515bb..554371c129f 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Contexts.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Contexts.hs @@ -29,7 +29,8 @@ instance Arbitrary ScriptContext where {-# INLINEABLE shrink #-} shrink (ScriptContext tinfo p) = - ScriptContext <$> shrink tinfo <*> shrink p + [ScriptContext tinfo' p | tinfo' <- shrink tinfo] ++ + [ScriptContext tinfo p' | p' <- shrink p] instance CoArbitrary ScriptContext where {-# INLINEABLE coarbitrary #-} @@ -50,7 +51,8 @@ instance Arbitrary TxInInfo where {-# INLINEABLE shrink #-} shrink (TxInInfo outref resolved) = - TxInInfo <$> shrink outref <*> shrink resolved + [TxInInfo outref' resolved | outref' <- shrink outref] ++ + [TxInInfo outref resolved' | resolved' <- shrink resolved] instance CoArbitrary TxInInfo where {-# INLINEABLE coarbitrary #-} @@ -81,18 +83,27 @@ instance Arbitrary TxInfo where <*> arbitrary -- tid {-# INLINEABLE shrink #-} - shrink (TxInfo ins outs fee mint dcert wdrl validRange sigs dats tid) = do - NonEmpty ins' <- shrink (NonEmpty ins) - NonEmpty outs' <- shrink (NonEmpty outs) - Value.FeeValue fee' <- shrink (Value.FeeValue fee) - Value.MintValue mint' <- shrink (Value.MintValue mint) - dcert' <- shrink dcert - wdrl' <- shrink wdrl - validRange' <- shrink validRange - sigs' <- Set.toList <$> shrink (Set.fromList sigs) - dats' <- shrink dats - tid' <- shrink tid - pure . TxInfo ins' outs' fee' mint' dcert' wdrl' validRange' sigs' dats' $ tid' + shrink (TxInfo ins outs fee mint dcert wdrl validRange sigs dats tid) = + [ TxInfo ins' outs fee mint dcert wdrl validRange sigs dats tid + | NonEmpty ins' <- shrink (NonEmpty ins) ] ++ + [ TxInfo ins outs' fee mint dcert wdrl validRange sigs dats tid + | NonEmpty outs' <- shrink (NonEmpty outs) ] ++ + [ TxInfo ins outs fee' mint dcert wdrl validRange sigs dats tid + | Value.FeeValue fee' <- shrink (Value.FeeValue fee) ] ++ + [ TxInfo ins outs fee mint' dcert wdrl validRange sigs dats tid + | Value.MintValue mint' <- shrink (Value.MintValue mint) ] ++ + [ TxInfo ins outs fee mint dcert' wdrl validRange sigs dats tid + | dcert' <- shrink dcert ] ++ + [ TxInfo ins outs fee mint dcert wdrl' validRange sigs dats tid + | wdrl' <- shrink wdrl ] ++ + [ TxInfo ins outs fee mint dcert wdrl validRange' sigs dats tid + | validRange' <- shrink validRange ] ++ + [ TxInfo ins outs fee mint dcert wdrl validRange sigs' dats tid + | sigs' <- Set.toList <$> shrink (Set.fromList sigs) ] ++ + [ TxInfo ins outs fee mint dcert wdrl validRange sigs dats' tid + | dats' <- shrink dats ] ++ + [ TxInfo ins outs fee mint dcert wdrl validRange sigs dats tid' + | tid' <- shrink tid ] instance CoArbitrary TxInfo where {-# INLINEABLE coarbitrary #-} diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Credential.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Credential.hs index e55acb1433c..336d2d17e7c 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Credential.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Credential.hs @@ -25,6 +25,11 @@ instance Arbitrary Credential where , ScriptCredential <$> arbitrary ] + {-# INLINEABLE shrink #-} + shrink = \case + PubKeyCredential pkh -> PubKeyCredential <$> shrink pkh + ScriptCredential sh -> ScriptCredential <$> shrink sh + instance CoArbitrary Credential where {-# INLINEABLE coarbitrary #-} coarbitrary = \case @@ -59,13 +64,11 @@ instance Arbitrary StakingCredential where {-# INLINEABLE shrink #-} shrink = \case - -- Since Credentials don't shrink, we don't shrink this case - StakingHash _ -> [] - StakingPtr i j k -> do - NonNegative i' <- shrink (NonNegative i) - NonNegative j' <- shrink (NonNegative j) - NonNegative k' <- shrink (NonNegative k) - pure . StakingPtr i' j' $ k' + StakingHash cred -> StakingHash <$> shrink cred + StakingPtr i j k -> + [StakingPtr i' j k | NonNegative i' <- shrink (NonNegative i)] ++ + [StakingPtr i j' k | NonNegative j' <- shrink (NonNegative j)] ++ + [StakingPtr i j k' | NonNegative k' <- shrink (NonNegative k)] instance CoArbitrary StakingCredential where {-# INLINEABLE coarbitrary #-} diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/DCert.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/DCert.hs index b9a25455649..7a58d782ad5 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/DCert.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/DCert.hs @@ -30,13 +30,12 @@ instance Arbitrary DCert where shrink = \case DCertDelegRegKey sc -> DCertDelegRegKey <$> shrink sc DCertDelegDeRegKey sc -> DCertDelegDeRegKey <$> shrink sc - -- PubKeyHash can't shrink, so we just pass it through, as otherwise, the - -- semantics of shrinking would mean the whole think can't shrink. - DCertDelegDelegate sc pkh -> DCertDelegDelegate <$> shrink sc <*> pure pkh - -- PubKeyHash can't shrink, so neither can this. - DCertPoolRegister _ _ -> [] - -- PubKeyHash can't shrink, so we just pass it through, as otherwise, the - -- semantics of shrinking would mean the whole think can't shrink. + DCertDelegDelegate sc pkh -> + [DCertDelegDelegate sc' pkh | sc' <- shrink sc] ++ + [DCertDelegDelegate sc pkh' | pkh' <- shrink pkh] + DCertPoolRegister pid pvfr -> + [DCertPoolRegister pid' pvfr | pid' <- shrink pid] ++ + [DCertPoolRegister pid pvfr' | pvfr' <- shrink pvfr] DCertPoolRetire pkh e -> DCertPoolRetire pkh . getNonNegative <$> shrink (NonNegative e) -- None of the other constructors have any data, so we don't shrink them. diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Interval.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Interval.hs index b9a05171038..b3d52a878b0 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Interval.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Interval.hs @@ -88,7 +88,9 @@ instance Arbitrary (LowerBound POSIXTime) where {-# INLINEABLE shrink #-} shrink (LowerBound e c) = case e of - Finite _ -> LowerBound <$> shrink e <*> shrink c + Finite _ -> + [LowerBound e' c | e' <- shrink e] ++ + [LowerBound e c' | c' <- shrink c] -- Negative or positive infinity bounds can't really shrink sensibly _ -> [] @@ -121,7 +123,9 @@ instance Arbitrary (UpperBound POSIXTime) where {-# INLINEABLE shrink #-} shrink (UpperBound e c) = case e of - Finite _ -> UpperBound <$> shrink e <*> shrink c + Finite _ -> + [UpperBound e' c | e' <- shrink e] ++ + [UpperBound e c' | c' <- shrink c] -- Negative or positive infinity bounds can't really shrink sensibly _ -> [] diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Scripts.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Scripts.hs index b04ea4b0b2c..7b8cd0a5ad4 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Scripts.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Scripts.hs @@ -46,8 +46,6 @@ instance Function RedeemerHash where {-# INLINEABLE function #-} function = functionMap coerce RedeemerHash - --- | BLAKE2b-244 hash. This does not shrink. deriving via Blake2b244Hash instance Arbitrary ScriptHash deriving via Blake2b244Hash instance CoArbitrary ScriptHash diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Tx.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Tx.hs index 15178033cb6..48d6fb361fc 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Tx.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Tx.hs @@ -31,7 +31,8 @@ instance Arbitrary TxOutRef where {-# INLINEABLE shrink #-} shrink (TxOutRef tid ix) = - TxOutRef <$> shrink tid <*> (fmap getNonNegative . shrink . NonNegative $ ix) + [TxOutRef tid' ix | tid' <- shrink tid] ++ + [TxOutRef tid ix' | NonNegative ix' <- shrink (NonNegative ix)] instance CoArbitrary TxOutRef where {-# INLINEABLE coarbitrary #-} @@ -52,11 +53,10 @@ instance Arbitrary TxOut where <*> arbitrary -- maybe datum hash {-# INLINEABLE shrink #-} - shrink (TxOut addr val mdh) = do - addr' <- shrink addr - val' <- Value.getUtxoValue <$> shrink (Value.UTxOValue val) - mdh' <- shrink mdh - pure . TxOut addr' val' $ mdh' + shrink (TxOut addr val mdh) = + [TxOut addr' val mdh | addr' <- shrink addr] ++ + [TxOut addr val' mdh | Value.UTxOValue val' <- shrink (Value.UTxOValue val)] ++ + [TxOut addr val mdh' | mdh' <- shrink mdh] instance CoArbitrary TxOut where {-# INLINEABLE coarbitrary #-} diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V2/Contexts.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V2/Contexts.hs index a55cd4cde90..27e43628e56 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V2/Contexts.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V2/Contexts.hs @@ -25,7 +25,8 @@ instance Arbitrary TxInInfo where {-# INLINEABLE shrink #-} shrink (TxInInfo outref resolved) = - TxInInfo <$> shrink outref <*> shrink resolved + [TxInInfo outref' resolved | outref' <- shrink outref] ++ + [TxInInfo outref resolved' | resolved' <- shrink resolved] instance CoArbitrary TxInInfo where {-# INLINEABLE coarbitrary #-} @@ -58,20 +59,31 @@ instance Arbitrary TxInfo where <*> arbitrary -- tid {-# INLINEABLE shrink #-} - shrink (TxInfo ins routs outs fee mint dcert wdrl validRange sigs reds dats tid) = do - NonEmpty ins' <- shrink (NonEmpty ins) - routs' <- shrink routs - NonEmpty outs' <- shrink (NonEmpty outs) - Value.FeeValue fee' <- shrink (Value.FeeValue fee) - Value.ZeroAdaValue mint' <- shrink (Value.ZeroAdaValue mint) - dcert' <- shrink dcert - wdrl' <- shrink wdrl - validRange' <- shrink validRange - sigs' <- Set.toList <$> shrink (Set.fromList sigs) - reds' <- shrink reds - dats' <- shrink dats - tid' <- shrink tid - pure . TxInfo ins' routs' outs' fee' mint' dcert' wdrl' validRange' sigs' reds' dats' $ tid' + shrink (TxInfo ins routs outs fee mint dcert wdrl validRange sigs reds dats tid) = + [TxInfo ins' routs outs fee mint dcert wdrl validRange sigs reds dats tid + | NonEmpty ins' <- shrink (NonEmpty ins)] ++ + [TxInfo ins routs' outs fee mint dcert wdrl validRange sigs reds dats tid + | routs' <- shrink routs] ++ + [TxInfo ins routs outs' fee mint dcert wdrl validRange sigs reds dats tid + | outs' <- shrink outs] ++ + [TxInfo ins routs outs fee' mint dcert wdrl validRange sigs reds dats tid + | Value.FeeValue fee' <- shrink (Value.FeeValue fee)] ++ + [TxInfo ins routs outs fee mint' dcert wdrl validRange sigs reds dats tid + | Value.ZeroAdaValue mint' <- shrink (Value.ZeroAdaValue mint)] ++ + [TxInfo ins routs outs fee mint dcert' wdrl validRange sigs reds dats tid + | dcert' <- shrink dcert] ++ + [TxInfo ins routs outs fee mint dcert wdrl' validRange sigs reds dats tid + | wdrl' <- shrink wdrl] ++ + [TxInfo ins routs outs fee mint dcert wdrl validRange' sigs reds dats tid + | validRange' <- shrink validRange] ++ + [TxInfo ins routs outs fee mint dcert wdrl validRange sigs' reds dats tid + | sigs' <- Set.toList <$> shrink (Set.fromList sigs)] ++ + [TxInfo ins routs outs fee mint dcert wdrl validRange sigs reds' dats tid + | reds' <- shrink reds] ++ + [TxInfo ins routs outs fee mint dcert wdrl validRange sigs reds dats' tid + | dats' <- shrink dats] ++ + [TxInfo ins routs outs fee mint dcert wdrl validRange sigs reds dats tid' + | tid' <- shrink tid] instance CoArbitrary TxInfo where {-# INLINEABLE coarbitrary #-} diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V2/Tx.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V2/Tx.hs index bf8490d869b..9dcfd18ff37 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V2/Tx.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V2/Tx.hs @@ -25,11 +25,10 @@ instance Arbitrary OutputDatum where ] {-# INLINEABLE shrink #-} - -- We only shrink the OutputDatum case, since the others wouldn't shrink - -- anyway. shrink = \case + NoOutputDatum -> [] + OutputDatumHash h -> OutputDatumHash <$> shrink h OutputDatum d -> OutputDatum <$> shrink d - _ -> [] instance CoArbitrary OutputDatum where {-# INLINEABLE coarbitrary #-} @@ -66,11 +65,10 @@ instance Arbitrary TxOut where {-# INLINEABLE shrink #-} shrink (TxOut addr val od msh) = - TxOut - <$> shrink addr - <*> (Value.getUtxoValue <$> shrink (Value.UTxOValue val)) - <*> shrink od - <*> shrink msh + [TxOut addr' val od msh | addr' <- shrink addr] ++ + [TxOut addr val' od msh | val' <- Value.getUtxoValue <$> shrink (Value.UTxOValue val)] ++ + [TxOut addr val od' msh | od' <- shrink od] ++ + [TxOut addr val od msh' | msh' <- shrink msh] instance CoArbitrary TxOut where {-# INLINEABLE coarbitrary #-} diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V3/Contexts.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V3/Contexts.hs index 00090ebc01f..f0f6c0c3c76 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V3/Contexts.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V3/Contexts.hs @@ -125,9 +125,11 @@ instance Arbitrary Delegatee where {-# INLINEABLE shrink #-} shrink = \case - DelegStake _ -> [] -- PubKeyHashes don't shrink anyway + DelegStake pkh -> DelegStake <$> shrink pkh DelegVote drep -> DelegVote <$> shrink drep - DelegStakeVote pkh drep -> DelegStakeVote pkh <$> shrink drep + DelegStakeVote pkh drep -> + [DelegStakeVote pkh' drep | pkh' <- shrink pkh] ++ + [DelegStakeVote pkh drep' | drep' <- shrink drep] instance CoArbitrary Delegatee where {-# INLINEABLE coarbitrary #-} @@ -178,24 +180,34 @@ instance Arbitrary TxCert where {-# INLINEABLE shrink #-} shrink = \case TxCertRegStaking cred mLovelace -> - TxCertRegStaking <$> shrink cred <*> shrink mLovelace + [TxCertRegStaking cred' mLovelace | cred' <- shrink cred] ++ + [TxCertRegStaking cred mLovelace' | mLovelace' <- shrink mLovelace] TxCertUnRegStaking cred mLovelace -> - TxCertUnRegStaking <$> shrink cred <*> shrink mLovelace + [TxCertUnRegStaking cred' mLovelace | cred' <- shrink cred] ++ + [TxCertUnRegStaking cred mLovelace' | mLovelace' <- shrink mLovelace] TxCertDelegStaking cred deleg -> - TxCertDelegStaking <$> shrink cred <*> shrink deleg + [TxCertDelegStaking cred' deleg | cred' <- shrink cred] ++ + [TxCertDelegStaking cred deleg' | deleg' <- shrink deleg] TxCertRegDeleg cred deleg lovelace -> - TxCertRegDeleg <$> shrink cred <*> shrink deleg <*> shrink lovelace + [TxCertRegDeleg cred' deleg lovelace | cred' <- shrink cred] ++ + [TxCertRegDeleg cred deleg' lovelace | deleg' <- shrink deleg] ++ + [TxCertRegDeleg cred deleg lovelace' | lovelace' <- shrink lovelace] TxCertRegDRep drepCred lovelace -> - TxCertRegDRep <$> shrink drepCred <*> shrink lovelace + [TxCertRegDRep drepCred' lovelace | drepCred' <- shrink drepCred] ++ + [TxCertRegDRep drepCred lovelace' | lovelace' <- shrink lovelace] TxCertUpdateDRep drepCred -> TxCertUpdateDRep <$> shrink drepCred TxCertUnRegDRep drepCred lovelace -> - TxCertUnRegDRep <$> shrink drepCred <*> shrink lovelace - -- PubKeyHash doesn't shrink, so we don't bother either - TxCertPoolRegister _ _ -> [] + [TxCertUnRegDRep drepCred' lovelace | drepCred' <- shrink drepCred] ++ + [TxCertUnRegDRep drepCred lovelace' | lovelace' <- shrink lovelace] + TxCertPoolRegister pkh vrf -> + [TxCertPoolRegister pkh' vrf | pkh' <- shrink pkh] ++ + [TxCertPoolRegister pkh vrf' | vrf' <- shrink vrf] TxCertPoolRetire pkh epoch -> - TxCertPoolRetire pkh . getPositive <$> shrink (Positive epoch) + [TxCertPoolRetire pkh' epoch | pkh' <- shrink pkh] ++ + [TxCertPoolRetire pkh epoch' | epoch' <- shrink epoch] TxCertAuthHotCommittee cold hot -> - TxCertAuthHotCommittee <$> shrink cold <*> shrink hot + [TxCertAuthHotCommittee cold' hot | cold' <- shrink cold] ++ + [TxCertAuthHotCommittee cold hot' | hot' <- shrink hot] TxCertResignColdCommittee cold -> TxCertResignColdCommittee <$> shrink cold instance CoArbitrary TxCert where @@ -352,8 +364,7 @@ instance Arbitrary Voter where shrink = \case CommitteeVoter hcc -> CommitteeVoter <$> shrink hcc DRepVoter drepCred -> DRepVoter <$> shrink drepCred - -- PubKeyHashes don't shrink so we don't bother either - _ -> [] + StakePoolVoter pkh -> StakePoolVoter <$> shrink pkh instance CoArbitrary Voter where {-# INLINEABLE coarbitrary #-} @@ -427,10 +438,11 @@ instance Arbitrary GovernanceActionId where GovernanceActionId <$> arbitrary <*> (getNonNegative <$> arbitrary) + {-# INLINEABLE shrink #-} shrink (GovernanceActionId tid ix) = - -- Hashes don't shrink, so we don't bother either - GovernanceActionId tid . getNonNegative <$> shrink (NonNegative ix) + [GovernanceActionId tid' ix | tid' <- shrink tid] ++ + [GovernanceActionId tid ix' | NonNegative ix' <- shrink (NonNegative ix)] instance CoArbitrary GovernanceActionId where {-# INLINEABLE coarbitrary #-} @@ -454,6 +466,7 @@ instance Arbitrary Committee where num <- chooseInt (1, 100) let quorum = Ratio.unsafeRatio (fromIntegral num) 100 pure . Committee committee $ quorum + {-# INLINEABLE shrink #-} shrink (Committee committee quorum) = do committee' <- liftShrink (fmap getPositive . shrink . Positive) committee @@ -498,11 +511,11 @@ instance Arbitrary ProtocolVersion where NonNegative major <- arbitrary NonNegative minor <- arbitrary pure . ProtocolVersion major $ minor + {-# INLINEABLE shrink #-} - shrink (ProtocolVersion major minor) = do - NonNegative major' <- shrink (NonNegative major) - NonNegative minor' <- shrink (NonNegative minor) - pure . ProtocolVersion major' $ minor' + shrink (ProtocolVersion major minor) = + [ProtocolVersion major' minor | NonNegative major' <- shrink (NonNegative major)] ++ + [ProtocolVersion major minor' | NonNegative minor' <- shrink (NonNegative minor)] instance CoArbitrary ProtocolVersion where {-# INLINEABLE coarbitrary #-} @@ -557,25 +570,21 @@ instance Arbitrary GovernanceAction where {-# INLINEABLE shrink #-} shrink = \case ParameterChange mgid cp msh -> - ParameterChange - <$> shrink mgid - <*> shrink cp - <*> shrink msh + [ParameterChange mgid' cp msh | mgid' <- shrink mgid] ++ + [ParameterChange mgid cp' msh | cp' <- shrink cp] ++ + [ParameterChange mgid cp msh' | msh' <- shrink msh] HardForkInitiation mgid v -> - HardForkInitiation - <$> shrink mgid - <*> shrink v + [HardForkInitiation mgid' v | mgid' <- shrink mgid] ++ + [HardForkInitiation mgid v' | v' <- shrink v] TreasuryWithdrawals wdrls msh -> - TreasuryWithdrawals - <$> shrink wdrls - <*> shrink msh + [TreasuryWithdrawals wdrls' msh | wdrls' <- shrink wdrls] ++ + [TreasuryWithdrawals wdrls msh' | msh' <- shrink msh] NoConfidence msh -> NoConfidence <$> shrink msh -- No quorum shrinking - UpdateCommittee mgid creds mems quorum -> do - mgid' <- shrink mgid - creds' <- shrink creds - mems' <- shrink mems - pure . UpdateCommittee mgid' creds' mems' $ quorum + UpdateCommittee mgid creds mems quorum -> + [UpdateCommittee mgid' creds mems quorum | mgid' <- shrink mgid] ++ + [UpdateCommittee mgid creds' mems quorum | creds' <- shrink creds] ++ + [UpdateCommittee mgid creds mems' quorum | mems' <- shrink mems] NewConstitution mgid c -> NewConstitution <$> shrink mgid <*> shrink c _ -> [] @@ -682,7 +691,9 @@ instance Arbitrary ProposalProcedure where {-# INLINEABLE shrink #-} shrink (ProposalProcedure dep raddr ga) = - ProposalProcedure <$> shrink dep <*> shrink raddr <*> shrink ga + [ProposalProcedure dep' raddr ga | dep' <- shrink dep] ++ + [ProposalProcedure dep raddr' ga | raddr' <- shrink raddr] ++ + [ProposalProcedure dep raddr ga' | ga' <- shrink ga] instance CoArbitrary ProposalProcedure where {-# INLINEABLE coarbitrary #-} @@ -707,9 +718,11 @@ instance Function ProposalProcedure where instance Arbitrary TxOutRef where {-# INLINEABLE arbitrary #-} arbitrary = TxOutRef <$> arbitrary <*> (getNonNegative <$> arbitrary) + {-# INLINEABLE shrink #-} shrink (TxOutRef tid ix) = - TxOutRef <$> shrink tid <*> (fmap getNonNegative . shrink . NonNegative $ ix) + [TxOutRef tid' ix | tid' <- shrink tid] ++ + [TxOutRef tid ix' | NonNegative ix' <- shrink (NonNegative ix)] instance CoArbitrary TxOutRef where {-# INLINEABLE coarbitrary #-} @@ -738,15 +751,13 @@ instance Arbitrary ScriptPurpose where Minting cs -> Minting <$> shrink cs Spending txo -> Spending <$> shrink txo Rewarding cred -> Rewarding <$> shrink cred - Certifying ix cert -> do - cert' <- shrink cert - NonNegative ix' <- shrink (NonNegative ix) - pure . Certifying ix' $ cert' + Certifying ix cert -> + [Certifying ix' cert | NonNegative ix' <- shrink (NonNegative ix)] ++ + [Certifying ix cert' | cert' <- shrink cert] Voting voter -> Voting <$> shrink voter - Proposing ix pp -> do - pp' <- shrink pp - NonNegative ix' <- shrink (NonNegative ix) - pure . Proposing ix' $ pp' + Proposing ix pp -> + [Proposing ix' pp | NonNegative ix' <- shrink (NonNegative ix)] ++ + [Proposing ix pp' | pp' <- shrink pp] instance CoArbitrary ScriptPurpose where {-# INLINEABLE coarbitrary #-} @@ -823,15 +834,17 @@ instance Arbitrary ScriptInfo where {-# INLINEABLE shrink #-} shrink = \case MintingScript cs -> MintingScript <$> shrink cs - SpendingScript outRef mdat -> SpendingScript <$> shrink outRef <*> shrink mdat + SpendingScript outRef mdat -> + [SpendingScript outRef' mdat | outRef' <- shrink outRef] ++ + [SpendingScript outRef mdat' | mdat' <- shrink mdat] RewardingScript cred -> RewardingScript <$> shrink cred - CertifyingScript ix cert -> do - NonNegative ix' <- shrink (NonNegative ix) - CertifyingScript ix' <$> shrink cert + CertifyingScript ix cert -> + [CertifyingScript ix' cert | NonNegative ix' <- shrink (NonNegative ix)] ++ + [CertifyingScript ix cert' | cert' <- shrink cert] VotingScript voter -> VotingScript <$> shrink voter - ProposingScript ix pp -> do - NonNegative ix' <- shrink (NonNegative ix) - ProposingScript ix' <$> shrink pp + ProposingScript ix pp -> + [ProposingScript ix' pp | NonNegative ix' <- shrink (NonNegative ix)] ++ + [ProposingScript ix pp' | pp' <- shrink pp] instance CoArbitrary ScriptInfo where {-# INLINEABLE coarbitrary #-} @@ -883,7 +896,8 @@ instance Arbitrary TxInInfo where {-# INLINEABLE shrink #-} shrink (TxInInfo toutref tout) = - TxInInfo <$> shrink toutref <*> shrink tout + [TxInInfo toutref' tout | toutref' <- shrink toutref] ++ + [TxInInfo toutref tout' | tout' <- shrink tout] instance CoArbitrary TxInInfo where {-# INLINEABLE coarbitrary #-} @@ -925,41 +939,39 @@ instance Arbitrary TxInfo where $ tDonation {-# INLINEABLE shrink #-} - shrink (TxInfo ins routs outs fee mint cert wdrl val sigs rds dats tid votes pps cur don) = do - NonEmpty ins' <- shrink (NonEmpty ins) - routs' <- shrink routs - NonEmpty outs' <- shrink (NonEmpty outs) - fee' <- shrink fee - mint' <- shrink mint - cert' <- shrink cert - wdrl' <- shrink wdrl - valid' <- shrink val - sigs' <- shrink sigs - reds' <- shrink rds - dats' <- shrink dats - tid' <- shrink tid - votes' <- shrink votes - pps' <- shrink pps - currT' <- shrink cur - tDonation' <- shrink don - pure $ - TxInfo - ins' - routs' - outs' - fee' - mint' - cert' - wdrl' - valid' - sigs' - reds' - dats' - tid' - votes' - pps' - currT' - tDonation' + shrink (TxInfo ins routs outs fee mint cert wdrl val sigs rds dats tid votes pps cur don) = + [TxInfo ins' routs outs fee mint cert wdrl val sigs rds dats tid votes pps cur don + | NonEmpty ins' <- shrink (NonEmpty ins)] ++ + [TxInfo ins routs' outs fee mint cert wdrl val sigs rds dats tid votes pps cur don + | routs' <- shrink routs] ++ + [TxInfo ins routs outs' fee mint cert wdrl val sigs rds dats tid votes pps cur don + | NonEmpty outs' <- shrink (NonEmpty outs)] ++ + [TxInfo ins routs outs fee' mint cert wdrl val sigs rds dats tid votes pps cur don + | fee' <- shrink fee] ++ + [TxInfo ins routs outs fee mint' cert wdrl val sigs rds dats tid votes pps cur don + | mint' <- shrink mint] ++ + [TxInfo ins routs outs fee mint cert' wdrl val sigs rds dats tid votes pps cur don + | cert' <- shrink cert] ++ + [TxInfo ins routs outs fee mint cert wdrl' val sigs rds dats tid votes pps cur don + | wdrl' <- shrink wdrl] ++ + [TxInfo ins routs outs fee mint cert wdrl val' sigs rds dats tid votes pps cur don + | val' <- shrink val] ++ + [TxInfo ins routs outs fee mint cert wdrl val sigs' rds dats tid votes pps cur don + | sigs' <- shrink sigs] ++ + [TxInfo ins routs outs fee mint cert wdrl val sigs rds' dats tid votes pps cur don + | rds' <- shrink rds] ++ + [TxInfo ins routs outs fee mint cert wdrl val sigs rds dats' tid votes pps cur don + | dats' <- shrink dats] ++ + [TxInfo ins routs outs fee mint cert wdrl val sigs rds dats tid' votes pps cur don + | tid' <- shrink tid] ++ + [TxInfo ins routs outs fee mint cert wdrl val sigs rds dats tid votes' pps cur don + | votes' <- shrink votes] ++ + [TxInfo ins routs outs fee mint cert wdrl val sigs rds dats tid votes pps' cur don + | pps' <- shrink pps] ++ + [TxInfo ins routs outs fee mint cert wdrl val sigs rds dats tid votes pps cur' don + | cur' <- shrink cur] ++ + [TxInfo ins routs outs fee mint cert wdrl val sigs rds dats tid votes pps cur don' + | don' <- shrink don] instance CoArbitrary TxInfo where {-# INLINEABLE coarbitrary #-} @@ -1043,7 +1055,9 @@ instance Arbitrary ScriptContext where {-# INLINEABLE shrink #-} shrink (ScriptContext tinfo red sinfo) = - ScriptContext <$> shrink tinfo <*> shrink red <*> shrink sinfo + [ScriptContext tinfo' red sinfo | tinfo' <- shrink tinfo] ++ + [ScriptContext tinfo red' sinfo | red' <- shrink red] ++ + [ScriptContext tinfo red sinfo' | sinfo' <- shrink sinfo] instance CoArbitrary ScriptContext where {-# INLINEABLE coarbitrary #-} diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V3/Tx.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V3/Tx.hs index ba50bc26fc0..663fe4ced00 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V3/Tx.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V3/Tx.hs @@ -25,7 +25,8 @@ instance Arbitrary TxOutRef where {-# INLINEABLE shrink #-} shrink (TxOutRef tid ix) = - TxOutRef <$> shrink tid <*> (fmap getNonNegative . shrink . NonNegative $ ix) + [TxOutRef tid' ix | tid' <- shrink tid] ++ + [TxOutRef tid ix' | ix' <- fmap getNonNegative . shrink . NonNegative $ ix] instance CoArbitrary TxOutRef where {-# INLINEABLE coarbitrary #-} From 076343dfbae174a8db559fa7aa10e7bf5a57e3ce Mon Sep 17 00:00:00 2001 From: t4ccer Date: Wed, 13 Nov 2024 15:54:12 -0700 Subject: [PATCH 11/16] Implement `Arbitrary BuiltinData` in terms of `Data` --- .../PlutusLedgerApi/Test/Orphans/PlutusTx.hs | 57 +++---------------- 1 file changed, 7 insertions(+), 50 deletions(-) diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/PlutusTx.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/PlutusTx.hs index c8e2578022f..0f78620e5e3 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/PlutusTx.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/PlutusTx.hs @@ -21,18 +21,18 @@ module PlutusLedgerApi.Test.Orphans.PlutusTx ( import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.Coerce (coerce) -import Data.Kind (Type) import Data.Set qualified as Set import Data.Word (Word8) +import PlutusCore.Generators.QuickCheck.Builtin () import PlutusLedgerApi.Test.Common.QuickCheck.Utils (unSizedByteString) +import PlutusTx qualified import PlutusTx.AssocMap qualified as AssocMap import PlutusTx.Builtins qualified as Builtins import PlutusTx.Prelude qualified as PlutusTx import Prettyprinter (Pretty) import Test.QuickCheck (Arbitrary (arbitrary, shrink), Arbitrary1 (liftArbitrary, liftShrink), - CoArbitrary (coarbitrary), Function (function), Gen, - NonNegative (NonNegative), functionMap, getNonNegative, liftArbitrary, - oneof, scale, shuffle, sized, variant) + CoArbitrary (coarbitrary), Function (function), functionMap, liftArbitrary, + shuffle, variant) import Test.QuickCheck.Instances.ByteString () instance Arbitrary PlutusTx.BuiltinByteString where @@ -96,53 +96,10 @@ deriving via PlutusTx.BuiltinByteString instance CoArbitrary Blake2b256Hash getBlake2b256Hash :: Blake2b256Hash -> PlutusTx.BuiltinByteString getBlake2b256Hash = coerce -{- | This is a very general instance, able to produce 'PlutusTx.BuiltinData' of -basically any shape. You probably want something more focused than this. --} +-- cannot derive via because BuiltinData is not a newtype instance Arbitrary PlutusTx.BuiltinData where - {-# INLINEABLE arbitrary #-} - arbitrary = sized $ \size -> go size - where - scaleDown :: forall (a :: Type). Gen a -> Gen a - scaleDown = scale (`quot` 4) - go :: Int -> Gen PlutusTx.BuiltinData - go size - | size <= 0 = oneof [genB, genI] - | otherwise = oneof [genB, genI, genConstr, genList, genMap] - genB :: Gen PlutusTx.BuiltinData - genB = Builtins.mkB <$> arbitrary - genI :: Gen PlutusTx.BuiltinData - genI = Builtins.mkI <$> arbitrary - genConstr :: Gen PlutusTx.BuiltinData - genConstr = - Builtins.mkConstr . getNonNegative - <$> arbitrary - <*> scaleDown (liftArbitrary arbitrary) - genList :: Gen PlutusTx.BuiltinData - genList = - Builtins.mkList <$> scaleDown (liftArbitrary arbitrary) - genMap :: Gen PlutusTx.BuiltinData - genMap = - Builtins.mkMap <$> scaleDown (liftArbitrary ((,) <$> arbitrary <*> arbitrary)) - {-# INLINEABLE shrink #-} - shrink dat = - Builtins.matchData - dat - shrinkConstr - shrinkMap - shrinkList - (fmap (Builtins.mkI . getNonNegative) . shrink . NonNegative) - (fmap Builtins.mkB . shrink) - where - shrinkConstr :: Integer -> [PlutusTx.BuiltinData] -> [PlutusTx.BuiltinData] - shrinkConstr ix dats = do - NonNegative ix' <- shrink (NonNegative ix) - dats' <- shrink dats - pure . Builtins.mkConstr ix' $ dats' - shrinkMap :: [(PlutusTx.BuiltinData, PlutusTx.BuiltinData)] -> [PlutusTx.BuiltinData] - shrinkMap kvs = Builtins.mkMap <$> shrink kvs - shrinkList :: [PlutusTx.BuiltinData] -> [PlutusTx.BuiltinData] - shrinkList ell = Builtins.mkList <$> shrink ell + arbitrary = PlutusTx.dataToBuiltinData <$> arbitrary + shrink = fmap PlutusTx.dataToBuiltinData . shrink . PlutusTx.builtinDataToData instance CoArbitrary PlutusTx.BuiltinData where {-# INLINEABLE coarbitrary #-} From dbd6dac5efb30dd19cf2638e5c9dcc12bd4685ef Mon Sep 17 00:00:00 2001 From: t4ccer Date: Wed, 13 Nov 2024 16:15:56 -0700 Subject: [PATCH 12/16] Shrink `Extended` towards `Finite 0` --- .../testlib/PlutusLedgerApi/Test/Orphans/V1/Interval.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Interval.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Interval.hs index b3d52a878b0..6a85cd3310b 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Interval.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Interval.hs @@ -35,14 +35,17 @@ instance Arbitrary1 Extended where PosInf -> [] {- | This makes use of the 'Arbitrary1' instance of 'Extended' internally, -and thus is subject to the same caveats. +and thus is subject to the same caveats, but shrinks towards 'Finite 0' -} -instance Arbitrary a => Arbitrary (Extended a) where +instance (Num a, Arbitrary a) => Arbitrary (Extended a) where {-# INLINEABLE arbitrary #-} arbitrary = liftArbitrary arbitrary {-# INLINEABLE shrink #-} - shrink = liftShrink shrink + shrink = \case + NegInf -> [Finite 0] + Finite x -> Finite <$> shrink x + PosInf -> [Finite 0] instance CoArbitrary a => CoArbitrary (Extended a) where {-# INLINEABLE coarbitrary #-} From 60ebef74406240f22a428fb16a137be0198fdd4c Mon Sep 17 00:00:00 2001 From: t4ccer Date: Wed, 13 Nov 2024 16:16:15 -0700 Subject: [PATCH 13/16] Generate arbitrary closure bounds at infinities Such intervals are provided by cardano-node, see: --- .../Test/Orphans/V1/Interval.hs | 30 +++++++------------ 1 file changed, 10 insertions(+), 20 deletions(-) diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Interval.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Interval.hs index 6a85cd3310b..a39966b147e 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Interval.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Interval.hs @@ -80,22 +80,17 @@ of this instance. -} instance Arbitrary (LowerBound POSIXTime) where {-# INLINEABLE arbitrary #-} - arbitrary = do - e <- arbitrary - case e of - -- For a finite bound, it makes sense to talk about it being open or - -- closed. - Finite _ -> LowerBound e <$> arbitrary - -- If the bound is infinite, it _must_ be open. - _ -> pure . LowerBound e $ False + -- While it seem like there is no sense in closed bounds at infinities, cardano-node actually + -- produces such intervals in TxInfo so we generate them as well + arbitrary = LowerBound <$> arbitrary <*> arbitrary {-# INLINEABLE shrink #-} shrink (LowerBound e c) = case e of Finite _ -> [LowerBound e' c | e' <- shrink e] ++ [LowerBound e c' | c' <- shrink c] - -- Negative or positive infinity bounds can't really shrink sensibly - _ -> [] + PosInf -> [LowerBound e c' | c' <- shrink c] + NegInf -> [LowerBound e c' | c' <- shrink c] instance CoArbitrary a => CoArbitrary (LowerBound a) where {-# INLINEABLE coarbitrary #-} @@ -115,22 +110,17 @@ of this instance. -} instance Arbitrary (UpperBound POSIXTime) where {-# INLINEABLE arbitrary #-} - arbitrary = do - e <- arbitrary - case e of - -- For a finite bound, it makes sense to talk about it being open or - -- closed. - Finite _ -> UpperBound e <$> arbitrary - -- If the bound is infinite, it _must_ be open. - _ -> pure . UpperBound e $ False + -- While it seem like there is no sense in closed bounds at infinities, cardano-node actually + -- produces such intervals in TxInfo so we generate them as well + arbitrary = UpperBound <$> arbitrary <*> arbitrary {-# INLINEABLE shrink #-} shrink (UpperBound e c) = case e of Finite _ -> [UpperBound e' c | e' <- shrink e] ++ [UpperBound e c' | c' <- shrink c] - -- Negative or positive infinity bounds can't really shrink sensibly - _ -> [] + PosInf -> [UpperBound e c' | c' <- shrink c] + NegInf -> [UpperBound e c' | c' <- shrink c] instance CoArbitrary a => CoArbitrary (UpperBound a) where {-# INLINEABLE coarbitrary #-} From e0771401ff17cf7cbb8ddde01a55103fb42055c0 Mon Sep 17 00:00:00 2001 From: t4ccer Date: Wed, 13 Nov 2024 19:07:43 -0700 Subject: [PATCH 14/16] Generate large lovelace entries in `FeeValue` --- .../PlutusLedgerApi/Test/Orphans/V1/Value.hs | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Value.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Value.hs index 1374ef04833..93baa048004 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Value.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Value.hs @@ -29,10 +29,10 @@ import PlutusLedgerApi.V1.Value (AssetClass (AssetClass), CurrencySymbol (Curren import PlutusTx.AssocMap qualified as AssocMap import PlutusTx.Prelude qualified as PlutusTx import Test.QuickCheck (Arbitrary (arbitrary, shrink), Arbitrary1 (liftArbitrary, liftShrink), - CoArbitrary, Function (function), Gen, NonEmptyList (NonEmpty), - NonZero (NonZero), Positive (Positive), chooseBoundedIntegral, chooseInt, - frequency, functionMap, getNonEmpty, getNonZero, getPositive, resize, scale, - sized, vectorOf) + CoArbitrary, Function (function), Gen, Large (getLarge), + NonEmptyList (NonEmpty), NonZero (NonZero), Positive (Positive), + chooseBoundedIntegral, chooseInt, frequency, functionMap, getNonEmpty, + getNonZero, getPositive, resize, scale, sized, vectorOf) deriving via (CurrencySymbol, TokenName) instance Arbitrary AssetClass @@ -304,7 +304,12 @@ newtype FeeValue = FeeValue Value instance Arbitrary FeeValue where {-# INLINEABLE arbitrary #-} - arbitrary = FeeValue . singleton adaSymbol adaToken . getPositive <$> arbitrary + arbitrary = FeeValue + . singleton adaSymbol adaToken + . fromIntegral @Int + . getLarge + . getPositive + <$> arbitrary {-# INLINEABLE shrink #-} shrink (FeeValue v) = From 655c7291a2b346f7d74151fd55c6e14789f9c032 Mon Sep 17 00:00:00 2001 From: t4ccer Date: Wed, 13 Nov 2024 20:23:16 -0700 Subject: [PATCH 15/16] Fix post-merge duplicate Arbitrary instances --- .../test-plugin/Spec/MintValue/V3.hs | 1 + .../Spec/Value/WithCurrencySymbol.hs | 24 +++---------------- 2 files changed, 4 insertions(+), 21 deletions(-) diff --git a/plutus-ledger-api/test-plugin/Spec/MintValue/V3.hs b/plutus-ledger-api/test-plugin/Spec/MintValue/V3.hs index 72dd9c26698..78a0a6c6711 100644 --- a/plutus-ledger-api/test-plugin/Spec/MintValue/V3.hs +++ b/plutus-ledger-api/test-plugin/Spec/MintValue/V3.hs @@ -18,6 +18,7 @@ module Spec.MintValue.V3 where import PlutusTx.Prelude import Data.Coerce (coerce) +import PlutusLedgerApi.Test.QuickCheck () import PlutusLedgerApi.Test.V1.Value () import PlutusLedgerApi.Test.V3.MintValue () import PlutusLedgerApi.V1.Value (AssetClass (..), Value (..), flattenValue) diff --git a/plutus-ledger-api/test-plugin/Spec/Value/WithCurrencySymbol.hs b/plutus-ledger-api/test-plugin/Spec/Value/WithCurrencySymbol.hs index 68318948d78..cad3e377af6 100644 --- a/plutus-ledger-api/test-plugin/Spec/Value/WithCurrencySymbol.hs +++ b/plutus-ledger-api/test-plugin/Spec/Value/WithCurrencySymbol.hs @@ -18,13 +18,11 @@ module Spec.Value.WithCurrencySymbol where import PlutusTx.Prelude -import Data.ByteString (ByteString) -import PlutusCore.Generators.QuickCheck.Builtin (ArbitraryBuiltin (arbitraryBuiltin), shrinkBuiltin) +import PlutusLedgerApi.Test.QuickCheck () import PlutusLedgerApi.Test.V1.Value () import PlutusLedgerApi.Test.V3.MintValue () -import PlutusLedgerApi.V1.Value (CurrencySymbol (..), TokenName (..), Value (..), currencySymbol, - singleton, symbols, tokenName, unCurrencySymbol, - withCurrencySymbol) +import PlutusLedgerApi.V1.Value (CurrencySymbol (..), TokenName (..), Value (..), singleton, + symbols, withCurrencySymbol) import PlutusTx.AssocMap qualified as Map import PlutusTx.Code (CompiledCode, unsafeApplyCode) import PlutusTx.Lift (liftCodeDef) @@ -109,19 +107,3 @@ scaleTestsBy factor = cekProp :: CompiledCode Bool -> Property cekProp code = cekResultMatchesHaskellValue (compiledCodeToTerm code) (===) True - -instance Arbitrary CurrencySymbol where - arbitrary = Haskell.fmap currencySymbol (arbitraryBuiltin @ByteString) - shrink = - Haskell.fmap currencySymbol - . shrinkBuiltin - . fromBuiltin - . unCurrencySymbol - -instance Arbitrary TokenName where - arbitrary = Haskell.fmap tokenName (arbitraryBuiltin @ByteString) - shrink = - Haskell.fmap tokenName - . shrinkBuiltin - . fromBuiltin - . unTokenName From cdcac037a1b9e1b1597f56e82d8544db1222e181 Mon Sep 17 00:00:00 2001 From: t4ccer Date: Thu, 14 Nov 2024 21:56:03 -0700 Subject: [PATCH 16/16] Fix V3.MintValue generator This is a backport of --- .../PlutusLedgerApi/Test/Orphans/V3/MintValue.hs | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V3/MintValue.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V3/MintValue.hs index e024704d491..c21ff32fca7 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V3/MintValue.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V3/MintValue.hs @@ -32,8 +32,12 @@ instance Arbitrary MintValue where let keyList = Set.toList keySet -- For each key, generate a set of token name keys that aren't Ada keyVals <- traverse (scale (`quot` 8) . mkInner) keyList + + -- It is possible to generate positive and negative quantity of the same asset so we have to + -- prune zeros despite using NonZero generator pure . getValue + . pruneZeros . foldMap (\(cs, vals) -> foldMap (uncurry (Value.singleton cs)) vals) $ keyVals where @@ -75,3 +79,15 @@ deriving via Value instance CoArbitrary MintValue instance Function MintValue where {-# INLINEABLE function #-} function = functionMap coerce UnsafeMintValue + +pruneZeros :: Value.Value -> Value.Value +pruneZeros (Value.Value assets) = + Value.Value $ + AssocMap.unsafeFromList $ + filter (not . AssocMap.null . snd) $ + AssocMap.toList + (AssocMap.mapMaybe (assocMapNonEmpty . filter ((/= 0) . snd) . AssocMap.toList) assets) + where + assocMapNonEmpty :: [(k, v)] -> Maybe (AssocMap.Map k v) + assocMapNonEmpty [] = Nothing + assocMapNonEmpty lst = Just $ AssocMap.unsafeFromList lst