Property tests

plutus-ledger-api/plutus-ledger-api.cabal

@@ -216,6 +216,7 @@ test-suite plutus-ledger-api-plugin-test
     Spec.ReturnUnit.V3
     Spec.ScriptSize
     Spec.Value
+    Spec.Value.WithCurrencySymbol
 
   if os(windows)
     buildable: False 
@@ -232,10 +233,13 @@ test-suite plutus-ledger-api-plugin-test
     , plutus-ledger-api:plutus-ledger-api-testlib
     , plutus-tx                                    ^>=1.36
     , plutus-tx-plugin                             ^>=1.36
+    , plutus-tx-test-util
     , plutus-tx:plutus-tx-testlib
     , prettyprinter
+    , QuickCheck
     , tasty
     , tasty-hunit
+    , tasty-quickcheck
 
 -- This is a nightly test, so it is an executable instead of test-suite to avoid
 -- running this in CI.

plutus-ledger-api/test-plugin/Spec.hs

@@ -8,6 +8,7 @@ import Spec.ReturnUnit.V2 qualified
 import Spec.ReturnUnit.V3 qualified
 import Spec.ScriptSize qualified
 import Spec.Value qualified
+import Spec.Value.WithCurrencySymbol qualified
 
 import Test.Tasty
 
@@ -26,4 +27,5 @@ tests =
     , Spec.ReturnUnit.V3.tests
     , Spec.ScriptSize.tests
     , Spec.Value.test_EqValue
+    , Spec.Value.WithCurrencySymbol.tests
     ]

plutus-ledger-api/test-plugin/Spec/Value/WithCurrencySymbol.hs

@@ -0,0 +1,130 @@
+{-# LANGUAGE BlockArguments    #-}
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE TypeApplications  #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+{-# OPTIONS_GHC -fno-full-laziness #-}
+{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-}
+{-# OPTIONS_GHC -fno-omit-interface-pragmas #-}
+{-# OPTIONS_GHC -fno-spec-constr #-}
+{-# OPTIONS_GHC -fno-specialise #-}
+{-# OPTIONS_GHC -fno-strictness #-}
+{-# OPTIONS_GHC -fno-unbox-small-strict-fields #-}
+{-# OPTIONS_GHC -fno-unbox-strict-fields #-}
+{-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-}
+
+{-# HLINT ignore "Use const" #-}
+
+module Spec.Value.WithCurrencySymbol where
+
+import PlutusTx.Prelude
+
+import Data.ByteString (ByteString)
+import PlutusCore.Generators.QuickCheck.Builtin (ArbitraryBuiltin (arbitraryBuiltin), shrinkBuiltin)
+import PlutusLedgerApi.Test.V1.Value ()
+import PlutusLedgerApi.Test.V3.MintValue ()
+import PlutusLedgerApi.V1.Value (CurrencySymbol (..), TokenName (..), Value (..), currencySymbol,
+                                 singleton, symbols, tokenName, unCurrencySymbol,
+                                 withCurrencySymbol)
+import PlutusTx.AssocMap qualified as Map
+import PlutusTx.Code (CompiledCode, unsafeApplyCode)
+import PlutusTx.Lift (liftCodeDef)
+import PlutusTx.List qualified as List
+import PlutusTx.Test.Util.Compiled (cekResultMatchesHaskellValue, compiledCodeToTerm)
+import PlutusTx.TH (compile)
+import Prelude qualified as Haskell
+import Test.QuickCheck
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.QuickCheck (testProperty)
+
+tests :: TestTree
+tests = testGroup "withCurrencySymbol" [testPropsInHaskell, testPropsInPlinth]
+
+--------------------------------------------------------------------------------
+-- Properties ------------------------------------------------------------------
+
+prop_EachCurrencySymbolGetsContinuationApplied :: Value -> Bool
+prop_EachCurrencySymbolGetsContinuationApplied v =
+  List.all (\cs -> withCurrencySymbol cs v False (\_tokens -> True)) (symbols v)
+
+prop_CorrectTokenQuantitiesAreSelected
+  :: (CurrencySymbol, TokenName, Integer) -> Bool
+prop_CorrectTokenQuantitiesAreSelected (cs, tn, q) =
+  [(tn, q)] == withCurrencySymbol cs (singleton cs tn q) [] Map.toList
+
+--------------------------------------------------------------------------------
+-- Test properties in Haskell --------------------------------------------------
+
+testPropsInHaskell :: TestTree
+testPropsInHaskell =
+  testGroup
+    "Haskell"
+    [ test_Hask_EachCurrencySymbolGetsItsContinuationApplied
+    , test_Hask_CorrectTokenQuantitiesAreSelected
+    ]
+
+test_Hask_EachCurrencySymbolGetsItsContinuationApplied :: TestTree
+test_Hask_EachCurrencySymbolGetsItsContinuationApplied =
+  testProperty "Each currency symbol in a Value gets its continuation applied"
+    $ scaleTestsBy 5 prop_EachCurrencySymbolGetsContinuationApplied
+
+test_Hask_CorrectTokenQuantitiesAreSelected :: TestTree
+test_Hask_CorrectTokenQuantitiesAreSelected =
+  testProperty "Correct token quantities are selected"
+    $ scaleTestsBy 5 prop_CorrectTokenQuantitiesAreSelected
+
+--------------------------------------------------------------------------------
+-- Test properties in Plinth ---------------------------------------------------
+
+testPropsInPlinth :: TestTree
+testPropsInPlinth =
+  testGroup
+    "Plinth"
+    [ test_Plinth_EachCurrencySymbolGetsItsContinuationApplied
+    , test_Plinth_CorrectTokenQuantitiesAreSelected
+    ]
+
+test_Plinth_EachCurrencySymbolGetsItsContinuationApplied :: TestTree
+test_Plinth_EachCurrencySymbolGetsItsContinuationApplied =
+  testProperty "Each currency symbol in a Value gets its continuation applied"
+    $ cekProp
+    . \value ->
+      $$(compile [||prop_EachCurrencySymbolGetsContinuationApplied||])
+        `unsafeApplyCode` liftCodeDef value
+
+test_Plinth_CorrectTokenQuantitiesAreSelected :: TestTree
+test_Plinth_CorrectTokenQuantitiesAreSelected =
+  testProperty "Correct token quantities are selected"
+    $ cekProp
+    . \values ->
+      $$(compile [||prop_CorrectTokenQuantitiesAreSelected||])
+        `unsafeApplyCode` liftCodeDef values
+
+--------------------------------------------------------------------------------
+-- Helper functions ------------------------------------------------------------
+
+scaleTestsBy :: (Testable prop) => Haskell.Int -> prop -> Property
+scaleTestsBy factor =
+  withMaxSuccess (100 Haskell.* factor) . mapSize (Haskell.* 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