[PlutusTx] [Test] 'Eq' for 'Value'

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

@@ -141,6 +141,7 @@ test-suite plutus-ledger-api-test
     Spec.Eval
     Spec.Interval
     Spec.NoThunks
+    Spec.Value
     Spec.Versions
 
   build-depends:
@@ -154,7 +155,9 @@ test-suite plutus-ledger-api-test
     , nothunks
     , plutus-core:{plutus-core, plutus-core-testlib}                    ^>=1.14
     , plutus-ledger-api:{plutus-ledger-api, plutus-ledger-api-testlib}  ^>=1.14
-    , plutus-tx:plutus-tx-testlib                                       ^>=1.14
+    , plutus-tx-plugin                                                  ^>=1.14
+    , plutus-tx:{plutus-tx, plutus-tx-testlib}                          ^>=1.14
+    , prettyprinter
     , tasty
     , tasty-hedgehog
     , tasty-hunit

plutus-ledger-api/test/Spec.hs

@@ -11,6 +11,7 @@ import Spec.CostModelParams qualified
 import Spec.Eval qualified
 import Spec.Interval qualified
 import Spec.NoThunks qualified
+import Spec.Value qualified
 import Spec.Versions qualified
 
 import Test.Tasty
@@ -104,4 +105,5 @@ tests = testGroup "plutus-ledger-api" [
     , Spec.CostModelParams.tests
     , Spec.NoThunks.tests
     , Spec.CBOR.DeserialiseFailureInfo.tests
+    , Spec.Value.test_EqValue
     ]

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

