From cd62f668665fa83e87a823a5768d5ebed804a0bf Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Mon, 27 May 2024 16:36:55 +0300 Subject: [PATCH 01/13] Add V1.Data.Value Signed-off-by: Ana Pantilie --- plutus-ledger-api/plutus-ledger-api.cabal | 1 + .../src/PlutusLedgerApi/V1/Data/Value.hs | 537 ++++++++++++++++++ plutus-tx/src/PlutusTx/Data/AssocMap.hs | 74 ++- 3 files changed, 611 insertions(+), 1 deletion(-) create mode 100644 plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs diff --git a/plutus-ledger-api/plutus-ledger-api.cabal b/plutus-ledger-api/plutus-ledger-api.cabal index 79896e53347..4a3744528ad 100644 --- a/plutus-ledger-api/plutus-ledger-api.cabal +++ b/plutus-ledger-api/plutus-ledger-api.cabal @@ -64,6 +64,7 @@ library PlutusLedgerApi.V1.Contexts PlutusLedgerApi.V1.Credential PlutusLedgerApi.V1.Crypto + PlutusLedgerApi.V1.Data.Value PlutusLedgerApi.V1.DCert PlutusLedgerApi.V1.EvaluationContext PlutusLedgerApi.V1.Interval diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs new file mode 100644 index 00000000000..63c501f478e --- /dev/null +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs @@ -0,0 +1,537 @@ +-- editorconfig-checker-disable-file +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-orphans #-} +-- Prevent unboxing, which the plugin can't deal with +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} +{-# OPTIONS_GHC -fno-spec-constr #-} +{-# OPTIONS_GHC -fno-specialise #-} +{-# OPTIONS_GHC -fexpose-all-unfoldings #-} +-- We need -fexpose-all-unfoldings to compile the Marlowe validator +-- with GHC 9.6.2. +-- TODO. Look into this more closely: see PLT-7976. + +-- | Functions for working with 'Value'. +module PlutusLedgerApi.V1.Data.Value ( + -- ** Currency symbols + CurrencySymbol(..) + , currencySymbol + , adaSymbol + -- ** Token names + , TokenName(..) + , tokenName + , toString + , adaToken + -- * Asset classes + , AssetClass(..) + , assetClass + , assetClassValue + , assetClassValueOf + -- ** Value + , Value(..) + , singleton + , valueOf + , currencySymbolValueOf + , lovelaceValue + , lovelaceValueOf + , scale + , symbols + -- * Partial order operations + , geq + , gt + , leq + , lt + -- * Etc. + , isZero + , split + , unionWith + , flattenValue + , Lovelace (..) + ) where + +import Prelude qualified as Haskell + +import Control.DeepSeq (NFData) +import Data.ByteString qualified as BS +import Data.Data (Data) +import Data.String (IsString (fromString)) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as E +import GHC.Generics (Generic) +import PlutusLedgerApi.V1.Bytes (LedgerBytes (LedgerBytes), encodeByteString) +import PlutusTx qualified +import PlutusTx.Builtins.Internal (BuiltinList) +import PlutusTx.Data.AssocMap qualified as Map +import PlutusTx.Lift (makeLift) +import PlutusTx.List qualified +import PlutusTx.Ord qualified as Ord +import PlutusTx.Prelude as PlutusTx hiding (sort) +import PlutusTx.Show qualified as PlutusTx +import PlutusTx.These (These (..)) +import Prettyprinter (Pretty, (<>)) +import Prettyprinter.Extras (PrettyShow (PrettyShow)) + +{- | ByteString representing the currency, hashed with /BLAKE2b-224/. +It is empty for `Ada`, 28 bytes for `MintingPolicyHash`. +Forms an `AssetClass` along with `TokenName`. +A `Value` is a map from `CurrencySymbol`'s to a map from `TokenName` to an `Integer`. + +This is a simple type without any validation, __use with caution__. +You may want to add checks for its invariants. See the + [Shelley ledger specification](https://github.com/IntersectMBO/cardano-ledger/releases/download/cardano-ledger-spec-2023-04-03/shelley-ledger.pdf). +-} +newtype CurrencySymbol = CurrencySymbol { unCurrencySymbol :: PlutusTx.BuiltinByteString } + deriving + (IsString -- ^ from hex encoding + , Haskell.Show -- ^ using hex encoding + , Pretty -- ^ using hex encoding + ) via LedgerBytes + deriving stock (Generic, Data) + deriving newtype (Haskell.Eq, Haskell.Ord, Eq, Ord, PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) + deriving anyclass (NFData) + +{-# INLINABLE currencySymbol #-} +-- | Creates `CurrencySymbol` from raw `ByteString`. +currencySymbol :: BS.ByteString -> CurrencySymbol +currencySymbol = CurrencySymbol . PlutusTx.toBuiltin + +{- | ByteString of a name of a token. +Shown as UTF-8 string when possible. +Should be no longer than 32 bytes, empty for Ada. +Forms an `AssetClass` along with a `CurrencySymbol`. + +This is a simple type without any validation, __use with caution__. +You may want to add checks for its invariants. See the + [Shelley ledger specification](https://github.com/IntersectMBO/cardano-ledger/releases/download/cardano-ledger-spec-2023-04-03/shelley-ledger.pdf). +-} +newtype TokenName = TokenName { unTokenName :: PlutusTx.BuiltinByteString } + deriving stock (Generic, Data) + deriving newtype (Haskell.Eq, Haskell.Ord, Eq, Ord, PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) + deriving anyclass (NFData) + deriving Pretty via (PrettyShow TokenName) + +-- | UTF-8 encoding. Doesn't verify length. +instance IsString TokenName where + fromString = fromText . Text.pack + +{-# INLINABLE tokenName #-} +-- | Creates `TokenName` from raw `BS.ByteString`. +tokenName :: BS.ByteString -> TokenName +tokenName = TokenName . PlutusTx.toBuiltin + +fromText :: Text -> TokenName +fromText = tokenName . E.encodeUtf8 + +fromTokenName :: (BS.ByteString -> r) -> (Text -> r) -> TokenName -> r +fromTokenName handleBytestring handleText (TokenName bs) = either (\_ -> handleBytestring $ PlutusTx.fromBuiltin bs) handleText $ E.decodeUtf8' (PlutusTx.fromBuiltin bs) + +-- | Encode a `ByteString` to a hex `Text`. +asBase16 :: BS.ByteString -> Text +asBase16 bs = Text.concat ["0x", encodeByteString bs] + +-- | Wrap the input `Text` in double quotes. +quoted :: Text -> Text +quoted s = Text.concat ["\"", s, "\""] + +{- | Turn a TokenName to a hex-encoded 'String' + +Compared to `show` , it will not surround the string with double-quotes. +-} +toString :: TokenName -> Haskell.String +toString = Text.unpack . fromTokenName asBase16 id + +instance Haskell.Show TokenName where + show = Text.unpack . fromTokenName asBase16 quoted + +{-# INLINABLE adaSymbol #-} +-- | The 'CurrencySymbol' of the 'Ada' currency. +adaSymbol :: CurrencySymbol +adaSymbol = CurrencySymbol emptyByteString + +{-# INLINABLE adaToken #-} +-- | The 'TokenName' of the 'Ada' currency. +adaToken :: TokenName +adaToken = TokenName emptyByteString + +-- | An asset class, identified by a `CurrencySymbol` and a `TokenName`. +newtype AssetClass = AssetClass { unAssetClass :: (CurrencySymbol, TokenName) } + deriving stock (Generic, Data) + deriving newtype (Haskell.Eq, Haskell.Ord, Haskell.Show, Eq, Ord, PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) + deriving anyclass (NFData) + deriving Pretty via (PrettyShow (CurrencySymbol, TokenName)) + +{-# INLINABLE assetClass #-} +-- | The curried version of 'AssetClass' constructor +assetClass :: CurrencySymbol -> TokenName -> AssetClass +assetClass s t = AssetClass (s, t) + +{- Note [Value vs value] +We call two completely different things "values": the 'Value' type and a value within a key-value +pair. To distinguish between the two we write the former with a capital "V" and enclosed in single +quotes and we write the latter with a lower case "v" and without the quotes, i.e. 'Value' vs value. +-} + +{- Note [Optimising Value] + +We have attempted to improve the performance of 'Value' and other usages of +'PlutusTx.AssocMap.Map' by choosing a different representation for 'PlutusTx.AssocMap.Map', +see https://github.com/IntersectMBO/plutus/pull/5697. +This approach has been found to not be suitable, as the PR's description mentions. + +Another approach was to define a specialised 'ByteStringMap', where the key type was 'BuiltinByteString', +since that is the representation of both 'CurrencySymbol' and 'TokenName'. +Unfortunately, this approach actually had worse performance in practice. We believe it is worse +because having two map libraries would make some optimisations, such as CSE, less effective. +We base this on the fact that turning off all optimisations ended up making the code more performant. +See https://github.com/IntersectMBO/plutus/pull/5779 for details on the experiment done. +-} + +-- See Note [Value vs value]. +-- See Note [Optimising Value]. +{- | The 'Value' type represents a collection of amounts of different currencies. +We can think of 'Value' as a vector space whose dimensions are currencies. + +Operations on currencies are usually implemented /pointwise/. That is, +we apply the operation to the quantities for each currency in turn. So +when we add two 'Value's the resulting 'Value' has, for each currency, +the sum of the quantities of /that particular/ currency in the argument +'Value'. The effect of this is that the currencies in the 'Value' are "independent", +and are operated on separately. + +Whenever we need to get the quantity of a currency in a 'Value' where there +is no explicit quantity of that currency in the 'Value', then the quantity is +taken to be zero. + +There is no 'Ord Value' instance since 'Value' is only a partial order, so 'compare' can't +do the right thing in some cases. + -} +newtype Value = Value { getValue :: Map.Map CurrencySymbol (Map.Map TokenName Integer) } + deriving stock (Generic, Haskell.Show) + deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) + deriving Pretty via (PrettyShow Value) + +instance Haskell.Eq Value where + (==) = eq + +instance Eq Value where + {-# INLINABLE (==) #-} + (==) = eq + +instance Haskell.Semigroup Value where + (<>) = unionWith (+) + +instance Semigroup Value where + {-# INLINABLE (<>) #-} + (<>) = unionWith (+) + +instance Haskell.Monoid Value where + mempty = Value Map.empty + +instance Monoid Value where + {-# INLINABLE mempty #-} + mempty = Value Map.empty + +instance Group Value where + {-# INLINABLE inv #-} + inv = scale @Integer @Value (-1) + +deriving via (Additive Value) instance AdditiveSemigroup Value +deriving via (Additive Value) instance AdditiveMonoid Value +deriving via (Additive Value) instance AdditiveGroup Value + +instance Module Integer Value where + {-# INLINABLE scale #-} + scale i (Value xs) = Value (Map.map (Map.map (\i' -> i * i')) xs) + +instance JoinSemiLattice Value where + {-# INLINABLE (\/) #-} + (\/) = unionWith Ord.max + +instance MeetSemiLattice Value where + {-# INLINABLE (/\) #-} + (/\) = unionWith Ord.min + +{-# INLINABLE valueOf #-} +-- | Get the quantity of the given currency in the 'Value'. +-- Assumes that the underlying map doesn't contain duplicate keys. +valueOf :: Value -> CurrencySymbol -> TokenName -> Integer +valueOf (Value mp) cur tn = + case Map.lookup cur mp of + Nothing -> 0 :: Integer + Just i -> case Map.lookup tn i of + Nothing -> 0 + Just v -> v + +{-# INLINABLE currencySymbolValueOf #-} +-- | Get the total value of the currency symbol in the 'Value' map. +-- Assumes that the underlying map doesn't contain duplicate keys. +currencySymbolValueOf :: Value -> CurrencySymbol -> Integer +currencySymbolValueOf (Value mp) cur = case Map.lookup cur mp of + Nothing -> 0 + Just tokens -> + -- This is more efficient than `PlutusTx.sum (Map.elems tokens)`, because + -- the latter materializes the intermediate result of `Map.elems tokens`. + PlutusTx.List.foldr (\(_, amt) acc -> amt + acc) 0 (Map.toList tokens) + +{-# INLINABLE symbols #-} +-- | The list of 'CurrencySymbol's of a 'Value'. +symbols :: Value -> BuiltinList BuiltinData +symbols (Value mp) = Map.keys mp + +{-# INLINABLE singleton #-} +-- | Make a 'Value' containing only the given quantity of the given currency. +singleton :: CurrencySymbol -> TokenName -> Integer -> Value +singleton c tn i = Value (Map.singleton c (Map.singleton tn i)) + +{-# INLINABLE lovelaceValue #-} +-- | A 'Value' containing the given quantity of Lovelace. +lovelaceValue :: Lovelace -> Value +lovelaceValue = singleton adaSymbol adaToken . getLovelace + +{-# INLINABLE lovelaceValueOf #-} +-- | Get the quantity of Lovelace in the 'Value'. +lovelaceValueOf :: Value -> Lovelace +lovelaceValueOf v = Lovelace (valueOf v adaSymbol adaToken) + +{-# INLINABLE assetClassValue #-} +-- | A 'Value' containing the given amount of the asset class. +assetClassValue :: AssetClass -> Integer -> Value +assetClassValue (AssetClass (c, t)) i = singleton c t i + +{-# INLINABLE assetClassValueOf #-} +-- | Get the quantity of the given 'AssetClass' class in the 'Value'. +assetClassValueOf :: Value -> AssetClass -> Integer +assetClassValueOf v (AssetClass (c, t)) = valueOf v c t + +{-# INLINABLE unionVal #-} +-- | Combine two 'Value' maps, assumes the well-definedness of the two maps. +unionVal :: Value -> Value -> Map.Map CurrencySymbol (Map.Map TokenName (These Integer Integer)) +unionVal (Value l) (Value r) = + let + combined = Map.union l r + unThese k = case k of + This a -> Map.map This a + That b -> Map.map That b + These a b -> Map.union a b + in Map.map unThese combined + +{-# INLINABLE unionWith #-} +-- | Combine two 'Value' maps with the argument function. +-- Assumes the well-definedness of the two maps. +unionWith :: (Integer -> Integer -> Integer) -> Value -> Value -> Value +unionWith f ls rs = + let + combined = unionVal ls rs + unThese k' = case k' of + This a -> f a 0 + That b -> f 0 b + These a b -> f a b + in Value (Map.map (Map.map unThese) combined) + +{-# INLINABLE flattenValue #-} +-- | Convert a 'Value' to a simple list, keeping only the non-zero amounts. +-- Note that the result isn't sorted, meaning @v1 == v2@ doesn't generally imply +-- @flattenValue v1 == flattenValue v2@. +-- Also assumes that there are no duplicate keys in the 'Value' 'Map'. +flattenValue :: Value -> [(CurrencySymbol, TokenName, Integer)] +flattenValue v = goOuter [] (Map.toList $ getValue v) + where + goOuter acc [] = acc + goOuter acc ((cs, m) : tl) = goOuter (goInner cs acc (Map.toList m)) tl + + goInner _ acc [] = acc + goInner cs acc ((tn, a) : tl) + | a /= 0 = goInner cs ((cs, tn, a) : acc) tl + | otherwise = goInner cs acc tl + +-- Num operations + +{-# INLINABLE isZero #-} +-- | Check whether a 'Value' is zero. +isZero :: Value -> Bool +isZero (Value xs) = Map.all (Map.all (\i -> 0 == i)) xs + +{-# INLINABLE checkPred #-} +-- | Checks whether a predicate holds for all the values in a 'Value' +-- union. Assumes the well-definedness of the two underlying 'Map's. +checkPred :: (These Integer Integer -> Bool) -> Value -> Value -> Bool +checkPred f l r = + let + inner :: Map.Map TokenName (These Integer Integer) -> Bool + inner = Map.all f + in + Map.all inner (unionVal l r) + +{-# INLINABLE checkBinRel #-} +-- | Check whether a binary relation holds for value pairs of two 'Value' maps, +-- supplying 0 where a key is only present in one of them. +checkBinRel :: (Integer -> Integer -> Bool) -> Value -> Value -> Bool +checkBinRel f l r = + let + unThese k' = case k' of + This a -> f a 0 + That b -> f 0 b + These a b -> f a b + in checkPred unThese l r + +{-# INLINABLE geq #-} +-- | Check whether one 'Value' is greater than or equal to another. See 'Value' for an explanation +-- of how operations on 'Value's work. +geq :: Value -> Value -> Bool +-- If both are zero then checkBinRel will be vacuously true, but this is fine. +geq = checkBinRel (>=) + +{-# INLINABLE leq #-} +-- | Check whether one 'Value' is less than or equal to another. See 'Value' for an explanation of +-- how operations on 'Value's work. +leq :: Value -> Value -> Bool +-- If both are zero then checkBinRel will be vacuously true, but this is fine. +leq = checkBinRel (<=) + +{-# INLINABLE gt #-} +-- | Check whether one 'Value' is strictly greater than another. +-- This is *not* a pointwise operation. @gt l r@ means @geq l r && not (eq l r)@. +gt :: Value -> Value -> Bool +gt l r = geq l r && not (eq l r) + +{-# INLINABLE lt #-} +-- | Check whether one 'Value' is strictly less than another. +-- This is *not* a pointwise operation. @lt l r@ means @leq l r && not (eq l r)@. +lt :: Value -> Value -> Bool +lt l r = leq l r && not (eq l r) + +-- | Split a 'Value' into its positive and negative parts. The first element of +-- the tuple contains the negative parts of the 'Value', the second element +-- contains the positive parts. +-- +-- @negate (fst (split a)) `plus` (snd (split a)) == a@ +-- +{-# INLINABLE split #-} +split :: Value -> (Value, Value) +split (Value mp) = (negate (Value neg), Value pos) where + (neg, pos) = Map.mapThese splitIntl mp + + splitIntl :: Map.Map TokenName Integer -> These (Map.Map TokenName Integer) (Map.Map TokenName Integer) + splitIntl mp' = These l r where + (l, r) = Map.mapThese (\i -> if i <= 0 then This i else That i) mp' + +{-# INLINABLE unordEqWith #-} +{- | Check equality of two lists of distinct key-value pairs, each value being uniquely +identified by a key, given a function checking whether a 'Value' is zero and a function +checking equality of values. Note that the caller must ensure that the two lists are +well-defined in this sense. This is not checked or enforced in `unordEqWith`, and therefore +it might yield undefined results for ill-defined input. + +This function recurses on both the lists in parallel and checks whether the key-value pairs are +equal pointwise. If there is a mismatch, then it tries to find the left key-value pair in the right +list. If that succeeds then the pair is removed from both the lists and recursion proceeds pointwise +as before until there's another mismatch. If at some point a key-value pair from the left list is +not found in the right one, then the function returns 'False'. If the left list is exhausted, but +the right one still has some non-zero elements, the function returns 'False' as well. + +We check equality of values of two key-value pairs right after ensuring that the keys match. This is +disadvantageous if the values are big and there's a key that is present in one of the lists but not +in the other, since in that case computing equality of values was expensive and pointless. However + +1. we've checked and on the chain 'Value's very rarely contain 'CurrencySymbol's with more than 3 + 'TokenName's associated with them, so we optimize for the most common use case +2. computing equality of values before ensuring equality of all the keys certainly does help when we + check equality of 'TokenName'-value pairs, since the value of a 'TokenName' is an 'Integer' and + @(==) :: Integer -> Integer -> Bool@ is generally much faster than repeatedly searching for keys + in a list +3. having some clever logic for computing equality of values right away in some cases, but not in + others would not only complicate the algorithm, but also increase the size of the function and + this resource is quite scarce as the size of a program growing beyond what's acceptable by the + network can be a real deal breaker, while general performance concerns don't seem to be as + pressing + +The algorithm we use here is very similar, if not identical, to @valueEqualsValue4@ from +https://github.com/IntersectMBO/plutus/issues/5135 +-} +unordEqWith :: forall k v. Eq k => (v -> Bool) -> (v -> v -> Bool) -> [(k, v)] -> [(k, v)] -> Bool +unordEqWith is0 eqV = goBoth where + -- Recurse on the spines of both the lists simultaneously. + goBoth :: [(k, v)] -> [(k, v)] -> Bool + -- One spine is longer than the other one, but this still can result in a succeeding equality + -- check if the non-empty list only contains zero values. + goBoth [] kvsR = all (is0 . snd) kvsR + -- Symmetric to the previous case. + goBoth kvsL [] = all (is0 . snd) kvsL + -- Both spines are non-empty. + goBoth ((kL, vL) : kvsL') kvsR0@(kvR0@(kR0, vR0) : kvsR0') + -- We could've avoided having this clause if we always searched for the right key-value pair + -- using @goRight@, however the sheer act of invoking that function, passing an empty list + -- to it as an accumulator and calling 'revAppend' afterwards affects performance quite a + -- bit, considering that all of that happens for every single element of the left list. + -- Hence we handle the special case of lists being equal pointwise (or at least their + -- prefixes being equal pointwise) with a bit of additional logic to get some easy + -- performance gains. + | kL == kR0 = if vL `eqV` vR0 then goBoth kvsL' kvsR0' else False + | is0 vL = goBoth kvsL' kvsR0 + | otherwise = goRight [kvR0 | not $ is0 vR0] kvsR0' + where + -- Recurse on the spine of the right list looking for a key-value pair whose key matches + -- @kL@, i.e. the first key in the remaining part of the left list. The accumulator + -- contains (in reverse order) all elements of the right list processed so far whose + -- keys are not equal to @kL@ and values are non-zero. + goRight :: [(k, v)] -> [(k, v)] -> Bool + goRight _ [] = False + goRight acc (kvR@(kR, vR) : kvsR') + | is0 vR = goRight acc kvsR' + -- @revAppend@ recreates @kvsR0'@ with @(kR, vR)@ removed, since that pair + -- equals @(kL, vL)@ from the left list, hence we throw both of them away. + | kL == kR = if vL `eqV` vR then goBoth kvsL' (revAppend acc kvsR') else False + | otherwise = goRight (kvR : acc) kvsR' + +{-# INLINABLE eqMapWith #-} +-- | Check equality of two 'Map's given a function checking whether a value is zero and a function +-- checking equality of values. +eqMapWith :: + forall k v + . (Eq k, PlutusTx.UnsafeFromData k, PlutusTx.UnsafeFromData v) + => (v -> Bool) -> (v -> v -> Bool) -> Map.Map k v -> Map.Map k v -> Bool +eqMapWith is0 eqV (Map.toList -> xs1) (Map.toList -> xs2) = unordEqWith is0 eqV xs1 xs2 + +{-# INLINABLE eq #-} +-- | Check equality of two 'Value's. Does not assume orderness of lists within a 'Value' or a lack +-- of empty values (such as a token whose quantity is zero or a currency that has a bunch of such +-- tokens or no tokens at all), but does assume that no currencies or tokens within a single +-- currency have multiple entries. +eq :: Value -> Value -> Bool +eq (Value currs1) (Value currs2) = eqMapWith (Map.all (0 ==)) (eqMapWith (0 ==) (==)) currs1 currs2 + +newtype Lovelace = Lovelace { getLovelace :: Integer } + deriving stock (Generic) + deriving (Pretty) via (PrettyShow Lovelace) + deriving newtype + ( Haskell.Eq + , Haskell.Ord + , Haskell.Show + , Haskell.Num + , Haskell.Real + , Haskell.Enum + , PlutusTx.Eq + , PlutusTx.Ord + , PlutusTx.ToData + , PlutusTx.FromData + , PlutusTx.UnsafeFromData + , PlutusTx.AdditiveSemigroup + , PlutusTx.AdditiveMonoid + , PlutusTx.AdditiveGroup + , PlutusTx.Show + ) + +makeLift ''CurrencySymbol +makeLift ''TokenName +makeLift ''AssetClass +makeLift ''Value +makeLift ''Lovelace diff --git a/plutus-tx/src/PlutusTx/Data/AssocMap.hs b/plutus-tx/src/PlutusTx/Data/AssocMap.hs index 48712bd3274..0dc01146677 100644 --- a/plutus-tx/src/PlutusTx/Data/AssocMap.hs +++ b/plutus-tx/src/PlutusTx/Data/AssocMap.hs @@ -24,13 +24,17 @@ module PlutusTx.Data.AssocMap ( any, union, unionWith, + keys, + map, + mapThese, ) where import PlutusTx.Builtins qualified as P import PlutusTx.Builtins.Internal qualified as BI import PlutusTx.IsData qualified as P import PlutusTx.Lift (makeLift) -import PlutusTx.Prelude hiding (all, any, null, toList, uncons) +import PlutusTx.Prelude hiding (all, any, map, null, toList, uncons) +import PlutusTx.Prelude qualified import PlutusTx.These @@ -321,6 +325,7 @@ union (Map ls) (Map rs) = Map res in insert' k v (safeAppend tl xs2) ) +{-# INLINEABLE unionWith #-} -- | Combine two 'Map's with the given combination function. unionWith :: forall k a. @@ -409,4 +414,71 @@ unsafeFromBuiltinList = Map nil :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) nil = BI.mkNilPairData BI.unitval +keys' + :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) + -> BI.BuiltinList BuiltinData +keys' = go + where + go xs = + P.matchList + xs + (\() -> BI.mkNilData BI.unitval) + ( \hd tl -> + let k = BI.fst hd + in BI.mkCons k (go tl) + ) + +{-# INLINEABLE keys #-} +keys :: forall k a. Map k a -> BI.BuiltinList BuiltinData +keys (Map m) = keys' m + +mapThese + :: forall v k a b + . ( P.ToData a, P.ToData b, P.UnsafeFromData v) + => (v -> These a b) -> Map k v -> (Map k a, Map k b) +mapThese f (Map m) = (Map ls, Map rs) + where + (ls, rs) = go m + go + :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) + -> + ( BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) + , BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) + ) + go xs = + P.matchList + xs + (\() -> (nil, nil)) + ( \hd tl -> + let k = BI.fst hd + v = BI.snd hd + (ls', rs') = go tl + in case f' v of + This l' -> (BI.mkCons (BI.mkPairData k (P.toBuiltinData l')) ls', rs') + That r' -> (ls', BI.mkCons (BI.mkPairData k (P.toBuiltinData r')) rs') + These l' r' -> + ( BI.mkCons (BI.mkPairData k (P.toBuiltinData l')) ls' + , BI.mkCons (BI.mkPairData k (P.toBuiltinData r')) rs' + ) + ) + f' :: BuiltinData -> These a b + f' = f . P.unsafeFromBuiltinData + +{-# INLINEABLE map #-} +map :: forall k a b. (P.UnsafeFromData a, P.ToData b) => (a -> b) -> Map k a -> Map k b +map f (Map m) = Map $ go m + where + go xs = + P.matchList + xs + (\() -> nil) + ( \hd tl -> + let k = BI.fst hd + v = BI.snd hd + in + BI.mkCons + (BI.mkPairData k (P.toBuiltinData (f (P.unsafeFromBuiltinData v)))) + (go tl) + ) + makeLift ''Map From edf3b0a154cdc6cd074c20284442802bcccfa439 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Thu, 30 May 2024 17:49:03 +0300 Subject: [PATCH 02/13] Copy Value tests for Data.Value Signed-off-by: Ana Pantilie --- plutus-ledger-api/plutus-ledger-api.cabal | 4 + plutus-ledger-api/test-plugin/Spec.hs | 4 + .../test-plugin/Spec/Data/Budget.hs | 164 ++++ .../9.6/currencySymbolValueOf.budget.golden | 2 + .../9.6/currencySymbolValueOf.eval.golden | 1 + .../9.6/currencySymbolValueOf.pir.golden | 105 +++ .../Spec/Data/Budget/9.6/geq1.budget.golden | 2 + .../Spec/Data/Budget/9.6/geq1.eval.golden | 1 + .../Spec/Data/Budget/9.6/geq2.budget.golden | 2 + .../Spec/Data/Budget/9.6/geq2.eval.golden | 1 + .../Spec/Data/Budget/9.6/geq3.budget.golden | 2 + .../Spec/Data/Budget/9.6/geq3.eval.golden | 1 + .../Spec/Data/Budget/9.6/geq4.budget.golden | 2 + .../Spec/Data/Budget/9.6/geq4.eval.golden | 1 + .../Spec/Data/Budget/9.6/geq5.budget.golden | 2 + .../Spec/Data/Budget/9.6/geq5.eval.golden | 1 + .../Spec/Data/Budget/9.6/gt.pir.golden | 804 ++++++++++++++++++ .../Spec/Data/Budget/9.6/gt1.budget.golden | 2 + .../Spec/Data/Budget/9.6/gt1.eval.golden | 1 + .../Spec/Data/Budget/9.6/gt2.budget.golden | 2 + .../Spec/Data/Budget/9.6/gt2.eval.golden | 1 + .../Spec/Data/Budget/9.6/gt3.budget.golden | 2 + .../Spec/Data/Budget/9.6/gt3.eval.golden | 1 + .../Spec/Data/Budget/9.6/gt4.budget.golden | 2 + .../Spec/Data/Budget/9.6/gt4.eval.golden | 1 + .../Spec/Data/Budget/9.6/gt5.budget.golden | 2 + .../Spec/Data/Budget/9.6/gt5.eval.golden | 1 + .../test-plugin/Spec/Data/Value.hs | 229 +++++ .../Spec/Data/Value/9.6/Long.stat.golden | 15 + .../Spec/Data/Value/9.6/Short.stat.golden | 21 + plutus-ledger-api/test/Spec.hs | 2 + plutus-ledger-api/test/Spec/V1/Data/Value.hs | 132 +++ .../PlutusLedgerApi/Test/V1/Data/Value.hs | 98 +++ 33 files changed, 1611 insertions(+) create mode 100644 plutus-ledger-api/test-plugin/Spec/Data/Budget.hs create mode 100644 plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/currencySymbolValueOf.budget.golden create mode 100644 plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/currencySymbolValueOf.eval.golden create mode 100644 plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/currencySymbolValueOf.pir.golden create mode 100644 plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq1.budget.golden create mode 100644 plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq1.eval.golden create mode 100644 plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq2.budget.golden create mode 100644 plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq2.eval.golden create mode 100644 plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq3.budget.golden create mode 100644 plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq3.eval.golden create mode 100644 plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq4.budget.golden create mode 100644 plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq4.eval.golden create mode 100644 plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq5.budget.golden create mode 100644 plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq5.eval.golden create mode 100644 plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt.pir.golden create mode 100644 plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt1.budget.golden create mode 100644 plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt1.eval.golden create mode 100644 plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt2.budget.golden create mode 100644 plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt2.eval.golden create mode 100644 plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt3.budget.golden create mode 100644 plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt3.eval.golden create mode 100644 plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt4.budget.golden create mode 100644 plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt4.eval.golden create mode 100644 plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt5.budget.golden create mode 100644 plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt5.eval.golden create mode 100644 plutus-ledger-api/test-plugin/Spec/Data/Value.hs create mode 100644 plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Long.stat.golden create mode 100644 plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Short.stat.golden create mode 100644 plutus-ledger-api/test/Spec/V1/Data/Value.hs create mode 100644 plutus-ledger-api/testlib/PlutusLedgerApi/Test/V1/Data/Value.hs diff --git a/plutus-ledger-api/plutus-ledger-api.cabal b/plutus-ledger-api/plutus-ledger-api.cabal index 4a3744528ad..e70cf0c9f45 100644 --- a/plutus-ledger-api/plutus-ledger-api.cabal +++ b/plutus-ledger-api/plutus-ledger-api.cabal @@ -117,6 +117,7 @@ library plutus-ledger-api-testlib PlutusLedgerApi.Test.EvaluationEvent PlutusLedgerApi.Test.Examples PlutusLedgerApi.Test.Scripts + PlutusLedgerApi.Test.V1.Data.Value PlutusLedgerApi.Test.V1.EvaluationContext PlutusLedgerApi.Test.V1.Value PlutusLedgerApi.Test.V2.EvaluationContext @@ -151,6 +152,7 @@ test-suite plutus-ledger-api-test Spec.Eval Spec.Interval Spec.ScriptDecodeError + Spec.V1.Data.Value Spec.V1.Value Spec.Versions @@ -186,6 +188,8 @@ test-suite plutus-ledger-api-plugin-test ghc-options: -threaded -rtsopts -with-rtsopts=-N other-modules: Spec.Budget + Spec.Data.Budget + Spec.Data.Value Spec.Value build-depends: diff --git a/plutus-ledger-api/test-plugin/Spec.hs b/plutus-ledger-api/test-plugin/Spec.hs index 7ab2b296a3a..1329c0560a1 100644 --- a/plutus-ledger-api/test-plugin/Spec.hs +++ b/plutus-ledger-api/test-plugin/Spec.hs @@ -1,6 +1,8 @@ module Main where import Spec.Budget qualified +import Spec.Data.Budget qualified +import Spec.Data.Value qualified import Spec.Value qualified import Test.Tasty @@ -12,4 +14,6 @@ tests :: TestTree tests = testGroup "plutus-ledger-api-plugin-test" [ Spec.Budget.tests , Spec.Value.test_EqValue + , Spec.Data.Budget.tests + , Spec.Data.Value.test_EqValue ] diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget.hs b/plutus-ledger-api/test-plugin/Spec/Data/Budget.hs new file mode 100644 index 00000000000..b1f4578408c --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} + +module Spec.Data.Budget where + +import Test.Tasty (TestName, TestTree) +import Test.Tasty.Extras + +import Data.Bifunctor +import Data.String +import PlutusLedgerApi.V1.Data.Value +import PlutusTx.Code +import PlutusTx.Data.AssocMap as Map +import PlutusTx.Lift (liftCodeDef) +import PlutusTx.Test +import PlutusTx.TH (compile) + +tests :: TestTree +tests = + runTestNested ["test-plugin", "Spec", "Data", "Budget"] . pure . testNestedGhc $ + [ goldenPirReadable "gt" compiledGt + , goldenPirReadable "currencySymbolValueOf" compiledCurrencySymbolValueOf + ] + ++ concatMap + ( \(TestCase name code) -> + [ goldenBudget name code + , goldenEvalCekCatch name [code] + ] + ) + testCases + +compiledGt :: CompiledCode (Value -> Value -> Bool) +compiledGt = $$(compile [||gt||]) + +compiledGeq :: CompiledCode (Value -> Value -> Bool) +compiledGeq = $$(compile [||geq||]) + +compiledCurrencySymbolValueOf :: CompiledCode (Value -> CurrencySymbol -> Integer) +compiledCurrencySymbolValueOf = $$(compile [||currencySymbolValueOf||]) + +mkValue :: [(Integer, [(Integer, Integer)])] -> Value +mkValue = + Value . Map.unsafeFromList . fmap (bimap toSymbol (Map.unsafeFromList . fmap (first toToken))) + +toSymbol :: Integer -> CurrencySymbol +toSymbol = currencySymbol . fromString . show + +toToken :: Integer -> TokenName +toToken = fromString . show + +value1 :: Value +value1 = + mkValue + [ (1, [(100, 101)]) + , (2, [(200, 201), (202, 203)]) + , (3, [(300, 301), (302, 303), (304, 305)]) + , (4, [(400, 401), (402, 403), (404, 405), (406, 407)]) + , (5, [(500, 501), (502, 503), (504, 505), (506, 507), (508, 509)]) + ] + +-- | One more CurrencySymbol than `value1`. +value2 :: Value +value2 = + mkValue + [ (1, [(100, 101)]) + , (2, [(200, 201), (202, 203)]) + , (3, [(300, 301), (302, 303), (304, 305)]) + , (4, [(400, 401), (402, 403), (404, 405), (406, 407)]) + , (5, [(500, 501), (502, 503), (504, 505), (506, 507), (508, 509)]) + , (6, [(600, 601), (602, 603), (604, 605), (606, 607), (608, 609), (610, 611)]) + ] + +-- | One more TokenName than `value1`. +value3 :: Value +value3 = + mkValue + [ (1, [(100, 101)]) + , (2, [(200, 201), (202, 203)]) + , (3, [(300, 301), (302, 303), (304, 305), (306, 307)]) + , (4, [(400, 401), (402, 403), (404, 405), (406, 407)]) + , (5, [(500, 501), (502, 503), (504, 505), (506, 507), (508, 509)]) + ] + +data TestCase = forall a. TestCase TestName (CompiledCode a) + +testCases :: [TestCase] +testCases = + [ TestCase + "gt1" + ( compiledGt + `unsafeApplyCode` liftCodeDef value1 + `unsafeApplyCode` liftCodeDef value1 + ) + , TestCase + "gt2" + ( compiledGt + `unsafeApplyCode` liftCodeDef value1 + `unsafeApplyCode` liftCodeDef value2 + ) + , TestCase + "gt3" + ( compiledGt + `unsafeApplyCode` liftCodeDef value2 + `unsafeApplyCode` liftCodeDef value1 + ) + , TestCase + "gt4" + ( compiledGt + `unsafeApplyCode` liftCodeDef value1 + `unsafeApplyCode` liftCodeDef value3 + ) + , TestCase + "gt5" + ( compiledGt + `unsafeApplyCode` liftCodeDef value3 + `unsafeApplyCode` liftCodeDef value1 + ) + , TestCase + "geq1" + ( compiledGeq + `unsafeApplyCode` liftCodeDef value1 + `unsafeApplyCode` liftCodeDef value1 + ) + , TestCase + "geq2" + ( compiledGeq + `unsafeApplyCode` liftCodeDef value1 + `unsafeApplyCode` liftCodeDef value2 + ) + , TestCase + "geq3" + ( compiledGeq + `unsafeApplyCode` liftCodeDef value2 + `unsafeApplyCode` liftCodeDef value1 + ) + , TestCase + "geq4" + ( compiledGeq + `unsafeApplyCode` liftCodeDef value1 + `unsafeApplyCode` liftCodeDef value3 + ) + , TestCase + "geq5" + ( compiledGeq + `unsafeApplyCode` liftCodeDef value3 + `unsafeApplyCode` liftCodeDef value1 + ) + , TestCase + "currencySymbolValueOf" + ( compiledCurrencySymbolValueOf + `unsafeApplyCode` liftCodeDef value2 + `unsafeApplyCode` liftCodeDef (toSymbol 6) + ) + ] diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/currencySymbolValueOf.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/currencySymbolValueOf.budget.golden new file mode 100644 index 00000000000..abbed7ba5a0 --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/currencySymbolValueOf.budget.golden @@ -0,0 +1,2 @@ +({cpu: 33082379 +| mem: 86164}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/currencySymbolValueOf.eval.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/currencySymbolValueOf.eval.golden new file mode 100644 index 00000000000..63195b8553f --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/currencySymbolValueOf.eval.golden @@ -0,0 +1 @@ +(con integer 3636) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/currencySymbolValueOf.pir.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/currencySymbolValueOf.pir.golden new file mode 100644 index 00000000000..965d81cad4c --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/currencySymbolValueOf.pir.golden @@ -0,0 +1,105 @@ +let + data Unit | Unit_match where + Unit : Unit + data (Tuple2 :: * -> * -> *) a b | Tuple2_match where + Tuple2 : a -> b -> Tuple2 a b +in +letrec + data (List :: * -> *) a | List_match where + Nil : List a + Cons : a -> List a -> List a +in +letrec + !go : list (pair data data) -> List (Tuple2 bytestring integer) + = \(xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> List (Tuple2 bytestring integer)} + xs + (\(ds : Unit) -> Nil {Tuple2 bytestring integer}) + (\(ds : Unit) -> + let + !hd : pair data data = headList {pair data data} xs + !tl : list (pair data data) = tailList {pair data data} xs + in + Cons + {Tuple2 bytestring integer} + (Tuple2 + {bytestring} + {integer} + (unBData (fstPair {data} {data} hd)) + (unIData (sndPair {data} {data} hd))) + (go tl)) + Unit +in +letrec + !go : List (Tuple2 bytestring integer) -> integer + = \(ds : List (Tuple2 bytestring integer)) -> + List_match + {Tuple2 bytestring integer} + ds + {all dead. integer} + (/\dead -> 0) + (\(x : Tuple2 bytestring integer) + (xs : List (Tuple2 bytestring integer)) -> + /\dead -> + Tuple2_match + {bytestring} + {integer} + x + {integer} + (\(ds : bytestring) (amt : integer) -> addInteger amt (go xs))) + {all dead. dead} +in +let + data Bool | Bool_match where + True : Bool + False : Bool + data (Maybe :: * -> *) a | Maybe_match where + Just : a -> Maybe a + Nothing : Maybe a +in +\(ds : + (\k a -> list (pair data data)) + bytestring + ((\k a -> list (pair data data)) bytestring integer)) + (cur : bytestring) -> + Maybe_match + {data} + (let + !k : data = bData cur + in + letrec + !go : list (pair data data) -> Maybe data + = \(xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> Maybe data} + xs + (\(ds : Unit) -> Nothing {data}) + (\(ds : Unit) -> + let + !hd : pair data data = headList {pair data data} xs + in + ifThenElse + {all dead. Maybe data} + (equalsData k (fstPair {data} {data} hd)) + (/\dead -> + let + !ds : list (pair data data) + = tailList {pair data data} xs + in + Just {data} (sndPair {data} {data} hd)) + (/\dead -> go (tailList {pair data data} xs)) + {all dead. dead}) + Unit + in + go ds) + {integer} + (\(a : data) -> + go + (let + !d : (\k a -> list (pair data data)) bytestring integer = unMapData a + in + go d)) + 0 \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq1.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq1.budget.golden new file mode 100644 index 00000000000..89ed0eb2340 --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq1.budget.golden @@ -0,0 +1,2 @@ +({cpu: 739705185 +| mem: 1839010}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq1.eval.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq1.eval.golden new file mode 100644 index 00000000000..1dd2b8ed5d3 --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq1.eval.golden @@ -0,0 +1 @@ +(constr 0) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq2.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq2.budget.golden new file mode 100644 index 00000000000..ed161a5c915 --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq2.budget.golden @@ -0,0 +1,2 @@ +({cpu: 783201675 +| mem: 1959530}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq2.eval.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq2.eval.golden new file mode 100644 index 00000000000..f217693e82c --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq2.eval.golden @@ -0,0 +1 @@ +(constr 1) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq3.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq3.budget.golden new file mode 100644 index 00000000000..2413c40bf14 --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq3.budget.golden @@ -0,0 +1,2 @@ +({cpu: 818311935 +| mem: 2051216}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq3.eval.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq3.eval.golden new file mode 100644 index 00000000000..1dd2b8ed5d3 --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq3.eval.golden @@ -0,0 +1 @@ +(constr 0) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq4.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq4.budget.golden new file mode 100644 index 00000000000..83c549f201f --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq4.budget.golden @@ -0,0 +1,2 @@ +({cpu: 704960331 +| mem: 1735702}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq4.eval.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq4.eval.golden new file mode 100644 index 00000000000..f217693e82c --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq4.eval.golden @@ -0,0 +1 @@ +(constr 1) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq5.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq5.budget.golden new file mode 100644 index 00000000000..dc42c028fc9 --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq5.budget.golden @@ -0,0 +1,2 @@ +({cpu: 766598956 +| mem: 1904018}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq5.eval.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq5.eval.golden new file mode 100644 index 00000000000..1dd2b8ed5d3 --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq5.eval.golden @@ -0,0 +1 @@ +(constr 0) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt.pir.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt.pir.golden new file mode 100644 index 00000000000..84085231654 --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt.pir.golden @@ -0,0 +1,804 @@ +let + !`$fToDataInteger_$ctoBuiltinData` : integer -> data + = \(i : integer) -> iData i + data (These :: * -> * -> *) a b | These_match where + That : b -> These a b + These : a -> b -> These a b + This : a -> These a b + !`$fToDataThese_$ctoBuiltinData` : + all a b. (\a -> a -> data) a -> (\a -> a -> data) b -> These a b -> data + = /\a b -> + \(`$dToData` : (\a -> a -> data) a) + (`$dToData` : (\a -> a -> data) b) + (ds : These a b) -> + These_match + {a} + {b} + ds + {data} + (\(arg : b) -> constrData 1 (mkCons {data} (`$dToData` arg) [])) + (\(arg : a) (arg : b) -> + constrData + 2 + (mkCons + {data} + (`$dToData` arg) + (mkCons {data} (`$dToData` arg) []))) + (\(arg : a) -> constrData 0 (mkCons {data} (`$dToData` arg) [])) + ~`$dToData` : These integer integer -> data + = `$fToDataThese_$ctoBuiltinData` + {integer} + {integer} + `$fToDataInteger_$ctoBuiltinData` + `$fToDataInteger_$ctoBuiltinData` + data Bool | Bool_match where + True : Bool + False : Bool + !f : integer -> integer -> Bool + = \(x : integer) (y : integer) -> + ifThenElse {Bool} (lessThanInteger x y) False True + data Unit | Unit_match where + Unit : Unit + !all : + all k a. + (\a -> data -> a) a -> + (a -> Bool) -> + (\k a -> list (pair data data)) k a -> + Bool + = /\k a -> + \(`$dUnsafeFromData` : (\a -> data -> a) a) (p : a -> Bool) -> + letrec + !go : list (pair data data) -> Bool + = \(xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> Bool} + xs + (\(ds : Unit) -> True) + (\(ds : Unit) -> + Bool_match + (p + (`$dUnsafeFromData` + (sndPair + {data} + {data} + (headList {pair data data} xs)))) + {all dead. Bool} + (/\dead -> go (tailList {pair data data} xs)) + (/\dead -> + let + !ds : list (pair data data) + = tailList {pair data data} xs + in + False) + {all dead. dead}) + Unit + in + \(ds : (\k a -> list (pair data data)) k a) -> go ds + !equalsByteString : bytestring -> bytestring -> Bool + = \(x : bytestring) (y : bytestring) -> + ifThenElse {Bool} (equalsByteString x y) True False + data (Tuple2 :: * -> * -> *) a b | Tuple2_match where + Tuple2 : a -> b -> Tuple2 a b +in +letrec + data (List :: * -> *) a | List_match where + Nil : List a + Cons : a -> List a -> List a +in +let + !toList : + all k a. + (\a -> data -> a) k -> + (\a -> data -> a) a -> + (\k a -> list (pair data data)) k a -> + List (Tuple2 k a) + = /\k a -> + \(`$dUnsafeFromData` : (\a -> data -> a) k) + (`$dUnsafeFromData` : (\a -> data -> a) a) -> + letrec + !go : list (pair data data) -> List (Tuple2 k a) + = \(xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> List (Tuple2 k a)} + xs + (\(ds : Unit) -> Nil {Tuple2 k a}) + (\(ds : Unit) -> + let + !hd : pair data data = headList {pair data data} xs + !tl : list (pair data data) + = tailList {pair data data} xs + in + Cons + {Tuple2 k a} + (Tuple2 + {k} + {a} + (`$dUnsafeFromData` (fstPair {data} {data} hd)) + (`$dUnsafeFromData` (sndPair {data} {data} hd))) + (go tl)) + Unit + in + \(d : (\k a -> list (pair data data)) k a) -> go d + !`$fUnsafeFromDataThese_$cunsafeFromBuiltinData` : + all a b. (\a -> data -> a) a -> (\a -> data -> a) b -> data -> These a b + = /\a b -> + \(`$dUnsafeFromData` : (\a -> data -> a) a) + (`$dUnsafeFromData` : (\a -> data -> a) b) + (d : data) -> + let + !tup : pair integer (list data) = unConstrData d + !index : integer = fstPair {integer} {list data} tup + !args : list data = sndPair {integer} {list data} tup + in + ifThenElse + {all dead. These a b} + (equalsInteger 0 index) + (/\dead -> This {a} {b} (`$dUnsafeFromData` (headList {data} args))) + (/\dead -> + ifThenElse + {all dead. These a b} + (equalsInteger 1 index) + (/\dead -> + That {a} {b} (`$dUnsafeFromData` (headList {data} args))) + (/\dead -> + ifThenElse + {all dead. These a b} + (equalsInteger 2 index) + (/\dead -> + These + {a} + {b} + (`$dUnsafeFromData` (headList {data} args)) + (`$dUnsafeFromData` + (headList {data} (tailList {data} args)))) + (/\dead -> error {These a b}) + {all dead. dead}) + {all dead. dead}) + {all dead. dead} + !`$fToDataMap_$ctoBuiltinData` : + all k a. (\k a -> list (pair data data)) k a -> data + = /\k a -> \(ds : (\k a -> list (pair data data)) k a) -> mapData ds + !map : + all k a b. + (\a -> data -> a) a -> + (\a -> a -> data) b -> + (a -> b) -> + (\k a -> list (pair data data)) k a -> + (\k a -> list (pair data data)) k b + = /\k a b -> + \(`$dUnsafeFromData` : (\a -> data -> a) a) + (`$dToData` : (\a -> a -> data) b) + (f : a -> b) -> + letrec + !go : list (pair data data) -> list (pair data data) + = \(xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> list (pair data data)} + xs + (\(ds : Unit) -> []) + (\(ds : Unit) -> + let + !hd : pair data data = headList {pair data data} xs + !tl : list (pair data data) + = tailList {pair data data} xs + !v : data = sndPair {data} {data} hd + in + mkCons + {pair data data} + (mkPairData + (fstPair {data} {data} hd) + (`$dToData` (f (`$dUnsafeFromData` v)))) + (go tl)) + Unit + in + \(ds : (\k a -> list (pair data data)) k a) -> go ds +in +letrec + !safeAppend : + list (pair data data) -> list (pair data data) -> list (pair data data) + = \(xs : list (pair data data)) (xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> list (pair data data)} + xs + (\(ds : Unit) -> xs) + (\(ds : Unit) -> + let + !hd : pair data data = headList {pair data data} xs + !tl : list (pair data data) = tailList {pair data data} xs + !v : data = sndPair {data} {data} hd + !k : data = fstPair {data} {data} hd + in + letrec + !go : list (pair data data) -> list (pair data data) + = \(xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> list (pair data data)} + xs + (\(ds : Unit) -> + mkCons {pair data data} (mkPairData k v) []) + (\(ds : Unit) -> + let + !hd : pair data data = headList {pair data data} xs + !tl : list (pair data data) + = tailList {pair data data} xs + in + ifThenElse + {all dead. list (pair data data)} + (equalsData k (fstPair {data} {data} hd)) + (/\dead -> + mkCons {pair data data} (mkPairData k v) tl) + (/\dead -> mkCons {pair data data} hd (go tl)) + {all dead. dead}) + Unit + in + let + !eta : list (pair data data) = safeAppend tl xs + in + go eta) + Unit +in +let + data (Maybe :: * -> *) a | Maybe_match where + Just : a -> Maybe a + Nothing : Maybe a + !lookup' : data -> list (pair data data) -> Maybe data + = \(k : data) -> + letrec + !go : list (pair data data) -> Maybe data + = \(xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> Maybe data} + xs + (\(ds : Unit) -> Nothing {data}) + (\(ds : Unit) -> + let + !hd : pair data data = headList {pair data data} xs + in + ifThenElse + {all dead. Maybe data} + (equalsData k (fstPair {data} {data} hd)) + (/\dead -> + let + !ds : list (pair data data) + = tailList {pair data data} xs + in + Just {data} (sndPair {data} {data} hd)) + (/\dead -> go (tailList {pair data data} xs)) + {all dead. dead}) + Unit + in + \(m : list (pair data data)) -> go m + !union : + all k a b. + (\a -> data -> a) a -> + (\a -> data -> a) b -> + (\a -> a -> data) a -> + (\a -> a -> data) b -> + (\k a -> list (pair data data)) k a -> + (\k a -> list (pair data data)) k b -> + (\k a -> list (pair data data)) k (These a b) + = /\k a b -> + \(`$dUnsafeFromData` : (\a -> data -> a) a) + (`$dUnsafeFromData` : (\a -> data -> a) b) + (`$dToData` : (\a -> a -> data) a) + (`$dToData` : (\a -> a -> data) b) + (ds : (\k a -> list (pair data data)) k a) -> + letrec + !goRight : list (pair data data) -> list (pair data data) + = \(xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> list (pair data data)} + xs + (\(ds : Unit) -> []) + (\(ds : Unit) -> + let + !hd : pair data data = headList {pair data data} xs + !tl : list (pair data data) + = tailList {pair data data} xs + !v : data = sndPair {data} {data} hd + !k : data = fstPair {data} {data} hd + in + Maybe_match + {data} + (lookup' k ds) + {all dead. list (pair data data)} + (\(r : data) -> + /\dead -> + mkCons + {pair data data} + (mkPairData + k + (`$fToDataThese_$ctoBuiltinData` + {a} + {b} + `$dToData` + `$dToData` + (These + {a} + {b} + (`$dUnsafeFromData` v) + (`$dUnsafeFromData` r)))) + (goRight tl)) + (/\dead -> + mkCons + {pair data data} + (mkPairData + k + (`$fToDataThese_$ctoBuiltinData` + {a} + {b} + `$dToData` + `$dToData` + (That {a} {b} (`$dUnsafeFromData` v)))) + (goRight tl)) + {all dead. dead}) + Unit + in + \(ds : (\k a -> list (pair data data)) k b) -> + letrec + !goLeft : list (pair data data) -> list (pair data data) + = \(xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> list (pair data data)} + xs + (\(ds : Unit) -> []) + (\(ds : Unit) -> + let + !hd : pair data data = headList {pair data data} xs + !tl : list (pair data data) + = tailList {pair data data} xs + !v : data = sndPair {data} {data} hd + !k : data = fstPair {data} {data} hd + in + Maybe_match + {data} + (lookup' k ds) + {all dead. list (pair data data)} + (\(r : data) -> + /\dead -> + mkCons + {pair data data} + (mkPairData + k + (`$fToDataThese_$ctoBuiltinData` + {a} + {b} + `$dToData` + `$dToData` + (These + {a} + {b} + (`$dUnsafeFromData` v) + (`$dUnsafeFromData` r)))) + (goLeft tl)) + (/\dead -> + mkCons + {pair data data} + (mkPairData + k + (`$fToDataThese_$ctoBuiltinData` + {a} + {b} + `$dToData` + `$dToData` + (This {a} {b} (`$dUnsafeFromData` v)))) + (goLeft tl)) + {all dead. dead}) + Unit + in + safeAppend (goLeft ds) (goRight ds) + !unordEqWith : + all k v. + (\a -> a -> a -> Bool) k -> + (v -> Bool) -> + (v -> v -> Bool) -> + List (Tuple2 k v) -> + List (Tuple2 k v) -> + Bool + = /\k v -> + \(`$dEq` : (\a -> a -> a -> Bool) k) + (is : v -> Bool) -> + letrec + !go : List (Tuple2 k v) -> Bool + = \(ds : List (Tuple2 k v)) -> + List_match + {Tuple2 k v} + ds + {all dead. Bool} + (/\dead -> True) + (\(x : Tuple2 k v) (xs : List (Tuple2 k v)) -> + /\dead -> + Tuple2_match + {k} + {v} + x + {Bool} + (\(ipv : k) (ipv : v) -> + Bool_match + (is ipv) + {all dead. Bool} + (/\dead -> go xs) + (/\dead -> False) + {all dead. dead})) + {all dead. dead} + in + letrec + !go : List (Tuple2 k v) -> Bool + = \(ds : List (Tuple2 k v)) -> + List_match + {Tuple2 k v} + ds + {all dead. Bool} + (/\dead -> True) + (\(x : Tuple2 k v) (xs : List (Tuple2 k v)) -> + /\dead -> + Tuple2_match + {k} + {v} + x + {Bool} + (\(ipv : k) (ipv : v) -> + Bool_match + (is ipv) + {all dead. Bool} + (/\dead -> go xs) + (/\dead -> False) + {all dead. dead})) + {all dead. dead} + in + \(eqV : v -> v -> Bool) -> + letrec + !goBoth : + List (Tuple2 k v) -> List (Tuple2 k v) -> Bool + = \(ds : List (Tuple2 k v)) + (kvsR : List (Tuple2 k v)) -> + List_match + {Tuple2 k v} + ds + {all dead. Bool} + (/\dead -> go kvsR) + (\(ipv : Tuple2 k v) + (ipv : List (Tuple2 k v)) -> + /\dead -> + List_match + {Tuple2 k v} + kvsR + {all dead. Bool} + (/\dead -> go ds) + (\(ipv : Tuple2 k v) + (ipv : List (Tuple2 k v)) -> + /\dead -> + Tuple2_match + {k} + {v} + ipv + {Bool} + (\(kL : k) + (vL : v) -> + letrec + !goRight : + List (Tuple2 k v) -> + List (Tuple2 k v) -> + Bool + = \(ds : List (Tuple2 k v)) + (ds : List (Tuple2 k v)) -> + List_match + {Tuple2 k v} + ds + {all dead. Bool} + (/\dead -> False) + (\(kvR : Tuple2 k v) + (kvsR' : + List (Tuple2 k v)) -> + /\dead -> + Tuple2_match + {k} + {v} + kvR + {Bool} + (\(kR : k) + (vR : v) -> + Bool_match + (is vR) + {all dead. Bool} + (/\dead -> + goRight + ds + kvsR') + (/\dead -> + Bool_match + (`$dEq` kL kR) + {all dead. + Bool} + (/\dead -> + Bool_match + (eqV + vL + vR) + {all dead. + Bool} + (/\dead -> + goBoth + ipv + ((let + a + = Tuple2 + k + v + in + letrec + !rev : + List + a -> + List + a -> + List + a + = \(ds : + List + a) + (a : + List + a) -> + List_match + {a} + ds + {all dead. + List + a} + (/\dead -> + a) + (\(x : + a) + (xs : + List + a) -> + /\dead -> + rev + xs + (Cons + {a} + x + a)) + {all dead. + dead} + in + \(eta : + List + a) + (eta : + List + a) -> + rev + eta + eta) + ds + kvsR')) + (/\dead -> + False) + {all dead. + dead}) + (/\dead -> + goRight + (Cons + {Tuple2 + k + v} + kvR + ds) + kvsR') + {all dead. + dead}) + {all dead. dead})) + {all dead. dead} + in + Tuple2_match + {k} + {v} + ipv + {Bool} + (\(kR : k) (vR : v) -> + Bool_match + (`$dEq` kL kR) + {all dead. Bool} + (/\dead -> + Bool_match + (eqV vL vR) + {all dead. Bool} + (/\dead -> goBoth ipv ipv) + (/\dead -> False) + {all dead. dead}) + (/\dead -> + Bool_match + (is vL) + {all dead. Bool} + (/\dead -> goBoth ipv kvsR) + (/\dead -> + goRight + ((let + a = Tuple2 k v + in + \(g : + all b. + (a -> + b -> + b) -> + b -> + b) -> + g + {List a} + (\(ds : a) + (ds : + List a) -> + Cons + {a} + ds + ds) + (Nil {a})) + (/\a -> + \(c : + Tuple2 k v -> + a -> + a) + (n : a) -> + Bool_match + (is vR) + {all dead. a} + (/\dead -> n) + (/\dead -> + c ipv n) + {all dead. + dead})) + ipv) + {all dead. dead}) + {all dead. dead}))) + {all dead. dead}) + {all dead. dead} + in + \(eta : List (Tuple2 k v)) (eta : List (Tuple2 k v)) -> + goBoth eta eta +in +\(l : + (\k a -> list (pair data data)) + bytestring + ((\k a -> list (pair data data)) bytestring integer)) + (r : + (\k a -> list (pair data data)) + bytestring + ((\k a -> list (pair data data)) bytestring integer)) -> + Bool_match + (all + {bytestring} + {(\k a -> list (pair data data)) bytestring (These integer integer)} + (\(eta : data) -> unMapData eta) + (all + {bytestring} + {These integer integer} + (`$fUnsafeFromDataThese_$cunsafeFromBuiltinData` + {integer} + {integer} + unIData + unIData) + (\(k' : These integer integer) -> + These_match + {integer} + {integer} + k' + {Bool} + (\(b : integer) -> f 0 b) + (\(a : integer) (b : integer) -> f a b) + (\(a : integer) -> f a 0))) + (map + {bytestring} + {These + ((\k a -> list (pair data data)) bytestring integer) + ((\k a -> list (pair data data)) bytestring integer)} + {(\k a -> list (pair data data)) bytestring (These integer integer)} + (`$fUnsafeFromDataThese_$cunsafeFromBuiltinData` + {(\k a -> list (pair data data)) bytestring integer} + {(\k a -> list (pair data data)) bytestring integer} + (\(eta : data) -> unMapData eta) + (\(eta : data) -> unMapData eta)) + (`$fToDataMap_$ctoBuiltinData` {bytestring} {These integer integer}) + (\(k : + These + ((\k a -> list (pair data data)) bytestring integer) + ((\k a -> list (pair data data)) bytestring integer)) -> + These_match + {(\k a -> list (pair data data)) bytestring integer} + {(\k a -> list (pair data data)) bytestring integer} + k + {(\k a -> list (pair data data)) + bytestring + (These integer integer)} + (\(b : (\k a -> list (pair data data)) bytestring integer) -> + map + {bytestring} + {integer} + {These integer integer} + unIData + `$dToData` + (\(ds : integer) -> That {integer} {integer} ds) + b) + (\(a : (\k a -> list (pair data data)) bytestring integer) + (b : (\k a -> list (pair data data)) bytestring integer) -> + union + {bytestring} + {integer} + {integer} + unIData + unIData + `$fToDataInteger_$ctoBuiltinData` + `$fToDataInteger_$ctoBuiltinData` + a + b) + (\(a : (\k a -> list (pair data data)) bytestring integer) -> + map + {bytestring} + {integer} + {These integer integer} + unIData + `$dToData` + (\(ds : integer) -> This {integer} {integer} ds) + a)) + (union + {bytestring} + {(\k a -> list (pair data data)) bytestring integer} + {(\k a -> list (pair data data)) bytestring integer} + (\(eta : data) -> unMapData eta) + (\(eta : data) -> unMapData eta) + (`$fToDataMap_$ctoBuiltinData` {bytestring} {integer}) + (`$fToDataMap_$ctoBuiltinData` {bytestring} {integer}) + l + r))) + {all dead. Bool} + (/\dead -> + Bool_match + (unordEqWith + {bytestring} + {(\k a -> list (pair data data)) bytestring integer} + equalsByteString + (all + {bytestring} + {integer} + unIData + (\(v : integer) -> + ifThenElse {Bool} (equalsInteger 0 v) True False)) + (\(ds : (\k a -> list (pair data data)) bytestring integer) + (ds : (\k a -> list (pair data data)) bytestring integer) -> + unordEqWith + {bytestring} + {integer} + equalsByteString + (\(v : integer) -> + ifThenElse {Bool} (equalsInteger 0 v) True False) + (\(x : integer) (y : integer) -> + ifThenElse {Bool} (equalsInteger x y) True False) + (toList {bytestring} {integer} unBData unIData ds) + (toList {bytestring} {integer} unBData unIData ds)) + (toList + {bytestring} + {(\k a -> list (pair data data)) bytestring integer} + unBData + (\(eta : data) -> unMapData eta) + l) + (toList + {bytestring} + {(\k a -> list (pair data data)) bytestring integer} + unBData + (\(eta : data) -> unMapData eta) + r)) + {all dead. Bool} + (/\dead -> False) + (/\dead -> True) + {all dead. dead}) + (/\dead -> False) + {all dead. dead} \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt1.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt1.budget.golden new file mode 100644 index 00000000000..d624eda7107 --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt1.budget.golden @@ -0,0 +1,2 @@ +({cpu: 879764318 +| mem: 2316624}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt1.eval.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt1.eval.golden new file mode 100644 index 00000000000..f217693e82c --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt1.eval.golden @@ -0,0 +1 @@ +(constr 1) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt2.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt2.budget.golden new file mode 100644 index 00000000000..a5f91f9018c --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt2.budget.golden @@ -0,0 +1,2 @@ +({cpu: 783293675 +| mem: 1959930}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt2.eval.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt2.eval.golden new file mode 100644 index 00000000000..f217693e82c --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt2.eval.golden @@ -0,0 +1 @@ +(constr 1) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt3.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt3.budget.golden new file mode 100644 index 00000000000..dd47f2ee99d --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt3.budget.golden @@ -0,0 +1,2 @@ +({cpu: 962305316 +| mem: 2541216}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt3.eval.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt3.eval.golden new file mode 100644 index 00000000000..1dd2b8ed5d3 --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt3.eval.golden @@ -0,0 +1 @@ +(constr 0) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt4.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt4.budget.golden new file mode 100644 index 00000000000..e96cefd5110 --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt4.budget.golden @@ -0,0 +1,2 @@ +({cpu: 705052331 +| mem: 1736102}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt4.eval.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt4.eval.golden new file mode 100644 index 00000000000..f217693e82c --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt4.eval.golden @@ -0,0 +1 @@ +(constr 1) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt5.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt5.budget.golden new file mode 100644 index 00000000000..2e1e0490b28 --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt5.budget.golden @@ -0,0 +1,2 @@ +({cpu: 843304067 +| mem: 2166558}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt5.eval.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt5.eval.golden new file mode 100644 index 00000000000..1dd2b8ed5d3 --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt5.eval.golden @@ -0,0 +1 @@ +(constr 0) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Value.hs b/plutus-ledger-api/test-plugin/Spec/Data/Value.hs new file mode 100644 index 00000000000..7e059a8a95f --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Value.hs @@ -0,0 +1,229 @@ +{-# 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.Data.Value where + +import Prelude qualified as Haskell + +import PlutusLedgerApi.V1.Data.Value + +import PlutusTx.Base +import PlutusTx.Code (CompiledCode, getPlc, unsafeApplyCode) +import PlutusTx.Data.AssocMap qualified as AssocMap +import PlutusTx.Lift +import PlutusTx.List qualified as ListTx +import PlutusTx.Maybe +import PlutusTx.Numeric +import PlutusTx.Prelude hiding (integerToByteString) +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 i2Bs #-} +i2Bs :: Integer -> BuiltinByteString +i2Bs n = + if n < 0 + then "-" `appendByteString` i2Bs (negate n) + -- @48@ is the ASCII code of @0@. + else ListTx.foldr (consByteString . (48 +)) emptyByteString $ toDigits n + +{-# INLINEABLE replicateToByteString #-} +-- | Like 'i2Bs 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 $ i2Bs 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.unsafeFromList . ListTx.map (fmap AssocMap.unsafeFromList) + +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 -> toOpaque ((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)])]] -> TestNested +test_EqCurrencyList name currencyLists = + 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 = + runTestNested ["test-plugin", "Spec", "Data", "Value"] . pure . testNestedGhc $ + [ test_EqCurrencyList "Short" currencyListOptions + , test_EqCurrencyList "Long" currencyLongListOptions + ] diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Long.stat.golden b/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Long.stat.golden new file mode 100644 index 00000000000..b488ff27cce --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Long.stat.golden @@ -0,0 +1,15 @@ +({cpu: 5324257735 | mem: 17865770}) +({cpu: 451118984 | mem: 1465328}) +({cpu: 3717443753 | mem: 12473554}) +({cpu: 374798800 | mem: 1218472}) +({cpu: 3717443753 | mem: 12473554}) +({cpu: 298202616 | mem: 970416}) +({cpu: 2110629771 | mem: 7081338}) +({cpu: 298340616 | mem: 971016}) +({cpu: 3717443753 | mem: 12473554}) +({cpu: 298202616 | mem: 970416}) +({cpu: 2110629771 | mem: 7081338}) +({cpu: 221882432 | mem: 723560}) +({cpu: 2110629771 | mem: 7081338}) +({cpu: 145286248 | mem: 475504}) +({cpu: 503815789 | mem: 1689122}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Short.stat.golden b/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Short.stat.golden new file mode 100644 index 00000000000..1641ec2b485 --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Short.stat.golden @@ -0,0 +1,21 @@ +({cpu: 4536808 | mem: 18364}) +({cpu: 7438848 | mem: 28320}) +({cpu: 13490279 | mem: 50678}) +({cpu: 16373497 | mem: 60004}) +({cpu: 19540617 | mem: 70530}) +({cpu: 23221865 | mem: 81816}) +({cpu: 34544860 | mem: 122696}) +({cpu: 36200342 | mem: 127688}) +({cpu: 43498331 | mem: 155010}) +({cpu: 32763609 | mem: 113010}) +({cpu: 64553346 | mem: 227028}) +({cpu: 33760071 | mem: 115624}) +({cpu: 91658699 | mem: 318898}) +({cpu: 99450348 | mem: 336974}) +({cpu: 124820032 | mem: 430620}) +({cpu: 132611681 | mem: 448696}) +({cpu: 164032137 | mem: 562194}) +({cpu: 167713385 | mem: 573480}) +({cpu: 209295014 | mem: 713620}) +({cpu: 108360750 | mem: 360956}) +({cpu: 503815789 | mem: 1689122}) \ No newline at end of file diff --git a/plutus-ledger-api/test/Spec.hs b/plutus-ledger-api/test/Spec.hs index dba560ad665..76ae0a85823 100644 --- a/plutus-ledger-api/test/Spec.hs +++ b/plutus-ledger-api/test/Spec.hs @@ -14,6 +14,7 @@ import Spec.CostModelParams qualified import Spec.Eval qualified import Spec.Interval qualified import Spec.ScriptDecodeError qualified +import Spec.V1.Data.Value qualified as Data.Value import Spec.V1.Value qualified as Value import Spec.Versions qualified @@ -126,4 +127,5 @@ tests = testGroup "plutus-ledger-api"[ , Spec.ScriptDecodeError.tests , Spec.ContextDecoding.tests , Value.test_Value + , Data.Value.test_Value ] diff --git a/plutus-ledger-api/test/Spec/V1/Data/Value.hs b/plutus-ledger-api/test/Spec/V1/Data/Value.hs new file mode 100644 index 00000000000..81a5326cbdb --- /dev/null +++ b/plutus-ledger-api/test/Spec/V1/Data/Value.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE MultiWayIf #-} + +module Spec.V1.Data.Value where + +import PlutusLedgerApi.Test.V1.Data.Value as Value +-- TODO: import a new PlutusLedgerApi.Data.V1 module instead +import PlutusLedgerApi.V1.Data.Value +import PlutusTx.Numeric qualified as Numeric + +import Control.Lens +import Data.List (sort) +import Test.Tasty +import Test.Tasty.QuickCheck + +infix 4 <=>, + +-- | Ensure that @x@ equals @y@ and vice versa. The latter part is needed to ensure that @(==)@ is +-- symmetric for the specific type. +(<=>) :: (Eq a, Show a) => a -> a -> Property +x <=> y = x === y .&&. y === x + +-- | Ensure that @x@ doesn't equal @y@ and vice versa. The latter part is needed to ensure that +-- @(/=)@ is symmetric for the specific type. +() :: (Eq a, Show a) => a -> a -> Property +x y = x =/= y .&&. y =/= x + +scaleTestsBy :: Testable prop => Int -> prop -> Property +scaleTestsBy factor = withMaxSuccess (100 * factor) . mapSize (* factor) + +-- | Apply a function to an arbitrary number of elements of the given list. The elements are chosen +-- at random. +mapMany :: (a -> Gen a) -> [a] -> Gen [a] +mapMany f = traverse $ \x -> do + b <- arbitrary + if b then f x else pure x + +-- | Apply a function to an arbitrary non-zero number of elements of the given list. The elements +-- are chosen at random. +mapSome :: Eq a => (a -> Gen a) -> [a] -> Gen [a] +mapSome f xs = do + xs' <- mapMany f xs + i <- choose (0, length xs - 1) + let xi = xs !! i + ix i (\x -> if x == xi then f x else pure x) xs' + +-- | Generate an 'Integer' that is not equal to the given one. +updateInteger :: Integer -> Gen Integer +updateInteger i = arbitrary `suchThat` (/= i) + +-- | Generate new 'TokenName's such that the resulting list, being sorted, is not equal to the given +-- one, being sorted as well. +freshenTokenNames :: [(TokenName, Integer)] -> Gen [(TokenName, Integer)] +freshenTokenNames tokens = + uniqueNames TokenName (map snd tokens) `suchThat` \tokens' -> + sort (filter ((/= 0) . snd) tokens) /= sort (filter ((/= 0) . snd) tokens') + +onLists + :: Value + -> ([(CurrencySymbol, [(TokenName, Integer)])] -> + Gen [(CurrencySymbol, [(TokenName, Integer)])]) + -> (Value -> Property) + -> Property +onLists value f = forAll (fmap listsToValue . f $ valueToLists value) + +-- | Test various laws for operations over 'Value'. +test_laws :: TestTree +test_laws = testProperty "laws" . scaleTestsBy 5 $ \value1 -> conjoin + [ value1 <> value1 <=> Numeric.scale 2 value1 + , value1 <> Numeric.negate value1 <=> mempty + , if isZero value1 + then conjoin + [ value1 <=> mempty + , forAll arbitrary $ \value2 -> value1 <> value2 <=> value2 + ] + else conjoin + [ value1 mempty + , forAll arbitrary $ \value2 -> + if isZero value2 + then value1 <> value2 <=> value1 + else conjoin + [ value1 <> value2 value1 + , value1 <> value2 value2 + , value1 <> value2 <=> value2 <> value1 + , forAll arbitrary $ \value3 -> + not (isZero value3) ==> + (value1 <> value2) <> value3 <=> value1 <> (value2 <> value3) + ] + ] + ] + +-- | Test that changing the values of some of the values of 'TokenName's creates a different +-- 'Value'. +test_updateSomeTokenValues :: TestTree +test_updateSomeTokenValues = testProperty "updateSomeTokenValues" . scaleTestsBy 15 $ \prevalue -> + let lists = filter (not . null . snd) $ valueToLists prevalue + value = listsToValue lists + in not (null lists) ==> + onLists value (mapSome . traverse . mapSome $ traverse updateInteger) + (\value' -> value value') + +-- | Test that changing the values of some of the 'TokenName's creates a different 'Value'. +test_updateSomeTokenNames :: TestTree +test_updateSomeTokenNames = testProperty "updateSomeTokenNames" . scaleTestsBy 15 $ \prevalue -> + let lists = filter (not . null . snd) . map (fmap . filter $ (/= 0) . snd) $ + valueToLists prevalue + value = listsToValue lists + in not (null lists) ==> + onLists value (mapSome $ traverse freshenTokenNames) + (\value' -> value value') + +-- | Test that shuffling 'CurrencySymbol's or 'TokenName's creates a 'Value' that is equal to the +-- original one. +test_shuffle :: TestTree +test_shuffle = testProperty "shuffle" . scaleTestsBy 10 $ \value1 -> + conjoin + [ onLists value1 shuffle $ \value1' -> value1 <=> value1' + , onLists value1 (mapMany $ traverse shuffle) $ \value1' -> value1 <=> value1' + ] + +test_split :: TestTree +test_split = testProperty "split" . scaleTestsBy 7 $ \value -> + let (valueL, valueR) = split value + in Numeric.negate valueL <> valueR <=> value + +test_Value :: TestTree +test_Value = testGroup "Value" + [ test_laws + , test_updateSomeTokenValues + , test_updateSomeTokenNames + , test_shuffle + , test_split + ] diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V1/Data/Value.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V1/Data/Value.hs new file mode 100644 index 00000000000..da17fcc4e9e --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V1/Data/Value.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module PlutusLedgerApi.Test.V1.Data.Value where + +-- TODO: import a new PlutusLedgerApi.Data.V1 module instead +import PlutusLedgerApi.V1.Data.Value +import PlutusTx.Builtins hiding (error) +-- +import PlutusTx.Data.AssocMap qualified as AssocMap +import PlutusTx.List qualified as ListTx + +import PlutusCore.Generators.QuickCheck.Utils (multiSplit0, 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'. +listsToValue :: [(CurrencySymbol, [(TokenName, Integer)])] -> Value +listsToValue = Value . AssocMap.unsafeFromList . ListTx.map (fmap AssocMap.unsafeFromList) + +-- | Convert a 'Value' to its list representation. +valueToLists :: Value -> [(CurrencySymbol, [(TokenName, Integer)])] +valueToLists = ListTx.map (fmap AssocMap.toList) . AssocMap.toList . getValue + +-- | Return how many candidates to randomly choose from to fill the given number of cells. For +-- example, if we only need to fill a single cell, we choose from 6 different candidates, and if we +-- need to fill 5 cells, we choose from 11 candidates. +-- +-- >>> map (\i -> (i, toCellCandidatesNumber i)) [1..13] +-- [(1,6),(2,6),(3,6),(4,8),(5,11),(6,14),(7,18),(8,22),(9,27),(10,31),(11,36),(12,41),(13,46)] +toCellCandidatesNumber :: Int -> Int +toCellCandidatesNumber i = max 6 . floor @Double $ fromIntegral i ** 1.5 + +-- | Generate a 'BuiltinByteString' by picking one of the predetermined ones, given a number of +-- cells to fill (see 'toCellCandidatesNumber'). The idea is that we want to occasionally generate +-- the same 'CurrencySymbol' or 'TokenName' for different 'Value's to have decent test coverage, +-- hence to make name clashing more likely we pick from a predetermined set of +-- 'BuiltinByteString's. Otherwise the chance of generating the same 'BuiltinByteString' for two +-- different 'Value's would be virtually zero. +genShortHex :: Int -> Gen BuiltinByteString +genShortHex i = + toBuiltin . Base16.encode . BS8.pack . show <$> elements [0 .. toCellCandidatesNumber i] + +-- | Annotate each element of the give list with a @name@, given a function turning +-- 'BuiltinByteString' into names. +uniqueNames :: Eq name => (BuiltinByteString -> name) -> [b] -> Gen [(name, b)] +uniqueNames wrap ys = do + let len = length ys + -- We always generate unique 'CurrencySymbol's within a single 'Value' and 'TokenName' within a + -- single 'CurrencySymbol', because functions over 'Value' don't handle duplicated names anyway. + -- Note that we can generate the same 'TokenName' within different 'CurrencySymbol's within the + -- same 'Value'. + xs <- uniqueVectorOf len $ wrap <$> genShortHex len + pure $ zip xs ys + +-- | The value of a 'TokenName' in a 'Value'. +newtype FaceValue = FaceValue + { unFaceValue :: Integer + } + +instance Arbitrary FaceValue where + -- We want to generate zeroes often, because there's a lot of corner cases associated with them + -- and all non-zero numbers are handled pretty much the same anyway, so there isn't much point + -- in diversifying them as much as possible. + arbitrary = frequency + [ (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 From 239026794490086735b90090bceae20b5fde19ee Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Thu, 30 May 2024 18:08:19 +0300 Subject: [PATCH 03/13] Improve performance of currencySymbolValueOf Signed-off-by: Ana Pantilie --- .../src/PlutusLedgerApi/V1/Data/Value.hs | 3 +-- plutus-tx/src/PlutusTx/Data/AssocMap.hs | 19 +++++++++++++++++-- 2 files changed, 18 insertions(+), 4 deletions(-) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs index 63c501f478e..ce1461f7873 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs @@ -72,7 +72,6 @@ import PlutusTx qualified import PlutusTx.Builtins.Internal (BuiltinList) import PlutusTx.Data.AssocMap qualified as Map import PlutusTx.Lift (makeLift) -import PlutusTx.List qualified import PlutusTx.Ord qualified as Ord import PlutusTx.Prelude as PlutusTx hiding (sort) import PlutusTx.Show qualified as PlutusTx @@ -280,7 +279,7 @@ currencySymbolValueOf (Value mp) cur = case Map.lookup cur mp of Just tokens -> -- This is more efficient than `PlutusTx.sum (Map.elems tokens)`, because -- the latter materializes the intermediate result of `Map.elems tokens`. - PlutusTx.List.foldr (\(_, amt) acc -> amt + acc) 0 (Map.toList tokens) + Map.foldr (\amt acc -> amt + acc) 0 tokens {-# INLINABLE symbols #-} -- | The list of 'CurrencySymbol's of a 'Value'. diff --git a/plutus-tx/src/PlutusTx/Data/AssocMap.hs b/plutus-tx/src/PlutusTx/Data/AssocMap.hs index 0dc01146677..00b83a9e71f 100644 --- a/plutus-tx/src/PlutusTx/Data/AssocMap.hs +++ b/plutus-tx/src/PlutusTx/Data/AssocMap.hs @@ -27,13 +27,15 @@ module PlutusTx.Data.AssocMap ( keys, map, mapThese, + foldr, ) where import PlutusTx.Builtins qualified as P import PlutusTx.Builtins.Internal qualified as BI import PlutusTx.IsData qualified as P import PlutusTx.Lift (makeLift) -import PlutusTx.Prelude hiding (all, any, map, null, toList, uncons) +import PlutusTx.List qualified as List +import PlutusTx.Prelude hiding (all, any, foldr, map, null, toList, uncons) import PlutusTx.Prelude qualified import PlutusTx.These @@ -198,7 +200,7 @@ safeFromList :: forall k a . (P.ToData k, P.ToData a) =>[(k, a)] -> Map k a safeFromList = Map . toOpaque - . foldr (uncurry go) [] + . List.foldr (uncurry go) [] where go k v [] = [(P.toBuiltinData k, P.toBuiltinData v)] go k v ((k', v') : rest) = @@ -432,6 +434,7 @@ keys' = go keys :: forall k a. Map k a -> BI.BuiltinList BuiltinData keys (Map m) = keys' m +{-# INLINEABLE mapThese #-} mapThese :: forall v k a b . ( P.ToData a, P.ToData b, P.UnsafeFromData v) @@ -481,4 +484,16 @@ map f (Map m) = Map $ go m (go tl) ) +foldr :: forall a b k. (P.UnsafeFromData a) => (a -> b -> b) -> b -> Map k a -> b +foldr f z (Map m) = go m + where + go xs = + P.matchList + xs + (\() -> z) + ( \hd tl -> + let v = BI.snd hd + in f (P.unsafeFromBuiltinData v) (go tl) + ) + makeLift ''Map From 13395371801fcc9eda0d08f3369972ca74536e8e Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Thu, 30 May 2024 19:02:01 +0300 Subject: [PATCH 04/13] Try to Value -> [(,)] ahead of equality check Signed-off-by: Ana Pantilie --- .../src/PlutusLedgerApi/V1/Data/Value.hs | 33 +++- .../9.6/currencySymbolValueOf.budget.golden | 4 +- .../9.6/currencySymbolValueOf.pir.golden | 50 +---- .../Spec/Data/Budget/9.6/gt.pir.golden | 184 +++++++++++------- .../Spec/Data/Budget/9.6/gt1.budget.golden | 4 +- .../Spec/Data/Budget/9.6/gt2.budget.golden | 4 +- .../Spec/Data/Budget/9.6/gt3.budget.golden | 4 +- .../Spec/Data/Budget/9.6/gt4.budget.golden | 4 +- .../Spec/Data/Budget/9.6/gt5.budget.golden | 4 +- .../Spec/Data/Value/9.6/Long.stat.golden | 30 +-- .../Spec/Data/Value/9.6/Short.stat.golden | 42 ++-- plutus-tx/src/PlutusTx/Data/AssocMap.hs | 2 +- 12 files changed, 199 insertions(+), 166 deletions(-) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs index ce1461f7873..3f1fb0ef5b1 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs @@ -67,11 +67,15 @@ import Data.Text (Text) import Data.Text qualified as Text import Data.Text.Encoding qualified as E import GHC.Generics (Generic) +import PlutusLedgerApi.V1 (UnsafeFromData (unsafeFromBuiltinData)) import PlutusLedgerApi.V1.Bytes (LedgerBytes (LedgerBytes), encodeByteString) import PlutusTx qualified -import PlutusTx.Builtins.Internal (BuiltinList) +import PlutusTx.Builtins qualified as B +import PlutusTx.Builtins.Internal (BuiltinList, BuiltinPair) +import PlutusTx.Builtins.Internal qualified as BI import PlutusTx.Data.AssocMap qualified as Map import PlutusTx.Lift (makeLift) +import PlutusTx.List qualified as List import PlutusTx.Ord qualified as Ord import PlutusTx.Prelude as PlutusTx hiding (sort) import PlutusTx.Show qualified as PlutusTx @@ -506,7 +510,32 @@ eqMapWith is0 eqV (Map.toList -> xs1) (Map.toList -> xs2) = unordEqWith is0 eqV -- tokens or no tokens at all), but does assume that no currencies or tokens within a single -- currency have multiple entries. eq :: Value -> Value -> Bool -eq (Value currs1) (Value currs2) = eqMapWith (Map.all (0 ==)) (eqMapWith (0 ==) (==)) currs1 currs2 +eq (valueToList -> currs1) (valueToList -> currs2) = + unordEqWith + (List.all (0 ==) . fmap snd) + (unordEqWith (0 ==) (==)) + currs1 + currs2 + +valueToList :: Value -> [(CurrencySymbol, [(TokenName, Integer)])] +valueToList (Map.toBuiltinList . getValue -> bList) = + go bList + where + go l = + B.matchList + l + (\() -> []) + ( \hd tl -> + (unsafeFromBuiltinData (BI.fst hd), go' . BI.unsafeDataAsMap . BI.snd $ hd) : go tl + ) + + go' l = + B.matchList + l + (\() -> []) + ( \hd tl -> + (unsafeFromBuiltinData (BI.fst hd), unsafeFromBuiltinData (BI.snd hd)) : go' tl + ) newtype Lovelace = Lovelace { getLovelace :: Integer } deriving stock (Generic) diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/currencySymbolValueOf.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/currencySymbolValueOf.budget.golden index abbed7ba5a0..665d38b52f4 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/currencySymbolValueOf.budget.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/currencySymbolValueOf.budget.golden @@ -1,2 +1,2 @@ -({cpu: 33082379 -| mem: 86164}) \ No newline at end of file +({cpu: 27490443 +| mem: 64380}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/currencySymbolValueOf.pir.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/currencySymbolValueOf.pir.golden index 965d81cad4c..e40fc85f47f 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/currencySymbolValueOf.pir.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/currencySymbolValueOf.pir.golden @@ -1,56 +1,23 @@ let data Unit | Unit_match where Unit : Unit - data (Tuple2 :: * -> * -> *) a b | Tuple2_match where - Tuple2 : a -> b -> Tuple2 a b in letrec - data (List :: * -> *) a | List_match where - Nil : List a - Cons : a -> List a -> List a -in -letrec - !go : list (pair data data) -> List (Tuple2 bytestring integer) + !go : list (pair data data) -> integer = \(xs : list (pair data data)) -> chooseList {pair data data} - {Unit -> List (Tuple2 bytestring integer)} + {Unit -> integer} xs - (\(ds : Unit) -> Nil {Tuple2 bytestring integer}) + (\(ds : Unit) -> 0) (\(ds : Unit) -> let !hd : pair data data = headList {pair data data} xs !tl : list (pair data data) = tailList {pair data data} xs in - Cons - {Tuple2 bytestring integer} - (Tuple2 - {bytestring} - {integer} - (unBData (fstPair {data} {data} hd)) - (unIData (sndPair {data} {data} hd))) - (go tl)) + addInteger (unIData (sndPair {data} {data} hd)) (go tl)) Unit in -letrec - !go : List (Tuple2 bytestring integer) -> integer - = \(ds : List (Tuple2 bytestring integer)) -> - List_match - {Tuple2 bytestring integer} - ds - {all dead. integer} - (/\dead -> 0) - (\(x : Tuple2 bytestring integer) - (xs : List (Tuple2 bytestring integer)) -> - /\dead -> - Tuple2_match - {bytestring} - {integer} - x - {integer} - (\(ds : bytestring) (amt : integer) -> addInteger amt (go xs))) - {all dead. dead} -in let data Bool | Bool_match where True : Bool @@ -97,9 +64,8 @@ in go ds) {integer} (\(a : data) -> - go - (let - !d : (\k a -> list (pair data data)) bytestring integer = unMapData a - in - go d)) + let + !ds : (\k a -> list (pair data data)) bytestring integer = unMapData a + in + go ds) 0 \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt.pir.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt.pir.golden index 84085231654..66fbbf37bc4 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt.pir.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt.pir.golden @@ -1,3 +1,57 @@ +let + data (Tuple2 :: * -> * -> *) a b | Tuple2_match where + Tuple2 : a -> b -> Tuple2 a b +in +letrec + data (List :: * -> *) a | List_match where + Nil : List a + Cons : a -> List a -> List a +in +letrec + !go : List (Tuple2 bytestring integer) -> List integer + = \(ds : List (Tuple2 bytestring integer)) -> + List_match + {Tuple2 bytestring integer} + ds + {all dead. List integer} + (/\dead -> Nil {integer}) + (\(x : Tuple2 bytestring integer) + (xs : List (Tuple2 bytestring integer)) -> + /\dead -> + Cons + {integer} + (Tuple2_match + {bytestring} + {integer} + x + {integer} + (\(ds : bytestring) (b : integer) -> b)) + (go xs)) + {all dead. dead} +in +let + data Bool | Bool_match where + True : Bool + False : Bool +in +letrec + !go : List integer -> Bool + = \(ds : List integer) -> + List_match + {integer} + ds + {all dead. Bool} + (/\dead -> True) + (\(x : integer) (xs : List integer) -> + /\dead -> + ifThenElse + {all dead. Bool} + (equalsInteger 0 x) + (/\dead -> go xs) + (/\dead -> False) + {all dead. dead}) + {all dead. dead} +in let !`$fToDataInteger_$ctoBuiltinData` : integer -> data = \(i : integer) -> iData i @@ -31,9 +85,6 @@ let {integer} `$fToDataInteger_$ctoBuiltinData` `$fToDataInteger_$ctoBuiltinData` - data Bool | Bool_match where - True : Bool - False : Bool !f : integer -> integer -> Bool = \(x : integer) (y : integer) -> ifThenElse {Bool} (lessThanInteger x y) False True @@ -75,52 +126,58 @@ let Unit in \(ds : (\k a -> list (pair data data)) k a) -> go ds - !equalsByteString : bytestring -> bytestring -> Bool - = \(x : bytestring) (y : bytestring) -> - ifThenElse {Bool} (equalsByteString x y) True False - data (Tuple2 :: * -> * -> *) a b | Tuple2_match where - Tuple2 : a -> b -> Tuple2 a b in letrec - data (List :: * -> *) a | List_match where - Nil : List a - Cons : a -> List a -> List a + !`$fEqValue_go'` : list (pair data data) -> List (Tuple2 bytestring integer) + = \(l : list (pair data data)) -> + let + ~hd : pair data data = headList {pair data data} l + in + chooseList + {pair data data} + {Unit -> List (Tuple2 bytestring integer)} + l + (\(ds : Unit) -> Nil {Tuple2 bytestring integer}) + (\(ds : Unit) -> + Cons + {Tuple2 bytestring integer} + (Tuple2 + {bytestring} + {integer} + (unBData (fstPair {data} {data} hd)) + (unIData (sndPair {data} {data} hd))) + (`$fEqValue_go'` (tailList {pair data data} l))) + Unit +in +letrec + !`$fEqValue_go` : + list (pair data data) -> + List (Tuple2 bytestring (List (Tuple2 bytestring integer))) + = \(l : list (pair data data)) -> + let + ~hd : pair data data = headList {pair data data} l + in + chooseList + {pair data data} + {Unit -> List (Tuple2 bytestring (List (Tuple2 bytestring integer)))} + l + (\(ds : Unit) -> + Nil {Tuple2 bytestring (List (Tuple2 bytestring integer))}) + (\(ds : Unit) -> + Cons + {Tuple2 bytestring (List (Tuple2 bytestring integer))} + (Tuple2 + {bytestring} + {List (Tuple2 bytestring integer)} + (unBData (fstPair {data} {data} hd)) + (`$fEqValue_go'` (unMapData (sndPair {data} {data} hd)))) + (`$fEqValue_go` (tailList {pair data data} l))) + Unit in let - !toList : - all k a. - (\a -> data -> a) k -> - (\a -> data -> a) a -> - (\k a -> list (pair data data)) k a -> - List (Tuple2 k a) - = /\k a -> - \(`$dUnsafeFromData` : (\a -> data -> a) k) - (`$dUnsafeFromData` : (\a -> data -> a) a) -> - letrec - !go : list (pair data data) -> List (Tuple2 k a) - = \(xs : list (pair data data)) -> - chooseList - {pair data data} - {Unit -> List (Tuple2 k a)} - xs - (\(ds : Unit) -> Nil {Tuple2 k a}) - (\(ds : Unit) -> - let - !hd : pair data data = headList {pair data data} xs - !tl : list (pair data data) - = tailList {pair data data} xs - in - Cons - {Tuple2 k a} - (Tuple2 - {k} - {a} - (`$dUnsafeFromData` (fstPair {data} {data} hd)) - (`$dUnsafeFromData` (sndPair {data} {data} hd))) - (go tl)) - Unit - in - \(d : (\k a -> list (pair data data)) k a) -> go d + !equalsByteString : bytestring -> bytestring -> Bool + = \(x : bytestring) (y : bytestring) -> + ifThenElse {Bool} (equalsByteString x y) True False !`$fUnsafeFromDataThese_$cunsafeFromBuiltinData` : all a b. (\a -> data -> a) a -> (\a -> data -> a) b -> data -> These a b = /\a b -> @@ -764,38 +821,19 @@ in Bool_match (unordEqWith {bytestring} - {(\k a -> list (pair data data)) bytestring integer} + {List (Tuple2 bytestring integer)} equalsByteString - (all + (\(eta : List (Tuple2 bytestring integer)) -> go (go eta)) + (unordEqWith {bytestring} {integer} - unIData + equalsByteString (\(v : integer) -> - ifThenElse {Bool} (equalsInteger 0 v) True False)) - (\(ds : (\k a -> list (pair data data)) bytestring integer) - (ds : (\k a -> list (pair data data)) bytestring integer) -> - unordEqWith - {bytestring} - {integer} - equalsByteString - (\(v : integer) -> - ifThenElse {Bool} (equalsInteger 0 v) True False) - (\(x : integer) (y : integer) -> - ifThenElse {Bool} (equalsInteger x y) True False) - (toList {bytestring} {integer} unBData unIData ds) - (toList {bytestring} {integer} unBData unIData ds)) - (toList - {bytestring} - {(\k a -> list (pair data data)) bytestring integer} - unBData - (\(eta : data) -> unMapData eta) - l) - (toList - {bytestring} - {(\k a -> list (pair data data)) bytestring integer} - unBData - (\(eta : data) -> unMapData eta) - r)) + ifThenElse {Bool} (equalsInteger 0 v) True False) + (\(x : integer) (y : integer) -> + ifThenElse {Bool} (equalsInteger x y) True False)) + (`$fEqValue_go` l) + (`$fEqValue_go` r)) {all dead. Bool} (/\dead -> False) (/\dead -> True) diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt1.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt1.budget.golden index d624eda7107..9098a061ff4 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt1.budget.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt1.budget.golden @@ -1,2 +1,2 @@ -({cpu: 879764318 -| mem: 2316624}) \ No newline at end of file +({cpu: 867689318 +| mem: 2264124}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt2.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt2.budget.golden index a5f91f9018c..be5876cbc79 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt2.budget.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt2.budget.golden @@ -1,2 +1,2 @@ -({cpu: 783293675 -| mem: 1959930}) \ No newline at end of file +({cpu: 784673675 +| mem: 1965930}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt3.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt3.budget.golden index dd47f2ee99d..ce9043a45fc 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt3.budget.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt3.budget.golden @@ -1,2 +1,2 @@ -({cpu: 962305316 -| mem: 2541216}) \ No newline at end of file +({cpu: 962726971 +| mem: 2532132}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt4.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt4.budget.golden index e96cefd5110..4d255f7bb3c 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt4.budget.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt4.budget.golden @@ -1,2 +1,2 @@ -({cpu: 705052331 -| mem: 1736102}) \ No newline at end of file +({cpu: 706432331 +| mem: 1742102}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt5.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt5.budget.golden index 2e1e0490b28..7bca1612d9b 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt5.budget.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt5.budget.golden @@ -1,2 +1,2 @@ -({cpu: 843304067 -| mem: 2166558}) \ No newline at end of file +({cpu: 867140605 +| mem: 2232118}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Long.stat.golden b/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Long.stat.golden index b488ff27cce..e9c23e34292 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Long.stat.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Long.stat.golden @@ -1,15 +1,15 @@ -({cpu: 5324257735 | mem: 17865770}) -({cpu: 451118984 | mem: 1465328}) -({cpu: 3717443753 | mem: 12473554}) -({cpu: 374798800 | mem: 1218472}) -({cpu: 3717443753 | mem: 12473554}) -({cpu: 298202616 | mem: 970416}) -({cpu: 2110629771 | mem: 7081338}) -({cpu: 298340616 | mem: 971016}) -({cpu: 3717443753 | mem: 12473554}) -({cpu: 298202616 | mem: 970416}) -({cpu: 2110629771 | mem: 7081338}) -({cpu: 221882432 | mem: 723560}) -({cpu: 2110629771 | mem: 7081338}) -({cpu: 145286248 | mem: 475504}) -({cpu: 503815789 | mem: 1689122}) \ No newline at end of file +({cpu: 4913776735 | mem: 16081070}) +({cpu: 2331301382 | mem: 7278268}) +({cpu: 3431714753 | mem: 11231254}) +({cpu: 1918223822 | mem: 5990004}) +({cpu: 3431714753 | mem: 11231254}) +({cpu: 1504870262 | mem: 4700540}) +({cpu: 1949652771 | mem: 6381438}) +({cpu: 1505008262 | mem: 4701140}) +({cpu: 3431714753 | mem: 11231254}) +({cpu: 1504870262 | mem: 4700540}) +({cpu: 1949652771 | mem: 6381438}) +({cpu: 1091792702 | mem: 3412276}) +({cpu: 1949652771 | mem: 6381438}) +({cpu: 678439142 | mem: 2122812}) +({cpu: 467590789 | mem: 1531622}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Short.stat.golden b/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Short.stat.golden index 1641ec2b485..6f40f116c05 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Short.stat.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Short.stat.golden @@ -1,21 +1,21 @@ -({cpu: 4536808 | mem: 18364}) -({cpu: 7438848 | mem: 28320}) -({cpu: 13490279 | mem: 50678}) -({cpu: 16373497 | mem: 60004}) -({cpu: 19540617 | mem: 70530}) -({cpu: 23221865 | mem: 81816}) -({cpu: 34544860 | mem: 122696}) -({cpu: 36200342 | mem: 127688}) -({cpu: 43498331 | mem: 155010}) -({cpu: 32763609 | mem: 113010}) -({cpu: 64553346 | mem: 227028}) -({cpu: 33760071 | mem: 115624}) -({cpu: 91658699 | mem: 318898}) -({cpu: 99450348 | mem: 336974}) -({cpu: 124820032 | mem: 430620}) -({cpu: 132611681 | mem: 448696}) -({cpu: 164032137 | mem: 562194}) -({cpu: 167713385 | mem: 573480}) -({cpu: 209295014 | mem: 713620}) -({cpu: 108360750 | mem: 360956}) -({cpu: 503815789 | mem: 1689122}) \ No newline at end of file +({cpu: 5709808 | mem: 23464}) +({cpu: 8795848 | mem: 34220}) +({cpu: 12455279 | mem: 46178}) +({cpu: 15269497 | mem: 55204}) +({cpu: 18367617 | mem: 65430}) +({cpu: 23876875 | mem: 83512}) +({cpu: 31025860 | mem: 107396}) +({cpu: 34310998 | mem: 119052}) +({cpu: 37771331 | mem: 130110}) +({cpu: 37957212 | mem: 126810}) +({cpu: 56342346 | mem: 191328}) +({cpu: 47871381 | mem: 156240}) +({cpu: 80825699 | mem: 271798}) +({cpu: 104681919 | mem: 357262}) +({cpu: 111227032 | mem: 371520}) +({cpu: 137791981 | mem: 466808}) +({cpu: 147541137 | mem: 490494}) +({cpu: 163834040 | mem: 545696}) +({cpu: 189768014 | mem: 628720}) +({cpu: 235773308 | mem: 776020}) +({cpu: 467590789 | mem: 1531622}) \ No newline at end of file diff --git a/plutus-tx/src/PlutusTx/Data/AssocMap.hs b/plutus-tx/src/PlutusTx/Data/AssocMap.hs index 00b83a9e71f..a00327af26c 100644 --- a/plutus-tx/src/PlutusTx/Data/AssocMap.hs +++ b/plutus-tx/src/PlutusTx/Data/AssocMap.hs @@ -196,7 +196,7 @@ null (Map m) = P.null m -- | Create an `Map` from a list of key-value pairs. -- In case of duplicates, this function will keep only one entry (the one that precedes). -- In other words, this function de-duplicates the input list. -safeFromList :: forall k a . (P.ToData k, P.ToData a) =>[(k, a)] -> Map k a +safeFromList :: forall k a . (P.ToData k, P.ToData a) => [(k, a)] -> Map k a safeFromList = Map . toOpaque From ef6ec4d9d8ffba9fdd2a819f206bf5efd5b3a11c Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Fri, 31 May 2024 12:56:49 +0300 Subject: [PATCH 05/13] WIP: unordEqWith on builtins Signed-off-by: Ana Pantilie --- .../src/PlutusLedgerApi/V1/Data/Value.hs | 142 ++++++++++++------ 1 file changed, 100 insertions(+), 42 deletions(-) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs index 3f1fb0ef5b1..2d66a99cae2 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs @@ -75,7 +75,6 @@ import PlutusTx.Builtins.Internal (BuiltinList, BuiltinPair) import PlutusTx.Builtins.Internal qualified as BI import PlutusTx.Data.AssocMap qualified as Map import PlutusTx.Lift (makeLift) -import PlutusTx.List qualified as List import PlutusTx.Ord qualified as Ord import PlutusTx.Prelude as PlutusTx hiding (sort) import PlutusTx.Show qualified as PlutusTx @@ -460,49 +459,112 @@ in the other, since in that case computing equality of values was expensive and The algorithm we use here is very similar, if not identical, to @valueEqualsValue4@ from https://github.com/IntersectMBO/plutus/issues/5135 -} -unordEqWith :: forall k v. Eq k => (v -> Bool) -> (v -> v -> Bool) -> [(k, v)] -> [(k, v)] -> Bool +unordEqWith + :: (BuiltinData -> Bool) + -> (BuiltinData -> BuiltinData -> Bool) + -> BuiltinList (BuiltinPair BuiltinData BuiltinData) + -> BuiltinList (BuiltinPair BuiltinData BuiltinData) + -> Bool unordEqWith is0 eqV = goBoth where - -- Recurse on the spines of both the lists simultaneously. - goBoth :: [(k, v)] -> [(k, v)] -> Bool - -- One spine is longer than the other one, but this still can result in a succeeding equality - -- check if the non-empty list only contains zero values. - goBoth [] kvsR = all (is0 . snd) kvsR - -- Symmetric to the previous case. - goBoth kvsL [] = all (is0 . snd) kvsL - -- Both spines are non-empty. - goBoth ((kL, vL) : kvsL') kvsR0@(kvR0@(kR0, vR0) : kvsR0') - -- We could've avoided having this clause if we always searched for the right key-value pair - -- using @goRight@, however the sheer act of invoking that function, passing an empty list - -- to it as an accumulator and calling 'revAppend' afterwards affects performance quite a - -- bit, considering that all of that happens for every single element of the left list. - -- Hence we handle the special case of lists being equal pointwise (or at least their - -- prefixes being equal pointwise) with a bit of additional logic to get some easy - -- performance gains. - | kL == kR0 = if vL `eqV` vR0 then goBoth kvsL' kvsR0' else False - | is0 vL = goBoth kvsL' kvsR0 - | otherwise = goRight [kvR0 | not $ is0 vR0] kvsR0' - where - -- Recurse on the spine of the right list looking for a key-value pair whose key matches - -- @kL@, i.e. the first key in the remaining part of the left list. The accumulator - -- contains (in reverse order) all elements of the right list processed so far whose - -- keys are not equal to @kL@ and values are non-zero. - goRight :: [(k, v)] -> [(k, v)] -> Bool - goRight _ [] = False - goRight acc (kvR@(kR, vR) : kvsR') - | is0 vR = goRight acc kvsR' - -- @revAppend@ recreates @kvsR0'@ with @(kR, vR)@ removed, since that pair - -- equals @(kL, vL)@ from the left list, hence we throw both of them away. - | kL == kR = if vL `eqV` vR then goBoth kvsL' (revAppend acc kvsR') else False - | otherwise = goRight (kvR : acc) kvsR' + goBoth + :: BuiltinList (BuiltinPair BuiltinData BuiltinData) + -> BuiltinList (BuiltinPair BuiltinData BuiltinData) + -> Bool + goBoth l1 l2 = + B.matchList + l1 + -- null l1 case + ( \() -> + B.matchList + l2 + -- null l2 case + (\() -> True) + -- non-null l2 case + (\ _ _ -> Map.all is0 (Map.unsafeFromBuiltinList l2)) + ) + -- non-null l1 case + ( \hd1 tl1 -> + B.matchList + l2 + -- null l2 case + (\() -> Map.all is0 (Map.unsafeFromBuiltinList l1)) + -- non-null l2 case + ( \hd2 tl2 -> + let + k1 = BI.fst hd1 + v1 = BI.snd hd1 + k2 = BI.fst hd2 + v2 = BI.snd hd2 + in + if k1 == k2 + then + if eqV v1 v2 + then goBoth tl1 tl2 + else False + else + if is0 v1 + then goBoth tl1 l2 + else + let + goRight + :: BuiltinList (BuiltinPair BuiltinData BuiltinData) + -> BuiltinList (BuiltinPair BuiltinData BuiltinData) + -> Bool + goRight acc l = + B.matchList + l + -- null l case + (\() -> False) + -- non-null l case + ( \hd tl -> + let + k = BI.fst hd + v = BI.snd hd + in + if is0 v + then goRight acc tl + else + if k == k1 + then + if eqV v1 v + then goBoth tl1 (revAppend' acc tl) + else False + else goRight (hd `BI.mkCons` acc) tl + ) + in + goRight + ( if is0 v2 + then BI.mkNilPairData BI.unitval + else hd2 `BI.mkCons` BI.mkNilPairData BI.unitval + ) + tl2 + ) + ) + + revAppend' = rev + where + rev l acc = + B.matchList + l + (\() -> acc) + ( \hd tl -> + rev tl (hd `BI.mkCons` acc) + ) + {-# INLINABLE eqMapWith #-} -- | Check equality of two 'Map's given a function checking whether a value is zero and a function -- checking equality of values. eqMapWith :: forall k v - . (Eq k, PlutusTx.UnsafeFromData k, PlutusTx.UnsafeFromData v) + . (PlutusTx.UnsafeFromData v) => (v -> Bool) -> (v -> v -> Bool) -> Map.Map k v -> Map.Map k v -> Bool -eqMapWith is0 eqV (Map.toList -> xs1) (Map.toList -> xs2) = unordEqWith is0 eqV xs1 xs2 +eqMapWith is0 eqV map1 map2 = + let xs1 = Map.toBuiltinList map1 + xs2 = Map.toBuiltinList map2 + is0' v = is0 (unsafeFromBuiltinData v) + eqV' v1 v2 = eqV (unsafeFromBuiltinData v1) (unsafeFromBuiltinData v2) + in unordEqWith is0' eqV' xs1 xs2 {-# INLINABLE eq #-} -- | Check equality of two 'Value's. Does not assume orderness of lists within a 'Value' or a lack @@ -510,12 +572,8 @@ eqMapWith is0 eqV (Map.toList -> xs1) (Map.toList -> xs2) = unordEqWith is0 eqV -- tokens or no tokens at all), but does assume that no currencies or tokens within a single -- currency have multiple entries. eq :: Value -> Value -> Bool -eq (valueToList -> currs1) (valueToList -> currs2) = - unordEqWith - (List.all (0 ==) . fmap snd) - (unordEqWith (0 ==) (==)) - currs1 - currs2 +eq (Value currs1) (Value currs2) = + eqMapWith (Map.all (0 ==)) (eqMapWith (0 ==) (==)) currs1 currs2 valueToList :: Value -> [(CurrencySymbol, [(TokenName, Integer)])] valueToList (Map.toBuiltinList . getValue -> bList) = From 5d78bfc3b3400621a66d0cd08fabb8b60d7b219e Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Fri, 31 May 2024 13:22:44 +0300 Subject: [PATCH 06/13] Fix issue with unsupported feature Signed-off-by: Ana Pantilie --- .../src/PlutusLedgerApi/V1/Data/Value.hs | 28 ++++++++++++++----- 1 file changed, 21 insertions(+), 7 deletions(-) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs index 2d66a99cae2..4e719943055 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs @@ -480,14 +480,14 @@ unordEqWith is0 eqV = goBoth where -- null l2 case (\() -> True) -- non-null l2 case - (\ _ _ -> Map.all is0 (Map.unsafeFromBuiltinList l2)) + (\ _ _ -> Map.all is0 (Map.unsafeFromBuiltinList l2 :: Map.Map BuiltinData BuiltinData)) ) -- non-null l1 case ( \hd1 tl1 -> B.matchList l2 -- null l2 case - (\() -> Map.all is0 (Map.unsafeFromBuiltinList l1)) + (\() -> Map.all is0 (Map.unsafeFromBuiltinList l1 :: Map.Map BuiltinData BuiltinData)) -- non-null l2 case ( \hd2 tl2 -> let @@ -555,10 +555,12 @@ unordEqWith is0 eqV = goBoth where {-# INLINABLE eqMapWith #-} -- | Check equality of two 'Map's given a function checking whether a value is zero and a function -- checking equality of values. -eqMapWith :: - forall k v - . (PlutusTx.UnsafeFromData v) - => (v -> Bool) -> (v -> v -> Bool) -> Map.Map k v -> Map.Map k v -> Bool +eqMapWith + :: (Map.Map TokenName Integer -> Bool) + -> (Map.Map TokenName Integer -> Map.Map TokenName Integer -> Bool) + -> Map.Map CurrencySymbol (Map.Map TokenName Integer) + -> Map.Map CurrencySymbol (Map.Map TokenName Integer) + -> Bool eqMapWith is0 eqV map1 map2 = let xs1 = Map.toBuiltinList map1 xs2 = Map.toBuiltinList map2 @@ -566,6 +568,18 @@ eqMapWith is0 eqV map1 map2 = eqV' v1 v2 = eqV (unsafeFromBuiltinData v1) (unsafeFromBuiltinData v2) in unordEqWith is0' eqV' xs1 xs2 +{-# INLINABLE eqMapWith' #-} +-- | Check equality of two 'Map's given a function checking whether a value is zero and a function +-- checking equality of values. +eqMapWith' + :: (Integer -> Bool) -> (Integer -> Integer -> Bool) -> Map.Map TokenName Integer -> Map.Map TokenName Integer -> Bool +eqMapWith' is0 eqV map1 map2 = + let xs1 = Map.toBuiltinList map1 + xs2 = Map.toBuiltinList map2 + is0' v = is0 (unsafeFromBuiltinData v) + eqV' v1 v2 = eqV (unsafeFromBuiltinData v1) (unsafeFromBuiltinData v2) + in unordEqWith is0' eqV' xs1 xs2 + {-# INLINABLE eq #-} -- | Check equality of two 'Value's. Does not assume orderness of lists within a 'Value' or a lack -- of empty values (such as a token whose quantity is zero or a currency that has a bunch of such @@ -573,7 +587,7 @@ eqMapWith is0 eqV map1 map2 = -- currency have multiple entries. eq :: Value -> Value -> Bool eq (Value currs1) (Value currs2) = - eqMapWith (Map.all (0 ==)) (eqMapWith (0 ==) (==)) currs1 currs2 + eqMapWith (Map.all (0 ==)) (eqMapWith' (0 ==) (==)) currs1 currs2 valueToList :: Value -> [(CurrencySymbol, [(TokenName, Integer)])] valueToList (Map.toBuiltinList . getValue -> bList) = From fa9ab63f78f23f1f41a898c4f5b1e421206f77e2 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Fri, 31 May 2024 13:24:09 +0300 Subject: [PATCH 07/13] Update benchmarks Signed-off-by: Ana Pantilie --- .../Spec/Data/Budget/9.6/gt.pir.golden | 649 ++++++------------ .../Spec/Data/Budget/9.6/gt1.budget.golden | 4 +- .../Spec/Data/Budget/9.6/gt2.budget.golden | 4 +- .../Spec/Data/Budget/9.6/gt3.budget.golden | 4 +- .../Spec/Data/Budget/9.6/gt4.budget.golden | 4 +- .../Spec/Data/Budget/9.6/gt5.budget.golden | 4 +- .../Spec/Data/Value/9.6/Long.stat.golden | 30 +- .../Spec/Data/Value/9.6/Short.stat.golden | 42 +- 8 files changed, 270 insertions(+), 471 deletions(-) diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt.pir.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt.pir.golden index 66fbbf37bc4..76ed91318bb 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt.pir.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt.pir.golden @@ -1,57 +1,3 @@ -let - data (Tuple2 :: * -> * -> *) a b | Tuple2_match where - Tuple2 : a -> b -> Tuple2 a b -in -letrec - data (List :: * -> *) a | List_match where - Nil : List a - Cons : a -> List a -> List a -in -letrec - !go : List (Tuple2 bytestring integer) -> List integer - = \(ds : List (Tuple2 bytestring integer)) -> - List_match - {Tuple2 bytestring integer} - ds - {all dead. List integer} - (/\dead -> Nil {integer}) - (\(x : Tuple2 bytestring integer) - (xs : List (Tuple2 bytestring integer)) -> - /\dead -> - Cons - {integer} - (Tuple2_match - {bytestring} - {integer} - x - {integer} - (\(ds : bytestring) (b : integer) -> b)) - (go xs)) - {all dead. dead} -in -let - data Bool | Bool_match where - True : Bool - False : Bool -in -letrec - !go : List integer -> Bool - = \(ds : List integer) -> - List_match - {integer} - ds - {all dead. Bool} - (/\dead -> True) - (\(x : integer) (xs : List integer) -> - /\dead -> - ifThenElse - {all dead. Bool} - (equalsInteger 0 x) - (/\dead -> go xs) - (/\dead -> False) - {all dead. dead}) - {all dead. dead} -in let !`$fToDataInteger_$ctoBuiltinData` : integer -> data = \(i : integer) -> iData i @@ -85,99 +31,12 @@ let {integer} `$fToDataInteger_$ctoBuiltinData` `$fToDataInteger_$ctoBuiltinData` + data Bool | Bool_match where + True : Bool + False : Bool !f : integer -> integer -> Bool = \(x : integer) (y : integer) -> ifThenElse {Bool} (lessThanInteger x y) False True - data Unit | Unit_match where - Unit : Unit - !all : - all k a. - (\a -> data -> a) a -> - (a -> Bool) -> - (\k a -> list (pair data data)) k a -> - Bool - = /\k a -> - \(`$dUnsafeFromData` : (\a -> data -> a) a) (p : a -> Bool) -> - letrec - !go : list (pair data data) -> Bool - = \(xs : list (pair data data)) -> - chooseList - {pair data data} - {Unit -> Bool} - xs - (\(ds : Unit) -> True) - (\(ds : Unit) -> - Bool_match - (p - (`$dUnsafeFromData` - (sndPair - {data} - {data} - (headList {pair data data} xs)))) - {all dead. Bool} - (/\dead -> go (tailList {pair data data} xs)) - (/\dead -> - let - !ds : list (pair data data) - = tailList {pair data data} xs - in - False) - {all dead. dead}) - Unit - in - \(ds : (\k a -> list (pair data data)) k a) -> go ds -in -letrec - !`$fEqValue_go'` : list (pair data data) -> List (Tuple2 bytestring integer) - = \(l : list (pair data data)) -> - let - ~hd : pair data data = headList {pair data data} l - in - chooseList - {pair data data} - {Unit -> List (Tuple2 bytestring integer)} - l - (\(ds : Unit) -> Nil {Tuple2 bytestring integer}) - (\(ds : Unit) -> - Cons - {Tuple2 bytestring integer} - (Tuple2 - {bytestring} - {integer} - (unBData (fstPair {data} {data} hd)) - (unIData (sndPair {data} {data} hd))) - (`$fEqValue_go'` (tailList {pair data data} l))) - Unit -in -letrec - !`$fEqValue_go` : - list (pair data data) -> - List (Tuple2 bytestring (List (Tuple2 bytestring integer))) - = \(l : list (pair data data)) -> - let - ~hd : pair data data = headList {pair data data} l - in - chooseList - {pair data data} - {Unit -> List (Tuple2 bytestring (List (Tuple2 bytestring integer)))} - l - (\(ds : Unit) -> - Nil {Tuple2 bytestring (List (Tuple2 bytestring integer))}) - (\(ds : Unit) -> - Cons - {Tuple2 bytestring (List (Tuple2 bytestring integer))} - (Tuple2 - {bytestring} - {List (Tuple2 bytestring integer)} - (unBData (fstPair {data} {data} hd)) - (`$fEqValue_go'` (unMapData (sndPair {data} {data} hd)))) - (`$fEqValue_go` (tailList {pair data data} l))) - Unit -in -let - !equalsByteString : bytestring -> bytestring -> Bool - = \(x : bytestring) (y : bytestring) -> - ifThenElse {Bool} (equalsByteString x y) True False !`$fUnsafeFromDataThese_$cunsafeFromBuiltinData` : all a b. (\a -> data -> a) a -> (\a -> data -> a) b -> data -> These a b = /\a b -> @@ -217,6 +76,8 @@ let !`$fToDataMap_$ctoBuiltinData` : all k a. (\k a -> list (pair data data)) k a -> data = /\k a -> \(ds : (\k a -> list (pair data data)) k a) -> mapData ds + data Unit | Unit_match where + Unit : Unit !map : all k a b. (\a -> data -> a) a -> @@ -452,276 +313,206 @@ let Unit in safeAppend (goLeft ds) (goRight ds) - !unordEqWith : - all k v. - (\a -> a -> a -> Bool) k -> - (v -> Bool) -> - (v -> v -> Bool) -> - List (Tuple2 k v) -> - List (Tuple2 k v) -> +in +letrec + !rev : all a. list a -> list a -> list a + = /\a -> + \(l : list a) (acc : list a) -> + chooseList + {a} + {Unit -> list a} + l + (\(ds : Unit) -> acc) + (\(ds : Unit) -> + rev {a} (tailList {a} l) (mkCons {a} (headList {a} l) acc)) + Unit +in +let + !`$fUnsafeFromDataBuiltinData_$cunsafeFromBuiltinData` : data -> data + = \(d : data) -> d + !all : + all k a. + (\a -> data -> a) a -> + (a -> Bool) -> + (\k a -> list (pair data data)) k a -> Bool - = /\k v -> - \(`$dEq` : (\a -> a -> a -> Bool) k) - (is : v -> Bool) -> - letrec - !go : List (Tuple2 k v) -> Bool - = \(ds : List (Tuple2 k v)) -> - List_match - {Tuple2 k v} - ds - {all dead. Bool} - (/\dead -> True) - (\(x : Tuple2 k v) (xs : List (Tuple2 k v)) -> - /\dead -> - Tuple2_match - {k} - {v} - x - {Bool} - (\(ipv : k) (ipv : v) -> - Bool_match - (is ipv) - {all dead. Bool} - (/\dead -> go xs) - (/\dead -> False) - {all dead. dead})) - {all dead. dead} - in + = /\k a -> + \(`$dUnsafeFromData` : (\a -> data -> a) a) (p : a -> Bool) -> letrec - !go : List (Tuple2 k v) -> Bool - = \(ds : List (Tuple2 k v)) -> - List_match - {Tuple2 k v} - ds - {all dead. Bool} - (/\dead -> True) - (\(x : Tuple2 k v) (xs : List (Tuple2 k v)) -> - /\dead -> - Tuple2_match - {k} - {v} - x - {Bool} - (\(ipv : k) (ipv : v) -> - Bool_match - (is ipv) - {all dead. Bool} - (/\dead -> go xs) - (/\dead -> False) - {all dead. dead})) - {all dead. dead} + !go : list (pair data data) -> Bool + = \(xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> Bool} + xs + (\(ds : Unit) -> True) + (\(ds : Unit) -> + Bool_match + (p + (`$dUnsafeFromData` + (sndPair + {data} + {data} + (headList {pair data data} xs)))) + {all dead. Bool} + (/\dead -> go (tailList {pair data data} xs)) + (/\dead -> + let + !ds : list (pair data data) + = tailList {pair data data} xs + in + False) + {all dead. dead}) + Unit in - \(eqV : v -> v -> Bool) -> - letrec - !goBoth : - List (Tuple2 k v) -> List (Tuple2 k v) -> Bool - = \(ds : List (Tuple2 k v)) - (kvsR : List (Tuple2 k v)) -> - List_match - {Tuple2 k v} - ds - {all dead. Bool} - (/\dead -> go kvsR) - (\(ipv : Tuple2 k v) - (ipv : List (Tuple2 k v)) -> - /\dead -> - List_match - {Tuple2 k v} - kvsR - {all dead. Bool} - (/\dead -> go ds) - (\(ipv : Tuple2 k v) - (ipv : List (Tuple2 k v)) -> - /\dead -> - Tuple2_match - {k} - {v} - ipv - {Bool} - (\(kL : k) - (vL : v) -> - letrec - !goRight : - List (Tuple2 k v) -> - List (Tuple2 k v) -> - Bool - = \(ds : List (Tuple2 k v)) - (ds : List (Tuple2 k v)) -> - List_match - {Tuple2 k v} - ds - {all dead. Bool} - (/\dead -> False) - (\(kvR : Tuple2 k v) - (kvsR' : - List (Tuple2 k v)) -> - /\dead -> - Tuple2_match - {k} - {v} - kvR - {Bool} - (\(kR : k) - (vR : v) -> - Bool_match - (is vR) - {all dead. Bool} - (/\dead -> - goRight - ds - kvsR') - (/\dead -> - Bool_match - (`$dEq` kL kR) - {all dead. - Bool} - (/\dead -> - Bool_match - (eqV - vL - vR) - {all dead. - Bool} - (/\dead -> - goBoth - ipv - ((let - a - = Tuple2 - k - v - in - letrec - !rev : - List - a -> - List - a -> - List - a - = \(ds : - List - a) - (a : - List - a) -> - List_match - {a} - ds - {all dead. - List - a} - (/\dead -> - a) - (\(x : - a) - (xs : - List - a) -> - /\dead -> - rev - xs - (Cons - {a} - x - a)) - {all dead. - dead} - in - \(eta : - List - a) - (eta : - List - a) -> - rev - eta - eta) - ds - kvsR')) - (/\dead -> - False) - {all dead. - dead}) - (/\dead -> - goRight - (Cons - {Tuple2 - k - v} - kvR - ds) - kvsR') - {all dead. - dead}) - {all dead. dead})) - {all dead. dead} - in - Tuple2_match - {k} - {v} - ipv - {Bool} - (\(kR : k) (vR : v) -> - Bool_match - (`$dEq` kL kR) - {all dead. Bool} - (/\dead -> - Bool_match - (eqV vL vR) - {all dead. Bool} - (/\dead -> goBoth ipv ipv) - (/\dead -> False) - {all dead. dead}) - (/\dead -> - Bool_match - (is vL) - {all dead. Bool} - (/\dead -> goBoth ipv kvsR) - (/\dead -> - goRight - ((let - a = Tuple2 k v - in - \(g : - all b. - (a -> - b -> - b) -> - b -> - b) -> - g - {List a} - (\(ds : a) - (ds : - List a) -> - Cons - {a} - ds - ds) - (Nil {a})) - (/\a -> - \(c : - Tuple2 k v -> - a -> - a) - (n : a) -> - Bool_match - (is vR) - {all dead. a} - (/\dead -> n) - (/\dead -> - c ipv n) - {all dead. - dead})) - ipv) - {all dead. dead}) - {all dead. dead}))) - {all dead. dead}) - {all dead. dead} - in - \(eta : List (Tuple2 k v)) (eta : List (Tuple2 k v)) -> - goBoth eta eta + \(ds : (\k a -> list (pair data data)) k a) -> go ds + !unordEqWith : + (data -> Bool) -> + (data -> data -> Bool) -> + list (pair data data) -> + list (pair data data) -> + Bool + = \(is : data -> Bool) + (eqV : data -> data -> Bool) -> + letrec + !goBoth : + list (pair data data) -> list (pair data data) -> Bool + = \(l : list (pair data data)) -> + let + ~hd : pair data data = headList {pair data data} l + ~v : data = sndPair {data} {data} hd + ~tl : list (pair data data) = tailList {pair data data} l + in + \(l : list (pair data data)) -> + let + ~hd : pair data data = headList {pair data data} l + in + chooseList + {pair data data} + {Unit -> Bool} + l + (\(ds : Unit) -> + chooseList + {pair data data} + {Unit -> Bool} + l + (\(ds : Unit) -> True) + (\(ds : Unit) -> + all + {data} + {data} + `$fUnsafeFromDataBuiltinData_$cunsafeFromBuiltinData` + is + l) + Unit) + (\(ds : Unit) -> + chooseList + {pair data data} + {Unit -> Bool} + l + (\(ds : Unit) -> + all + {data} + {data} + `$fUnsafeFromDataBuiltinData_$cunsafeFromBuiltinData` + is + l) + (\(ds : Unit) -> + let + !d : data = fstPair {data} {data} hd + in + letrec + !goRight : + list (pair data data) -> + list (pair data data) -> + Bool + = \(acc : list (pair data data)) + (l : list (pair data data)) -> + let + ~hd : pair data data + = headList {pair data data} l + ~v : data = sndPair {data} {data} hd + in + chooseList + {pair data data} + {Unit -> Bool} + l + (\(ds : Unit) -> False) + (\(ds : Unit) -> + Bool_match + (is v) + {all dead. Bool} + (/\dead -> + goRight + acc + (tailList {pair data data} l)) + (/\dead -> + ifThenElse + {all dead. Bool} + (equalsData + (fstPair {data} {data} hd) + d) + (/\dead -> + Bool_match + (eqV v v) + {all dead. Bool} + (/\dead -> + goBoth + tl + (rev + {pair data data} + acc + (tailList + {pair data data} + l))) + (/\dead -> False) + {all dead. dead}) + (/\dead -> + goRight + (mkCons + {pair data data} + hd + acc) + (tailList + {pair data data} + l)) + {all dead. dead}) + {all dead. dead}) + Unit + in + ifThenElse + {all dead. Bool} + (equalsData d (fstPair {data} {data} hd)) + (/\dead -> + Bool_match + (eqV v (sndPair {data} {data} hd)) + {all dead. Bool} + (/\dead -> + goBoth tl (tailList {pair data data} l)) + (/\dead -> False) + {all dead. dead}) + (/\dead -> + Bool_match + (is v) + {all dead. Bool} + (/\dead -> goBoth tl l) + (/\dead -> + goRight + (Bool_match + (is (sndPair {data} {data} hd)) + {all dead. list (pair data data)} + (/\dead -> []) + (/\dead -> + mkCons {pair data data} hd []) + {all dead. dead}) + (tailList {pair data data} l)) + {all dead. dead}) + {all dead. dead}) + Unit) + Unit + in + \(eta : list (pair data data)) (eta : list (pair data data)) -> + goBoth eta eta in \(l : (\k a -> list (pair data data)) @@ -820,20 +611,28 @@ in (/\dead -> Bool_match (unordEqWith - {bytestring} - {List (Tuple2 bytestring integer)} - equalsByteString - (\(eta : List (Tuple2 bytestring integer)) -> go (go eta)) - (unordEqWith - {bytestring} - {integer} - equalsByteString - (\(v : integer) -> - ifThenElse {Bool} (equalsInteger 0 v) True False) - (\(x : integer) (y : integer) -> - ifThenElse {Bool} (equalsInteger x y) True False)) - (`$fEqValue_go` l) - (`$fEqValue_go` r)) + (\(v : data) -> + all + {bytestring} + {integer} + unIData + (\(v : integer) -> + ifThenElse {Bool} (equalsInteger 0 v) True False) + (unMapData v)) + (\(v : data) (v : data) -> + unordEqWith + (\(v : data) -> + ifThenElse {Bool} (equalsInteger 0 (unIData v)) True False) + (\(v : data) (v : data) -> + ifThenElse + {Bool} + (equalsInteger (unIData v) (unIData v)) + True + False) + (unMapData v) + (unMapData v)) + l + r) {all dead. Bool} (/\dead -> False) (/\dead -> True) diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt1.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt1.budget.golden index 9098a061ff4..084da0f4816 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt1.budget.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt1.budget.golden @@ -1,2 +1,2 @@ -({cpu: 867689318 -| mem: 2264124}) \ No newline at end of file +({cpu: 859384758 +| mem: 2153344}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt2.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt2.budget.golden index be5876cbc79..abced1f5ba1 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt2.budget.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt2.budget.golden @@ -1,2 +1,2 @@ -({cpu: 784673675 -| mem: 1965930}) \ No newline at end of file +({cpu: 783707675 +| mem: 1961730}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt3.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt3.budget.golden index ce9043a45fc..0c2efaa2e9f 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt3.budget.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt3.budget.golden @@ -1,2 +1,2 @@ -({cpu: 962726971 -| mem: 2532132}) \ No newline at end of file +({cpu: 942136100 +| mem: 2379272}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt4.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt4.budget.golden index 4d255f7bb3c..ff6102aea66 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt4.budget.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt4.budget.golden @@ -1,2 +1,2 @@ -({cpu: 706432331 -| mem: 1742102}) \ No newline at end of file +({cpu: 705466331 +| mem: 1737902}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt5.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt5.budget.golden index 7bca1612d9b..6f451f25133 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt5.budget.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt5.budget.golden @@ -1,2 +1,2 @@ -({cpu: 867140605 -| mem: 2232118}) \ No newline at end of file +({cpu: 823509793 +| mem: 2056794}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Long.stat.golden b/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Long.stat.golden index e9c23e34292..fd19b85d53b 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Long.stat.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Long.stat.golden @@ -1,15 +1,15 @@ -({cpu: 4913776735 | mem: 16081070}) -({cpu: 2331301382 | mem: 7278268}) -({cpu: 3431714753 | mem: 11231254}) -({cpu: 1918223822 | mem: 5990004}) -({cpu: 3431714753 | mem: 11231254}) -({cpu: 1504870262 | mem: 4700540}) -({cpu: 1949652771 | mem: 6381438}) -({cpu: 1505008262 | mem: 4701140}) -({cpu: 3431714753 | mem: 11231254}) -({cpu: 1504870262 | mem: 4700540}) -({cpu: 1949652771 | mem: 6381438}) -({cpu: 1091792702 | mem: 3412276}) -({cpu: 1949652771 | mem: 6381438}) -({cpu: 678439142 | mem: 2122812}) -({cpu: 467590789 | mem: 1531622}) \ No newline at end of file +({cpu: 6727061187 | mem: 12083358}) +({cpu: 10186791 | mem: 31548}) +({cpu: 4747794921 | mem: 8436358}) +({cpu: 10186791 | mem: 31548}) +({cpu: 4747794921 | mem: 8436358}) +({cpu: 10186791 | mem: 31548}) +({cpu: 2768528655 | mem: 4789358}) +({cpu: 10186791 | mem: 31548}) +({cpu: 4747794921 | mem: 8436358}) +({cpu: 10186791 | mem: 31548}) +({cpu: 2768528655 | mem: 4789358}) +({cpu: 10186791 | mem: 31548}) +({cpu: 2768528655 | mem: 4789358}) +({cpu: 10186791 | mem: 31548}) +({cpu: 789262389 | mem: 1142358}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Short.stat.golden b/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Short.stat.golden index 6f40f116c05..f8b5b579774 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Short.stat.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Short.stat.golden @@ -1,21 +1,21 @@ -({cpu: 5709808 | mem: 23464}) -({cpu: 8795848 | mem: 34220}) -({cpu: 12455279 | mem: 46178}) -({cpu: 15269497 | mem: 55204}) -({cpu: 18367617 | mem: 65430}) -({cpu: 23876875 | mem: 83512}) -({cpu: 31025860 | mem: 107396}) -({cpu: 34310998 | mem: 119052}) -({cpu: 37771331 | mem: 130110}) -({cpu: 37957212 | mem: 126810}) -({cpu: 56342346 | mem: 191328}) -({cpu: 47871381 | mem: 156240}) -({cpu: 80825699 | mem: 271798}) -({cpu: 104681919 | mem: 357262}) -({cpu: 111227032 | mem: 371520}) -({cpu: 137791981 | mem: 466808}) -({cpu: 147541137 | mem: 490494}) -({cpu: 163834040 | mem: 545696}) -({cpu: 189768014 | mem: 628720}) -({cpu: 235773308 | mem: 776020}) -({cpu: 467590789 | mem: 1531622}) \ No newline at end of file +({cpu: 2558808 | mem: 9764}) +({cpu: 6076546 | mem: 22088}) +({cpu: 9274301 | mem: 28614}) +({cpu: 12290217 | mem: 38208}) +({cpu: 14857661 | mem: 42702}) +({cpu: 19002253 | mem: 56424}) +({cpu: 27244616 | mem: 75640}) +({cpu: 30092472 | mem: 88932}) +({cpu: 33960109 | mem: 94490}) +({cpu: 21496965 | mem: 61158}) +({cpu: 52018526 | mem: 141516}) +({cpu: 15858253 | mem: 45636}) +({cpu: 75660303 | mem: 202630}) +({cpu: 91684231 | mem: 252490}) +({cpu: 106030766 | mem: 277832}) +({cpu: 122054694 | mem: 327692}) +({cpu: 142072691 | mem: 367122}) +({cpu: 146217283 | mem: 380844}) +({cpu: 183786078 | mem: 470500}) +({cpu: 73253295 | mem: 204964}) +({cpu: 789262389 | mem: 1142358}) \ No newline at end of file From 8fd979dc7347771f5f6f0ac58468e44b447cf654 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Fri, 31 May 2024 14:13:10 +0300 Subject: [PATCH 08/13] Clean-up Signed-off-by: Ana Pantilie --- .../src/PlutusLedgerApi/V1/Data/Value.hs | 45 +++++++------------ 1 file changed, 15 insertions(+), 30 deletions(-) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs index 4e719943055..122d3c04a00 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs @@ -552,28 +552,33 @@ unordEqWith is0 eqV = goBoth where ) -{-# INLINABLE eqMapWith #-} --- | Check equality of two 'Map's given a function checking whether a value is zero and a function +{-# INLINABLE eqMapOfMapsWith #-} +-- | Check equality of two maps of maps indexed by 'CurrencySymbol's, +--- given a function checking whether a value is zero and a function -- checking equality of values. -eqMapWith +eqMapOfMapsWith :: (Map.Map TokenName Integer -> Bool) -> (Map.Map TokenName Integer -> Map.Map TokenName Integer -> Bool) -> Map.Map CurrencySymbol (Map.Map TokenName Integer) -> Map.Map CurrencySymbol (Map.Map TokenName Integer) -> Bool -eqMapWith is0 eqV map1 map2 = +eqMapOfMapsWith is0 eqV map1 map2 = let xs1 = Map.toBuiltinList map1 xs2 = Map.toBuiltinList map2 is0' v = is0 (unsafeFromBuiltinData v) eqV' v1 v2 = eqV (unsafeFromBuiltinData v1) (unsafeFromBuiltinData v2) in unordEqWith is0' eqV' xs1 xs2 -{-# INLINABLE eqMapWith' #-} --- | Check equality of two 'Map's given a function checking whether a value is zero and a function +{-# INLINABLE eqMapWith #-} +-- | Check equality of two 'Map Token Integer's given a function checking whether a value is zero and a function -- checking equality of values. -eqMapWith' - :: (Integer -> Bool) -> (Integer -> Integer -> Bool) -> Map.Map TokenName Integer -> Map.Map TokenName Integer -> Bool -eqMapWith' is0 eqV map1 map2 = +eqMapWith + :: (Integer -> Bool) + -> (Integer -> Integer -> Bool) + -> Map.Map TokenName Integer + -> Map.Map TokenName Integer + -> Bool +eqMapWith is0 eqV map1 map2 = let xs1 = Map.toBuiltinList map1 xs2 = Map.toBuiltinList map2 is0' v = is0 (unsafeFromBuiltinData v) @@ -587,27 +592,7 @@ eqMapWith' is0 eqV map1 map2 = -- currency have multiple entries. eq :: Value -> Value -> Bool eq (Value currs1) (Value currs2) = - eqMapWith (Map.all (0 ==)) (eqMapWith' (0 ==) (==)) currs1 currs2 - -valueToList :: Value -> [(CurrencySymbol, [(TokenName, Integer)])] -valueToList (Map.toBuiltinList . getValue -> bList) = - go bList - where - go l = - B.matchList - l - (\() -> []) - ( \hd tl -> - (unsafeFromBuiltinData (BI.fst hd), go' . BI.unsafeDataAsMap . BI.snd $ hd) : go tl - ) - - go' l = - B.matchList - l - (\() -> []) - ( \hd tl -> - (unsafeFromBuiltinData (BI.fst hd), unsafeFromBuiltinData (BI.snd hd)) : go' tl - ) + eqMapOfMapsWith (Map.all (0 ==)) (eqMapWith (0 ==) (==)) currs1 currs2 newtype Lovelace = Lovelace { getLovelace :: Integer } deriving stock (Generic) From 9212574913c6951a236e27aedc1a045bb8dc4ae5 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Fri, 31 May 2024 14:31:40 +0300 Subject: [PATCH 09/13] Add pragma Signed-off-by: Ana Pantilie --- plutus-tx/src/PlutusTx/Data/AssocMap.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/plutus-tx/src/PlutusTx/Data/AssocMap.hs b/plutus-tx/src/PlutusTx/Data/AssocMap.hs index a00327af26c..59b426915b2 100644 --- a/plutus-tx/src/PlutusTx/Data/AssocMap.hs +++ b/plutus-tx/src/PlutusTx/Data/AssocMap.hs @@ -484,6 +484,7 @@ map f (Map m) = Map $ go m (go tl) ) +{-# INLINEABLE foldr #-} foldr :: forall a b k. (P.UnsafeFromData a) => (a -> b -> b) -> b -> Map k a -> b foldr f z (Map m) = go m where From 26d7f87ffdf3fbaebb2f5e85e93bcaec8477dea2 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Tue, 4 Jun 2024 13:41:25 +0300 Subject: [PATCH 10/13] Address some review comments Signed-off-by: Ana Pantilie --- plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs | 4 ++-- plutus-ledger-api/src/PlutusLedgerApi/V1/Value.hs | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs index 122d3c04a00..e94bc03a213 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs @@ -17,7 +17,7 @@ {-# OPTIONS_GHC -fexpose-all-unfoldings #-} -- We need -fexpose-all-unfoldings to compile the Marlowe validator -- with GHC 9.6.2. --- TODO. Look into this more closely: see PLT-7976. +-- TODO. Look into this more closely: see https://github.com/IntersectMBO/plutus/issues/6172. -- | Functions for working with 'Value'. module PlutusLedgerApi.V1.Data.Value ( @@ -268,7 +268,7 @@ instance MeetSemiLattice Value where valueOf :: Value -> CurrencySymbol -> TokenName -> Integer valueOf (Value mp) cur tn = case Map.lookup cur mp of - Nothing -> 0 :: Integer + Nothing -> 0 Just i -> case Map.lookup tn i of Nothing -> 0 Just v -> v diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Value.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Value.hs index 99eace37ae5..7fdcf11d4e9 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Value.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Value.hs @@ -17,7 +17,7 @@ {-# OPTIONS_GHC -fexpose-all-unfoldings #-} -- We need -fexpose-all-unfoldings to compile the Marlowe validator -- with GHC 9.6.2. --- TODO. Look into this more closely: see PLT-7976. +-- TODO. Look into this more closely: see https://github.com/IntersectMBO/plutus/issues/6172. -- | Functions for working with 'Value'. module PlutusLedgerApi.V1.Value ( @@ -266,7 +266,7 @@ instance MeetSemiLattice Value where valueOf :: Value -> CurrencySymbol -> TokenName -> Integer valueOf (Value mp) cur tn = case Map.lookup cur mp of - Nothing -> 0 :: Integer + Nothing -> 0 Just i -> case Map.lookup tn i of Nothing -> 0 Just v -> v From 79c17556a180408ec123e839098fdc3907c51697 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Tue, 4 Jun 2024 13:50:10 +0300 Subject: [PATCH 11/13] Add changelog Signed-off-by: Ana Pantilie --- .../20240604_134844_ana.pantilie95_add_data_value_types.md | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 plutus-ledger-api/changelog.d/20240604_134844_ana.pantilie95_add_data_value_types.md diff --git a/plutus-ledger-api/changelog.d/20240604_134844_ana.pantilie95_add_data_value_types.md b/plutus-ledger-api/changelog.d/20240604_134844_ana.pantilie95_add_data_value_types.md new file mode 100644 index 00000000000..9033de43f37 --- /dev/null +++ b/plutus-ledger-api/changelog.d/20240604_134844_ana.pantilie95_add_data_value_types.md @@ -0,0 +1,3 @@ +### Added + +- Added a new `Value` type backed by `Data`. This is currently experimental and not yet used in the ledger API. From a02f618151e49d5dbacf4df1974d222ba79ea217 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Fri, 7 Jun 2024 21:04:14 +0300 Subject: [PATCH 12/13] Regenerate golden files Signed-off-by: Ana Pantilie --- .../9.6/currencySymbolValueOf.budget.golden | 2 +- .../Spec/Data/Budget/9.6/geq1.budget.golden | 2 +- .../Spec/Data/Budget/9.6/geq2.budget.golden | 2 +- .../Spec/Data/Budget/9.6/geq3.budget.golden | 2 +- .../Spec/Data/Budget/9.6/geq4.budget.golden | 2 +- .../Spec/Data/Budget/9.6/geq5.budget.golden | 2 +- .../Spec/Data/Budget/9.6/gt1.budget.golden | 2 +- .../Spec/Data/Budget/9.6/gt2.budget.golden | 2 +- .../Spec/Data/Budget/9.6/gt3.budget.golden | 2 +- .../Spec/Data/Budget/9.6/gt4.budget.golden | 2 +- .../Spec/Data/Budget/9.6/gt5.budget.golden | 2 +- .../test-plugin/Spec/Data/Value.hs | 2 +- .../Spec/Data/Value/9.6/Long.stat.golden | 30 ++++++------- .../Spec/Data/Value/9.6/Short.stat.golden | 42 +++++++++---------- 14 files changed, 48 insertions(+), 48 deletions(-) diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/currencySymbolValueOf.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/currencySymbolValueOf.budget.golden index 665d38b52f4..195379a5747 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/currencySymbolValueOf.budget.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/currencySymbolValueOf.budget.golden @@ -1,2 +1,2 @@ -({cpu: 27490443 +({cpu: 22967162 | mem: 64380}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq1.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq1.budget.golden index 89ed0eb2340..889d817f475 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq1.budget.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq1.budget.golden @@ -1,2 +1,2 @@ -({cpu: 739705185 +({cpu: 614011320 | mem: 1839010}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq2.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq2.budget.golden index ed161a5c915..1c96be260f1 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq2.budget.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq2.budget.golden @@ -1,2 +1,2 @@ -({cpu: 783201675 +({cpu: 649267269 | mem: 1959530}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq3.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq3.budget.golden index 2413c40bf14..0cb8213faf4 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq3.budget.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq3.budget.golden @@ -1,2 +1,2 @@ -({cpu: 818311935 +({cpu: 677953814 | mem: 2051216}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq4.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq4.budget.golden index 83c549f201f..7cc3dfba486 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq4.budget.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq4.budget.golden @@ -1,2 +1,2 @@ -({cpu: 704960331 +({cpu: 589398915 | mem: 1735702}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq5.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq5.budget.golden index dc42c028fc9..9d0dcbff6db 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq5.budget.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq5.budget.golden @@ -1,2 +1,2 @@ -({cpu: 766598956 +({cpu: 636471807 | mem: 1904018}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt1.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt1.budget.golden index 084da0f4816..52164d0cda0 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt1.budget.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt1.budget.golden @@ -1,2 +1,2 @@ -({cpu: 859384758 +({cpu: 712873128 | mem: 2153344}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt2.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt2.budget.golden index abced1f5ba1..4a622ce09d2 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt2.budget.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt2.budget.golden @@ -1,2 +1,2 @@ -({cpu: 783707675 +({cpu: 649619269 | mem: 1961730}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt3.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt3.budget.golden index 0c2efaa2e9f..d5400a80dde 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt3.budget.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt3.budget.golden @@ -1,2 +1,2 @@ -({cpu: 942136100 +({cpu: 780012969 | mem: 2379272}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt4.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt4.budget.golden index ff6102aea66..bc2ff4d0de3 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt4.budget.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt4.budget.golden @@ -1,2 +1,2 @@ -({cpu: 705466331 +({cpu: 589750915 | mem: 1737902}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt5.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt5.budget.golden index 6f451f25133..61a0f8642f2 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt5.budget.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt5.budget.golden @@ -1,2 +1,2 @@ -({cpu: 823509793 +({cpu: 683168148 | mem: 2056794}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Value.hs b/plutus-ledger-api/test-plugin/Spec/Data/Value.hs index 7e059a8a95f..b761a1c0633 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Value.hs +++ b/plutus-ledger-api/test-plugin/Spec/Data/Value.hs @@ -160,7 +160,7 @@ eqValueCode valueCode1 valueCode2 = (res, cost) where $$(compile [|| \value1 value2 -> toOpaque ((value1 :: Value) == value2) ||]) `unsafeApplyCode` valueCode1 `unsafeApplyCode` valueCode2 (errOrRes, cost) - = PLC.runCekNoEmit PLC.defaultCekParameters PLC.counting + = PLC.runCekNoEmit PLC.unitCekParameters PLC.counting . PLC.runQuote . PLC.unDeBruijnTermWith (Haskell.error "Free variable") . PLC._progTerm diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Long.stat.golden b/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Long.stat.golden index fd19b85d53b..cef9bbf9434 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Long.stat.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Long.stat.golden @@ -1,15 +1,15 @@ -({cpu: 6727061187 | mem: 12083358}) -({cpu: 10186791 | mem: 31548}) -({cpu: 4747794921 | mem: 8436358}) -({cpu: 10186791 | mem: 31548}) -({cpu: 4747794921 | mem: 8436358}) -({cpu: 10186791 | mem: 31548}) -({cpu: 2768528655 | mem: 4789358}) -({cpu: 10186791 | mem: 31548}) -({cpu: 4747794921 | mem: 8436358}) -({cpu: 10186791 | mem: 31548}) -({cpu: 2768528655 | mem: 4789358}) -({cpu: 10186791 | mem: 31548}) -({cpu: 2768528655 | mem: 4789358}) -({cpu: 10186791 | mem: 31548}) -({cpu: 789262389 | mem: 1142358}) \ No newline at end of file +({cpu: 130537 | mem: 0}) +({cpu: 330 | mem: 0}) +({cpu: 91137 | mem: 0}) +({cpu: 330 | mem: 0}) +({cpu: 91137 | mem: 0}) +({cpu: 330 | mem: 0}) +({cpu: 51737 | mem: 0}) +({cpu: 330 | mem: 0}) +({cpu: 91137 | mem: 0}) +({cpu: 330 | mem: 0}) +({cpu: 51737 | mem: 0}) +({cpu: 330 | mem: 0}) +({cpu: 51737 | mem: 0}) +({cpu: 330 | mem: 0}) +({cpu: 12337 | mem: 0}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Short.stat.golden b/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Short.stat.golden index f8b5b579774..e5823c8a88e 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Short.stat.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Short.stat.golden @@ -1,21 +1,21 @@ -({cpu: 2558808 | mem: 9764}) -({cpu: 6076546 | mem: 22088}) -({cpu: 9274301 | mem: 28614}) -({cpu: 12290217 | mem: 38208}) -({cpu: 14857661 | mem: 42702}) -({cpu: 19002253 | mem: 56424}) -({cpu: 27244616 | mem: 75640}) -({cpu: 30092472 | mem: 88932}) -({cpu: 33960109 | mem: 94490}) -({cpu: 21496965 | mem: 61158}) -({cpu: 52018526 | mem: 141516}) -({cpu: 15858253 | mem: 45636}) -({cpu: 75660303 | mem: 202630}) -({cpu: 91684231 | mem: 252490}) -({cpu: 106030766 | mem: 277832}) -({cpu: 122054694 | mem: 327692}) -({cpu: 142072691 | mem: 367122}) -({cpu: 146217283 | mem: 380844}) -({cpu: 183786078 | mem: 470500}) -({cpu: 73253295 | mem: 204964}) -({cpu: 789262389 | mem: 1142358}) \ No newline at end of file +({cpu: 98 | mem: 0}) +({cpu: 226 | mem: 0}) +({cpu: 298 | mem: 0}) +({cpu: 400 | mem: 0}) +({cpu: 451 | mem: 0}) +({cpu: 597 | mem: 0}) +({cpu: 804 | mem: 0}) +({cpu: 941 | mem: 0}) +({cpu: 1004 | mem: 0}) +({cpu: 647 | mem: 0}) +({cpu: 1510 | mem: 0}) +({cpu: 483 | mem: 0}) +({cpu: 2169 | mem: 0}) +({cpu: 2706 | mem: 0}) +({cpu: 2981 | mem: 0}) +({cpu: 3518 | mem: 0}) +({cpu: 3946 | mem: 0}) +({cpu: 4092 | mem: 0}) +({cpu: 5064 | mem: 0}) +({cpu: 2195 | mem: 0}) +({cpu: 12337 | mem: 0}) \ No newline at end of file From ac628f7cfe32f3886450dfcafa24e6c511a2fc16 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Fri, 7 Jun 2024 21:13:53 +0300 Subject: [PATCH 13/13] Fix Signed-off-by: Ana Pantilie --- .../test-plugin/Spec/Data/Value.hs | 2 +- .../Spec/Data/Value/9.6/Long.stat.golden | 30 ++++++------- .../Spec/Data/Value/9.6/Short.stat.golden | 42 +++++++++---------- 3 files changed, 37 insertions(+), 37 deletions(-) diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Value.hs b/plutus-ledger-api/test-plugin/Spec/Data/Value.hs index b761a1c0633..5559a610335 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Value.hs +++ b/plutus-ledger-api/test-plugin/Spec/Data/Value.hs @@ -160,7 +160,7 @@ eqValueCode valueCode1 valueCode2 = (res, cost) where $$(compile [|| \value1 value2 -> toOpaque ((value1 :: Value) == value2) ||]) `unsafeApplyCode` valueCode1 `unsafeApplyCode` valueCode2 (errOrRes, cost) - = PLC.runCekNoEmit PLC.unitCekParameters PLC.counting + = PLC.runCekNoEmit PLC.defaultCekParametersForTesting PLC.counting . PLC.runQuote . PLC.unDeBruijnTermWith (Haskell.error "Free variable") . PLC._progTerm diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Long.stat.golden b/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Long.stat.golden index cef9bbf9434..1f45520e6b5 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Long.stat.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Long.stat.golden @@ -1,15 +1,15 @@ -({cpu: 130537 | mem: 0}) -({cpu: 330 | mem: 0}) -({cpu: 91137 | mem: 0}) -({cpu: 330 | mem: 0}) -({cpu: 91137 | mem: 0}) -({cpu: 330 | mem: 0}) -({cpu: 51737 | mem: 0}) -({cpu: 330 | mem: 0}) -({cpu: 91137 | mem: 0}) -({cpu: 330 | mem: 0}) -({cpu: 51737 | mem: 0}) -({cpu: 330 | mem: 0}) -({cpu: 51737 | mem: 0}) -({cpu: 330 | mem: 0}) -({cpu: 12337 | mem: 0}) \ No newline at end of file +({cpu: 8318680589 | mem: 12083358}) +({cpu: 7958913 | mem: 31548}) +({cpu: 5918884712 | mem: 8436358}) +({cpu: 7958913 | mem: 31548}) +({cpu: 5918884712 | mem: 8436358}) +({cpu: 7958913 | mem: 31548}) +({cpu: 3519088835 | mem: 4789358}) +({cpu: 7958913 | mem: 31548}) +({cpu: 5918884712 | mem: 8436358}) +({cpu: 7958913 | mem: 31548}) +({cpu: 3519088835 | mem: 4789358}) +({cpu: 7958913 | mem: 31548}) +({cpu: 3519088835 | mem: 4789358}) +({cpu: 7958913 | mem: 31548}) +({cpu: 1119292958 | mem: 1142358}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Short.stat.golden b/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Short.stat.golden index e5823c8a88e..9dd730bda3b 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Short.stat.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Short.stat.golden @@ -1,21 +1,21 @@ -({cpu: 98 | mem: 0}) -({cpu: 226 | mem: 0}) -({cpu: 298 | mem: 0}) -({cpu: 400 | mem: 0}) -({cpu: 451 | mem: 0}) -({cpu: 597 | mem: 0}) -({cpu: 804 | mem: 0}) -({cpu: 941 | mem: 0}) -({cpu: 1004 | mem: 0}) -({cpu: 647 | mem: 0}) -({cpu: 1510 | mem: 0}) -({cpu: 483 | mem: 0}) -({cpu: 2169 | mem: 0}) -({cpu: 2706 | mem: 0}) -({cpu: 2981 | mem: 0}) -({cpu: 3518 | mem: 0}) -({cpu: 3946 | mem: 0}) -({cpu: 4092 | mem: 0}) -({cpu: 5064 | mem: 0}) -({cpu: 2195 | mem: 0}) -({cpu: 12337 | mem: 0}) \ No newline at end of file +({cpu: 1802088 | mem: 9764}) +({cpu: 4468498 | mem: 22088}) +({cpu: 7335302 | mem: 28614}) +({cpu: 9561221 | mem: 38208}) +({cpu: 11971152 | mem: 42702}) +({cpu: 15168499 | mem: 56424}) +({cpu: 22331169 | mem: 75640}) +({cpu: 24024573 | mem: 88932}) +({cpu: 27864383 | mem: 94490}) +({cpu: 17425658 | mem: 61158}) +({cpu: 43051203 | mem: 141516}) +({cpu: 12785716 | mem: 45636}) +({cpu: 62873873 | mem: 202630}) +({cpu: 75086273 | mem: 252490}) +({cpu: 89814782 | mem: 277832}) +({cpu: 102027182 | mem: 327692}) +({cpu: 121582494 | mem: 367122}) +({cpu: 124779841 | mem: 380844}) +({cpu: 158177009 | mem: 470500}) +({cpu: 59505962 | mem: 204964}) +({cpu: 1119292958 | mem: 1142358}) \ No newline at end of file