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..c4ba7fabe4a --- /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.QuickCheck` instead. + +### Added + +- `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 3dc37f830c6..5ce53c1181e 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.QuickCheck PlutusLedgerApi.Test.Scripts PlutusLedgerApi.Test.V1.Data.EvaluationContext PlutusLedgerApi.Test.V1.Data.Value @@ -136,6 +137,28 @@ 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 + 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 , base >=4.9 && <5 @@ -149,6 +172,7 @@ library plutus-ledger-api-testlib , plutus-tx ^>=1.36 , prettyprinter , QuickCheck + , quickcheck-instances , serialise , text 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 diff --git a/plutus-ledger-api/test/Spec/V1/Data/Value.hs b/plutus-ledger-api/test/Spec/V1/Data/Value.hs index cb4b345a3fa..70027719b22 100644 --- a/plutus-ledger-api/test/Spec/V1/Data/Value.hs +++ b/plutus-ledger-api/test/Spec/V1/Data/Value.hs @@ -1,5 +1,6 @@ module Spec.V1.Data.Value where +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 34555c7d3ed..3182b74490a 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.QuickCheck () import PlutusLedgerApi.Test.V1.Value as Value import PlutusLedgerApi.V1 import PlutusTx.Numeric qualified as Numeric 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..3cfc381b8fb --- /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, Nat, 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 :: Nat) = 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 :: Nat). 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 :: Nat). + 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/PlutusTx.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/PlutusTx.hs new file mode 100644 index 00000000000..0f78620e5e3 --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/PlutusTx.hs @@ -0,0 +1,231 @@ +{-# 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, + UnsortedAssocMap, + getUnsortedAssocMap, + ) where + + +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.Coerce (coerce) +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), functionMap, liftArbitrary, + shuffle, 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) + +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 +getBlake2b244Hash = coerce + +-- Wrapper for BLAKE2b-256 hashes for convenience. +newtype Blake2b256Hash = Blake2b256Hash PlutusTx.BuiltinByteString + deriving (Eq, Ord) via PlutusTx.BuiltinByteString + deriving stock (Show) + +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 +getBlake2b256Hash = coerce + +-- cannot derive via because BuiltinData is not a newtype +instance Arbitrary PlutusTx.BuiltinData where + arbitrary = PlutusTx.dataToBuiltinData <$> arbitrary + shrink = fmap PlutusTx.dataToBuiltinData . shrink . PlutusTx.builtinDataToData + +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 + + +-- | 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/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..8d587dd05b5 --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Address.hs @@ -0,0 +1,35 @@ +{-# 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' scred | cred' <- shrink cred ] ++ + [ Address cred scred' | scred' <- 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..554371c129f --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Contexts.hs @@ -0,0 +1,202 @@ +{-# 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 tinfo' p | tinfo' <- shrink tinfo] ++ + [ScriptContext tinfo p' | p' <- 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 outref' resolved | outref' <- shrink outref] ++ + [TxInInfo outref resolved' | resolved' <- 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) = + [ 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 #-} + 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..336d2d17e7c --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Credential.hs @@ -0,0 +1,93 @@ +{-# 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 + ] + + {-# INLINEABLE shrink #-} + shrink = \case + PubKeyCredential pkh -> PubKeyCredential <$> shrink pkh + ScriptCredential sh -> ScriptCredential <$> shrink sh + +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 + 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 #-} + 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..7a58d782ad5 --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/DCert.hs @@ -0,0 +1,107 @@ +{-# 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 + 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. + _ -> [] + +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..a39966b147e --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Interval.hs @@ -0,0 +1,226 @@ +{-# 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, but shrinks towards 'Finite 0' +-} +instance (Num a, Arbitrary a) => Arbitrary (Extended a) where + {-# INLINEABLE arbitrary #-} + arbitrary = liftArbitrary arbitrary + + {-# INLINEABLE shrink #-} + shrink = \case + NegInf -> [Finite 0] + Finite x -> Finite <$> shrink x + PosInf -> [Finite 0] + +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 #-} + -- 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] + PosInf -> [LowerBound e c' | c' <- shrink c] + NegInf -> [LowerBound e c' | c' <- shrink c] + +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 #-} + -- 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] + PosInf -> [UpperBound e c' | c' <- shrink c] + NegInf -> [UpperBound e c' | c' <- shrink c] + +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..7b8cd0a5ad4 --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Scripts.hs @@ -0,0 +1,55 @@ +{-# 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 + +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..48d6fb361fc --- /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 tid' ix | tid' <- shrink tid] ++ + [TxOutRef tid ix' | NonNegative ix' <- 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) = + [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 #-} + 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..93baa048004 --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V1/Value.hs @@ -0,0 +1,404 @@ +{-# 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, 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 + +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 + . fromIntegral @Int + . getLarge + . 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 <>) 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..27e43628e56 --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V2/Contexts.hs @@ -0,0 +1,144 @@ +{-# 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 outref' resolved | outref' <- shrink outref] ++ + [TxInInfo outref resolved' | resolved' <- 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) = + [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 #-} + 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..9dcfd18ff37 --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V2/Tx.hs @@ -0,0 +1,90 @@ +{-# 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 #-} + shrink = \case + NoOutputDatum -> [] + OutputDatumHash h -> OutputDatumHash <$> shrink h + 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 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 #-} + 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 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..f0f6c0c3c76 --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V3/Contexts.hs @@ -0,0 +1,1075 @@ +{-# 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 pkh -> DelegStake <$> shrink pkh + DelegVote drep -> DelegVote <$> shrink drep + DelegStakeVote pkh drep -> + [DelegStakeVote pkh' drep | pkh' <- shrink pkh] ++ + [DelegStakeVote pkh drep' | drep' <- 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 cred' mLovelace | cred' <- shrink cred] ++ + [TxCertRegStaking cred mLovelace' | mLovelace' <- shrink mLovelace] + TxCertUnRegStaking cred mLovelace -> + [TxCertUnRegStaking cred' mLovelace | cred' <- shrink cred] ++ + [TxCertUnRegStaking cred mLovelace' | mLovelace' <- shrink mLovelace] + TxCertDelegStaking cred deleg -> + [TxCertDelegStaking cred' deleg | cred' <- shrink cred] ++ + [TxCertDelegStaking cred deleg' | deleg' <- shrink deleg] + TxCertRegDeleg cred deleg 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 drepCred' lovelace | drepCred' <- shrink drepCred] ++ + [TxCertRegDRep drepCred lovelace' | lovelace' <- shrink lovelace] + TxCertUpdateDRep drepCred -> TxCertUpdateDRep <$> shrink drepCred + TxCertUnRegDRep drepCred lovelace -> + [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' epoch | pkh' <- shrink pkh] ++ + [TxCertPoolRetire pkh epoch' | epoch' <- shrink epoch] + TxCertAuthHotCommittee cold hot -> + [TxCertAuthHotCommittee cold' hot | cold' <- shrink cold] ++ + [TxCertAuthHotCommittee cold hot' | hot' <- 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 + StakePoolVoter pkh -> StakePoolVoter <$> shrink pkh + +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) = + [GovernanceActionId tid' ix | tid' <- shrink tid] ++ + [GovernanceActionId tid ix' | NonNegative ix' <- 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) = + [ProtocolVersion major' minor | NonNegative major' <- shrink (NonNegative major)] ++ + [ProtocolVersion major minor' | NonNegative minor' <- shrink (NonNegative 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 mgid' cp msh | mgid' <- shrink mgid] ++ + [ParameterChange mgid cp' msh | cp' <- shrink cp] ++ + [ParameterChange mgid cp msh' | msh' <- shrink msh] + HardForkInitiation mgid v -> + [HardForkInitiation mgid' v | mgid' <- shrink mgid] ++ + [HardForkInitiation mgid v' | v' <- shrink v] + TreasuryWithdrawals wdrls 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 -> + [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 + _ -> [] + +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 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 #-} + 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 tid' ix | tid' <- shrink tid] ++ + [TxOutRef tid ix' | NonNegative ix' <- 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 -> + [Certifying ix' cert | NonNegative ix' <- shrink (NonNegative ix)] ++ + [Certifying ix cert' | cert' <- shrink cert] + Voting voter -> Voting <$> shrink voter + Proposing ix pp -> + [Proposing ix' pp | NonNegative ix' <- shrink (NonNegative ix)] ++ + [Proposing ix pp' | pp' <- shrink 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 outRef' mdat | outRef' <- shrink outRef] ++ + [SpendingScript outRef mdat' | mdat' <- shrink mdat] + RewardingScript cred -> RewardingScript <$> shrink cred + 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 -> + [ProposingScript ix' pp | NonNegative ix' <- shrink (NonNegative ix)] ++ + [ProposingScript ix pp' | pp' <- 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 toutref' tout | toutref' <- shrink toutref] ++ + [TxInInfo toutref tout' | tout' <- 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) = + [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 #-} + 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 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 #-} + 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..c21ff32fca7 --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V3/MintValue.hs @@ -0,0 +1,93 @@ +{-# 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 + + -- 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 + 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 + +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 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..663fe4ced00 --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Orphans/V3/Tx.hs @@ -0,0 +1,38 @@ +{-# 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 tid' ix | tid' <- shrink tid] ++ + [TxOutRef tid ix' | ix' <- 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) 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 () 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