@@ -0,0 +1,231 @@
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
+
+{-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-}
+{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-}
+{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-}
+
+module Spec.Value where
+
+import Prelude qualified as Haskell
+
+import PlutusLedgerApi.V1.Value
+
+import PlutusTx.AssocMap qualified as AssocMap
+import PlutusTx.Base
+import PlutusTx.Builtins
+import PlutusTx.Code (CompiledCode, getPlc, unsafeApplyCode)
+import PlutusTx.Lift
+import PlutusTx.List qualified as ListTx
+import PlutusTx.Maybe
+import PlutusTx.Numeric
+import PlutusTx.Prelude
+import PlutusTx.Show (toDigits)
+import PlutusTx.TH (compile)
+import PlutusTx.Traversable qualified as Tx
+
+import PlutusCore.Builtin qualified as PLC
+import PlutusCore.Evaluation.Machine.ExBudgetingDefaults qualified as PLC
+import PlutusCore.Quote qualified as PLC
+import UntypedPlutusCore qualified as PLC
+import UntypedPlutusCore.Evaluation.Machine.Cek qualified as PLC
+
+import Control.Exception qualified as Haskell
+import Data.Functor qualified as Haskell
+import Data.List qualified as Haskell
+import Data.Map qualified as Map
+import Prettyprinter qualified as Pretty
+import Test.Tasty
+import Test.Tasty.Extras
+
+{-# INLINEABLE scalingFactor #-}
+scalingFactor :: Integer
+scalingFactor = 4
+
+{-# INLINEABLE patternOptions #-}
+-- | A list of \"patterns\", each of which can be turned into 'Value's.
+--
+-- We use the patterns to construct lists of tokens: the first element of a tuple becomes a
+-- 'TokenName' and the second one stays an 'Integer', so that the result can be used to create a
+-- @Map TokenName Integer@.
+--
+-- Similarly, we use the patterns to construct lists of currencies: the first element of a tuple
+-- becomes a 'CurrencySymbol' and the second one is used as the index in the list of tokens that
+-- was described in the previous point.
+patternOptions :: [[(Integer, Integer)]]
+patternOptions =
+    [ []
+    , [(1,0)]
+    , [(1,1)]
+    , [(1,1), (2,2)]
+    , [(1,0), (2,2), (1,1)]
+    , [(2,3), (1,0), (2,2), (1,1)]
+    , [(2,2), (2,3), (1,0), (2,4), (1,1)]
+    , [(2,2), (2,3), (1,0), (3,5), (2,4), (1,1)]
+    , [(2,2), (2,3), (1,0), (3,5), (3,6), (2,4), (1,1)]
+    , [(2,2), (2,3), (1,0), (3,5), (3,6), (2,4), (1,1), (2,7)]
+    , [(1,9), (2,2), (6,10), (2,3), (1,0), (4,10), (3,5), (5,0), (3,6), (2,4), (1,1), (2,7), (4,8)]
+    ]
+
+{-# INLINEABLE integerToByteString #-}
+integerToByteString :: Integer -> BuiltinByteString
+integerToByteString n =
+    if n < 0
+        then "-" `appendByteString` integerToByteString (negate n)
+        -- @48@ is the ASCII code of @0@.
+        else ListTx.foldr (consByteString . (48 +)) emptyByteString $ toDigits n
+
+{-# INLINEABLE replicateToByteString #-}
+-- | Like 'integerToByteString' but generates longer bytestrings, so that repeated recalculations of
+-- currency/token name comparisons get reflected in the budget tests in a visible manner.
+replicateToByteString :: Integer -> BuiltinByteString
+replicateToByteString i =
+    ListTx.foldr id emptyByteString $
+        ListTx.replicate iTo6 (appendByteString $ integerToByteString i)
+  where
+    iTo2 = i * i
+    iTo4 = iTo2 * iTo2
+    iTo6 = iTo4 * iTo2
+
+{-# INLINEABLE tokenListOptions #-}
+tokenListOptions :: [[(TokenName, Integer)]]
+tokenListOptions =
+    ListTx.map
+        (ListTx.map $ \(i, x) -> (TokenName $ replicateToByteString i, x))
+        patternOptions
+
+{-# INLINEABLE currencyListOptions #-}
+currencyListOptions :: [[(CurrencySymbol, [(TokenName, Integer)])]]
+currencyListOptions =
+    ListTx.map
+        (ListTx.map $ \(i, x) ->
+            ( CurrencySymbol $ replicateToByteString i
+            , tokenListOptions ListTx.!! x
+            ))
+        patternOptions
+
+{-# INLINEABLE longCurrencyChunk #-}
+-- | A \"long\" list of currencies each with a \"long\" list of tokens for stress-testing (one
+-- doesn't need many elements to stress-test Plutus Tx, hence the quotes).
+longCurrencyChunk :: [(CurrencySymbol, [(TokenName, Integer)])]
+longCurrencyChunk
+    = ListTx.concatMap Tx.sequence
+    . ListTx.zip (ListTx.map (CurrencySymbol . replicateToByteString) [1 .. scalingFactor])
+    $ ListTx.replicate scalingFactor tokenListOptions
+
+{-# INLINEABLE insertHooks #-}
+-- | Return a list whose head is the argument list with 'Nothing' inserted at the beginning, the
+-- middle and the end of it (every other element is wrapped with 'Just'). The tail of the resulting
+-- list comprises all possible versions of the head that we get by removing any number of
+-- 'Nothing's.
+--
+-- Rendering 'Nothing' as @*@ and @Just c@ as @c@ we get:
+--
+-- >>> map (map $ maybe '*' id) $ insertHooks "abcd"
+-- ["*ab*cd*","ab*cd*","*ab*cd","ab*cd","*abcd*","abcd*","*abcd","abcd"]
+insertHooks :: [a] -> [[Maybe a]]
+insertHooks xs0 = do
+    -- The fast and slow pointers trick to find the middle of the list. Check out
+    -- https://medium.com/@arifimran5/fast-and-slow-pointer-pattern-in-linked-list-43647869ac99
+    -- if you're not familiar with the idea.
+    let go (_ : _ : xsFast) (x : xsSlow) = do
+            xs' <- go xsFast xsSlow
+            [Just x : xs']
+        go _ xsSlow = do
+            prefix <- [[Nothing], []]
+            suffix <- [[Nothing], []]
+            [prefix ++ map Just xsSlow ++ suffix]
+    xs0' <- go xs0 xs0
+    [Nothing : xs0', xs0']
+
+{-# INLINEABLE currencyLongListOptions #-}
+-- | The last and the biggest list of currencies from 'currencyListOptions' with 'longCurrencyChunk'
+-- inserted in it in various ways as per 'insertHooks'.
+currencyLongListOptions :: [[(CurrencySymbol, [(TokenName, Integer)])]]
+currencyLongListOptions =
+    insertHooks (ListTx.last currencyListOptions) <&> \currencyListWithHooks ->
+    ListTx.concatMap (maybe longCurrencyChunk pure) currencyListWithHooks
+
+listsToValue :: [(CurrencySymbol, [(TokenName, Integer)])] -> Value
+listsToValue = Value . AssocMap.fromList . ListTx.map (fmap AssocMap.fromList)
+
+valueToLists :: Value -> [(CurrencySymbol, [(TokenName, Integer)])]
+valueToLists = ListTx.map (fmap AssocMap.toList) . AssocMap.toList . getValue
+
+-- | Check equality of two compiled 'Value's through UPLC evaluation and annotate the result with
+-- the cost of evaluation.
+eqValueCode :: CompiledCode Value -> CompiledCode Value -> (Bool, PLC.CountingSt)
+eqValueCode valueCode1 valueCode2 = (res, cost) where
+    prog =
+        $$(compile [|| \value1 value2 -> toBuiltin ((value1 :: Value) == value2) ||])
+            `unsafeApplyCode` valueCode1 `unsafeApplyCode` valueCode2
+    (errOrRes, cost)
+        = PLC.runCekNoEmit PLC.defaultCekParameters PLC.counting
+        . PLC.runQuote
+        . PLC.unDeBruijnTermWith (Haskell.error "Free variable")
+        . PLC._progTerm
+        $ getPlc prog
+    res = either Haskell.throw id $ errOrRes >>= PLC.readKnownSelf
+
+-- | Check equality of two compiled 'Value's directly in Haskell.
+haskellEqValue :: Value -> Value -> Bool
+haskellEqValue value1 value2 = toMap value1 Haskell.== toMap value2 where
+    toMap
+        = Map.filter (Haskell.not . Map.null)
+        . Haskell.fmap (Map.filter (Haskell./= 0))
+        . Map.fromListWith (Map.unionWith (Haskell.+))
+        . Haskell.map (Haskell.fmap $ Map.fromListWith (Haskell.+))
+        . valueToLists
+
+-- | Check whether all currencies and tokens within each of the currencies occur uniquely.
+allDistinct :: Value -> Bool
+allDistinct
+    = Haskell.and
+    . Map.fromListWith (\_ _ -> False)
+    . Haskell.map (Haskell.fmap $
+        Haskell.and . Map.fromListWith (\_ _ -> False) . Haskell.map (Haskell.fmap $ \_ -> True))
+    . valueToLists
+
+-- | Return all the pairs of elements of the given list.
+--
+-- > (x, y) `elem` pairs xs ==> fromJust (x `elemIndex` xs) <= fromJust (y `elemIndex` xs)
+--
+-- >>> pairs "abc"
+-- [('a','a'),('a','b'),('b','b'),('b','c'),('c','c')]
+pairs :: [a] -> [(a, a)]
+pairs []           = []
+pairs [x]          = [(x, x)]
+pairs (x : y : xs) = (x, x) : (x, y) : pairs (y : xs)
+
+-- | Convert each list of currencies to a 'Value', check whether those 'Value' are equal to each
+-- other and dump the costs of all the checks to a golden file.
+test_EqCurrencyList :: Haskell.String -> [[(CurrencySymbol, [(TokenName, Integer)])]] -> TestTree
+test_EqCurrencyList name currencyLists =
+    runTestNestedIn ["test", "Spec", "golden"] $
+        nestedGoldenVsDoc name ".stat" . Pretty.vsep $
+            let attachCode value = (value, liftCodeDef value)
+                valuesWithCodes = map (attachCode . listsToValue) currencyLists
+            in pairs valuesWithCodes Haskell.<&> \((value1, valueCode1), (value2, valueCode2)) ->
+                let eqResExp = value1 `haskellEqValue` value2
+                    (eqResAct, PLC.CountingSt budget) = valueCode1 `eqValueCode` valueCode2
+                -- We need the 'allDistinct' checks, because duplicated
+                -- currencies/tokens-within-the-same-currency result in undefined behavior when
+                -- checking 'Value's for equality.
+                in if allDistinct value1 && allDistinct value2 && eqResAct /= eqResExp
+                    then Haskell.error $ Haskell.intercalate "\n"
+                        [ "Error when checking equality of"
+                        , "  " Haskell.++ Haskell.show value1
+                        , "and"
+                        , "  " Haskell.++ Haskell.show value2
+                        , "Expected " Haskell.++ Haskell.show eqResExp
+                        , "But got " Haskell.++ Haskell.show eqResAct
+                        ]
+                    else Pretty.group $ Pretty.pretty budget
+
+test_EqValue :: TestTree
+test_EqValue =
+    testGroup "`(==) @Value` is sound" $
+        [ test_EqCurrencyList "Short" currencyListOptions
+        , test_EqCurrencyList "Long" currencyLongListOptions
+        ]

plutus-ledger-api/test/Spec/golden/Long.stat.golden

@@ -0,0 +1,15 @@
+({cpu: 9780362526 | mem: 35002468})
+({cpu: 11535083020 | mem: 41619510})
+({cpu: 7773631953 | mem: 28259432})
+({cpu: 5769243585 | mem: 20971834})
+({cpu: 6924442130 | mem: 24754988})
+({cpu: 7745425322 | mem: 27984642})
+({cpu: 4446697967 | mem: 16138868})
+({cpu: 4033846923 | mem: 14573606})
+({cpu: 6808761202 | mem: 24376412})
+({cpu: 7477360785 | mem: 27205524})
+({cpu: 3869670543 | mem: 14302732})
+({cpu: 2884402957 | mem: 10629710})
+({cpu: 3952840806 | mem: 14128932})
+({cpu: 3754703216 | mem: 13744010})
+({cpu: 927859238 | mem: 3396606})

plutus-ledger-api/test/Spec/golden/Short.stat.golden

@@ -0,0 +1,21 @@
+({cpu: 5819100 | mem: 25400})
+({cpu: 10672100 | mem: 46500})
+({cpu: 16625882 | mem: 69804})
+({cpu: 20457371 | mem: 85206})
+({cpu: 23835153 | mem: 97310})
+({cpu: 31603198 | mem: 128414})
+({cpu: 44205186 | mem: 176624})
+({cpu: 43792795 | mem: 176122})
+({cpu: 51542186 | mem: 208524})
+({cpu: 59371679 | mem: 237032})
+({cpu: 83158026 | mem: 328650})
+({cpu: 77267223 | mem: 306844})
+({cpu: 100929378 | mem: 399060})
+({cpu: 115575158 | mem: 455670})
+({cpu: 146823868 | mem: 571500})
+({cpu: 156084569 | mem: 606208})
+({cpu: 198957295 | mem: 766946})
+({cpu: 204775120 | mem: 790948})
+({cpu: 236346454 | mem: 914568})
+({cpu: 390817706 | mem: 1513172})
+({cpu: 927859238 | mem: 3396606})

plutus-tx/src/PlutusTx/Applicative.hs

@@ -9,6 +9,7 @@ import PlutusTx.Base
 import PlutusTx.Bool (Bool)
 import PlutusTx.Either (Either (..))
 import PlutusTx.Functor
+import PlutusTx.List qualified as List
 import PlutusTx.Maybe (Maybe (..))
 import PlutusTx.Monoid (Monoid (..), mappend)
 
@@ -60,6 +61,12 @@ instance Applicative (Either a) where
     Left  e <*> _ = Left e
     Right f <*> r = fmap f r
 
+instance Applicative [] where
+    {-# INLINABLE pure #-}
+    pure x = [x]
+    {-# INLINABLE (<*>) #-}
+    fs <*> xs = List.concatMap (\f -> List.map f xs) fs
+
 instance Applicative Identity where
     {-# INLINABLE pure #-}
     pure = Identity

plutus-tx/src/PlutusTx/AssocMap.hs

@@ -18,6 +18,7 @@ module PlutusTx.AssocMap (
   empty,
   null,
   fromList,
+  fromListSafe,
   toList,
   keys,
   elems,
@@ -35,17 +36,19 @@ module PlutusTx.AssocMap (
   mapThese,
 ) where
 
-import Control.DeepSeq (NFData)
-import Data.Data
-import GHC.Generics (Generic)
+import Prelude qualified as Haskell
+
 import PlutusTx.Builtins qualified as P
 import PlutusTx.Builtins.Internal qualified as BI
 import PlutusTx.IsData
 import PlutusTx.Lift (makeLift)
 import PlutusTx.Prelude hiding (all, filter, mapMaybe, null, toList)
 import PlutusTx.Prelude qualified as P
 import PlutusTx.These
-import Prelude qualified as Haskell
+
+import Control.DeepSeq (NFData)
+import Data.Data
+import GHC.Generics (Generic)
 import Prettyprinter (Pretty (..))
 
 {- HLINT ignore "Use newtype instead of data" -}
@@ -149,6 +152,10 @@ instance (Pretty k, Pretty v) => Pretty (Map k v) where
 fromList :: [(k, v)] -> Map k v
 fromList = Map
 
+{-# INLINEABLE fromListSafe #-}
+fromListSafe :: Eq k => [(k, v)] -> Map k v
+fromListSafe = foldr (uncurry insert) empty
+
 {-# INLINEABLE toList #-}
 toList :: Map k v -> [(k, v)]
 toList (Map l) = l
@@ -166,7 +173,6 @@ lookup c (Map xs) =
     go xs
 
 {-# INLINEABLE member #-}
-
 -- | Is the key a member of the map?
 member :: forall k v. (Eq k) => k -> Map k v -> Bool
 member k m = isJust (lookup k m)

plutus-tx/src/PlutusTx/ErrorCodes.hs

@@ -38,6 +38,7 @@ allErrorCodes = Map.fromList [ ("PT1", "TH Generation of Indexed Data Error")
                              , ("PT16", "PlutusTx.Enum.Ordering.succ: bad argument")
                              , ("PT17", "PlutusTx.Enum.Ordering.pred: bad argument")
                              , ("PT18", "PlutusTx.Enum.Ordering.toEnum: bad argument")
+                             , ("PT19", "PlutusTx.List.last: empty list")
                              ]
 
 -- | The error happens in TH generation of indexed data
@@ -129,3 +130,8 @@ predOrderingBadArgumentError = "PT17"
 {-# INLINABLE toEnumOrderingBadArgumentError #-}
 toEnumOrderingBadArgumentError :: Builtins.BuiltinString
 toEnumOrderingBadArgumentError = "PT18"
+
+-- | PlutusTx.List.last: empty list
+{-# INLINABLE lastEmptyListError #-}
+lastEmptyListError :: Builtins.BuiltinString
+lastEmptyListError = "PT19"