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. diff --git a/plutus-ledger-api/plutus-ledger-api.cabal b/plutus-ledger-api/plutus-ledger-api.cabal index 666d1544925..39563c31a93 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 @@ -116,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 @@ -150,6 +152,7 @@ test-suite plutus-ledger-api-test Spec.Eval Spec.Interval Spec.ScriptDecodeError + Spec.V1.Data.Value Spec.V1.Value Spec.Versions @@ -185,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.ReturnUnit.V1 Spec.ReturnUnit.V2 Spec.ReturnUnit.V3 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..e94bc03a213 --- /dev/null +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs @@ -0,0 +1,622 @@ +-- 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 https://github.com/IntersectMBO/plutus/issues/6172. + +-- | 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 (UnsafeFromData (unsafeFromBuiltinData)) +import PlutusLedgerApi.V1.Bytes (LedgerBytes (LedgerBytes), encodeByteString) +import PlutusTx qualified +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.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 + 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`. + Map.foldr (\amt acc -> amt + acc) 0 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 + :: (BuiltinData -> Bool) + -> (BuiltinData -> BuiltinData -> Bool) + -> BuiltinList (BuiltinPair BuiltinData BuiltinData) + -> BuiltinList (BuiltinPair BuiltinData BuiltinData) + -> Bool +unordEqWith is0 eqV = goBoth where + 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 :: Map.Map BuiltinData BuiltinData)) + ) + -- non-null l1 case + ( \hd1 tl1 -> + B.matchList + l2 + -- null l2 case + (\() -> Map.all is0 (Map.unsafeFromBuiltinList l1 :: Map.Map BuiltinData BuiltinData)) + -- 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 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. +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 +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 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 = + 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 +-- 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) = + eqMapOfMapsWith (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-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 diff --git a/plutus-ledger-api/test-plugin/Spec.hs b/plutus-ledger-api/test-plugin/Spec.hs index d38230a8c9d..60b4b1a17a0 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.ReturnUnit.V1 qualified import Spec.ReturnUnit.V2 qualified import Spec.ReturnUnit.V3 qualified @@ -18,4 +20,6 @@ tests = testGroup "plutus-ledger-api-plugin-test" , Spec.ReturnUnit.V1.tests , Spec.ReturnUnit.V2.tests , Spec.ReturnUnit.V3.tests + , 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..195379a5747 --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/currencySymbolValueOf.budget.golden @@ -0,0 +1,2 @@ +({cpu: 22967162 +| mem: 64380}) \ 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..e40fc85f47f --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/currencySymbolValueOf.pir.golden @@ -0,0 +1,71 @@ +let + data Unit | Unit_match where + Unit : Unit +in +letrec + !go : list (pair data data) -> integer + = \(xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> integer} + xs + (\(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 + addInteger (unIData (sndPair {data} {data} hd)) (go tl)) + Unit +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) -> + 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/geq1.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq1.budget.golden new file mode 100644 index 00000000000..889d817f475 --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq1.budget.golden @@ -0,0 +1,2 @@ +({cpu: 614011320 +| 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..1c96be260f1 --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq2.budget.golden @@ -0,0 +1,2 @@ +({cpu: 649267269 +| 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..0cb8213faf4 --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq3.budget.golden @@ -0,0 +1,2 @@ +({cpu: 677953814 +| 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..7cc3dfba486 --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq4.budget.golden @@ -0,0 +1,2 @@ +({cpu: 589398915 +| 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..9d0dcbff6db --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq5.budget.golden @@ -0,0 +1,2 @@ +({cpu: 636471807 +| 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..76ed91318bb --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt.pir.golden @@ -0,0 +1,641 @@ +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 + !`$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 + data Unit | Unit_match where + Unit : Unit + !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) +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 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 + !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)) + 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 + (\(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) + {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..52164d0cda0 --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt1.budget.golden @@ -0,0 +1,2 @@ +({cpu: 712873128 +| mem: 2153344}) \ 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..4a622ce09d2 --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt2.budget.golden @@ -0,0 +1,2 @@ +({cpu: 649619269 +| mem: 1961730}) \ 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..d5400a80dde --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt3.budget.golden @@ -0,0 +1,2 @@ +({cpu: 780012969 +| mem: 2379272}) \ 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..bc2ff4d0de3 --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt4.budget.golden @@ -0,0 +1,2 @@ +({cpu: 589750915 +| mem: 1737902}) \ 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..61a0f8642f2 --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt5.budget.golden @@ -0,0 +1,2 @@ +({cpu: 683168148 +| mem: 2056794}) \ 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..5559a610335 --- /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.defaultCekParametersForTesting 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..1f45520e6b5 --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Long.stat.golden @@ -0,0 +1,15 @@ +({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 new file mode 100644 index 00000000000..9dd730bda3b --- /dev/null +++ b/plutus-ledger-api/test-plugin/Spec/Data/Value/9.6/Short.stat.golden @@ -0,0 +1,21 @@ +({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 diff --git a/plutus-ledger-api/test/Spec.hs b/plutus-ledger-api/test/Spec.hs index 8e312a47b30..abbc3dbb022 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 diff --git a/plutus-tx/src/PlutusTx/Data/AssocMap.hs b/plutus-tx/src/PlutusTx/Data/AssocMap.hs index 48712bd3274..59b426915b2 100644 --- a/plutus-tx/src/PlutusTx/Data/AssocMap.hs +++ b/plutus-tx/src/PlutusTx/Data/AssocMap.hs @@ -24,13 +24,19 @@ module PlutusTx.Data.AssocMap ( any, union, unionWith, + 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, 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 @@ -190,11 +196,11 @@ 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 - . foldr (uncurry go) [] + . List.foldr (uncurry go) [] where go k v [] = [(P.toBuiltinData k, P.toBuiltinData v)] go k v ((k', v') : rest) = @@ -321,6 +327,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 +416,85 @@ 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 + +{-# INLINEABLE mapThese #-} +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) + ) + +{-# 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 + go xs = + P.matchList + xs + (\() -> z) + ( \hd tl -> + let v = BI.snd hd + in f (P.unsafeFromBuiltinData v) (go tl) + ) + makeLift ''Map