From c03986f959327fcd9710573e8ace351f615b0846 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Mon, 29 Apr 2024 13:10:16 +0300 Subject: [PATCH 01/41] Add AssocList backed by Data Co-authored-by: Ziyang Liu Signed-off-by: Ana Pantilie --- plutus-tx-plugin/test/AssocList/Spec.hs | 368 +++++++++++++++++++ plutus-tx-plugin/test/Budget/Spec.hs | 2 +- plutus-tx/plutus-tx.cabal | 1 + plutus-tx/src/PlutusTx/AssocMap.hs | 3 +- plutus-tx/src/PlutusTx/Builtins.hs | 5 + plutus-tx/src/PlutusTx/Data/AssocList.hs | 395 +++++++++++++++++++++ plutus-tx/src/PlutusTx/IsData/Instances.hs | 2 + 7 files changed, 774 insertions(+), 2 deletions(-) create mode 100644 plutus-tx-plugin/test/AssocList/Spec.hs create mode 100644 plutus-tx/src/PlutusTx/Data/AssocList.hs diff --git a/plutus-tx-plugin/test/AssocList/Spec.hs b/plutus-tx-plugin/test/AssocList/Spec.hs new file mode 100644 index 00000000000..479915eef3a --- /dev/null +++ b/plutus-tx-plugin/test/AssocList/Spec.hs @@ -0,0 +1,368 @@ +-- editorconfig-checker-disable-file +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# 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 #-} +{-# LANGUAGE FlexibleInstances #-} + +module AssocList.Spec where + +import Test.Tasty.Extras + +import Control.Monad (when) +import Data.List (nubBy, sort) +import Data.Map.Strict qualified as HMap +import Data.Map.Strict qualified as Map +import Debug.Trace (traceM) +import Hedgehog (Gen, MonadTest, Property, Range, assert, forAll, property, (===)) +import Hedgehog.Gen (discard) +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import PlutusTx.AssocMap qualified as AssocMap +import PlutusTx.Builtins qualified as PlutusTx +import PlutusTx.Code +import PlutusTx.Data.AssocList (AssocList) +import PlutusTx.Data.AssocList qualified as Data.AssocList +import PlutusTx.IsData () +import PlutusTx.IsData qualified as P +import PlutusTx.Lift (liftCodeDef) +import PlutusTx.Prelude qualified as PlutusTx +import PlutusTx.Show qualified as PlutusTx +import PlutusTx.Test +import PlutusTx.TH (compile) +import PlutusTx.These (These (..)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testProperty) + +goldenTests :: TestNested +goldenTests = + testNestedGhc + "Budget" + [ goldenPirReadable "map1" map1 + , goldenUPlcReadable "map1" map1 + , goldenEvalCekCatch "map1" $ [map1 `unsafeApplyCode` (liftCodeDef 100)] + , goldenBudget "map1-budget" $ map1 `unsafeApplyCode` (liftCodeDef 100) + , goldenPirReadable "map2" map2 + , goldenUPlcReadable "map2" map2 + , goldenEvalCekCatch "map2" $ [map2 `unsafeApplyCode` (liftCodeDef 100)] + , goldenBudget "map2-budget" $ map2 `unsafeApplyCode` (liftCodeDef 100) + ] + +propertyTests :: TestTree +propertyTests = + testGroup "TESTING Map property tests" + [ testProperty "safeFromList" safeFromListSpec + , testProperty "unsafeFromList" unsafeFromListSpec + , testProperty "lookup" lookupSpec + , testProperty "member" memberSpec + , testProperty "insert" insertSpec + , testProperty "all" allSpec + , testProperty "any" anySpec + , testProperty "keys" keysSpec + , testProperty "uncons" unconsSpec + , testProperty "unsafeUncons" unsafeUnconsSpec + , testProperty "noDuplicateKeys" noDuplicateKeysSpec + , testProperty "delete" deleteSpec + , testProperty "union" unionSpec + ] + +map1 :: + CompiledCode + ( Integer -> + ( Maybe PlutusTx.BuiltinByteString + , Maybe PlutusTx.BuiltinByteString + , Maybe PlutusTx.BuiltinByteString + , Maybe PlutusTx.BuiltinByteString + , Maybe PlutusTx.BuiltinByteString + ) + ) +map1 = + $$( compile + [|| + \n -> + let m :: AssocList Integer PlutusTx.BuiltinByteString + m = + foldr + (\i -> Data.AssocList.insert (n PlutusTx.+ i) (PlutusTx.encodeUtf8 (PlutusTx.show i))) + (Data.AssocList.singleton n "0") + (PlutusTx.enumFromTo 1 10) + m' = Data.AssocList.delete (n PlutusTx.+ 5) m + in ( Data.AssocList.lookup n m + , Data.AssocList.lookup (n PlutusTx.+ 5) m + , Data.AssocList.lookup (n PlutusTx.+ 10) m + , Data.AssocList.lookup (n PlutusTx.+ 20) m + , Data.AssocList.lookup (n PlutusTx.+ 5) m' + ) + ||] + ) + +map2 :: CompiledCode (Integer -> [(Integer, PlutusTx.BuiltinString)]) +map2 = + $$( compile + [|| + \n -> + let m1 = + Data.AssocList.unsafeFromList + [ (n PlutusTx.+ 1, "one") + , (n PlutusTx.+ 2, "two") + , (n PlutusTx.+ 3, "three") + , (n PlutusTx.+ 4, "four") + , (n PlutusTx.+ 5, "five") + ] + m2 = + Data.AssocList.unsafeFromList + [ (n PlutusTx.+ 3, "THREE") + , (n PlutusTx.+ 4, "FOUR") + , (n PlutusTx.+ 6, "SIX") + , (n PlutusTx.+ 7, "SEVEN") + ] + m = Data.AssocList.unionWith PlutusTx.appendByteString m1 m2 + in PlutusTx.fmap (\(k, v) -> (k, PlutusTx.decodeUtf8 v)) (Data.AssocList.toList m) + ||] + ) + +newtype AssocListS k v = AssocListS [(k, v)] + deriving (Show, Eq) + +nullS :: AssocListS k v -> Bool +nullS (AssocListS l) = null l + +semanticsToAssocMap :: AssocListS k v -> AssocMap.Map k v +semanticsToAssocMap = AssocMap.unsafeFromList . toListS + +semanticsToAssocList :: (P.ToData k, P.ToData v) => AssocListS k v -> AssocList k v +semanticsToAssocList = Data.AssocList.unsafeFromList . toListS + +assocMapToSemantics :: AssocMap.Map k v -> AssocListS k v +assocMapToSemantics = unsafeFromListS . AssocMap.toList + +assocListToSemantics + :: (P.UnsafeFromData k, P.UnsafeFromData v) => AssocList k v -> AssocListS k v +assocListToSemantics = unsafeFromListS . Data.AssocList.toList + +sortS :: (Ord k, Ord v) => AssocListS k v -> AssocListS k v +sortS (AssocListS l) = AssocListS $ sort l + +toListS :: AssocListS k v -> [(k, v)] +toListS (AssocListS l) = l + +unsafeFromListS :: [(k, v)] -> AssocListS k v +unsafeFromListS = AssocListS + +safeFromListS :: Ord k => [(k, v)] -> AssocListS k v +safeFromListS = AssocListS . Map.toList . Map.fromList + +lookupS :: Integer -> AssocListS Integer Integer -> Maybe Integer +lookupS k (AssocListS l) = Map.lookup k . Map.fromList $ l + +memberS :: Integer -> AssocListS Integer Integer -> Bool +memberS k (AssocListS l) = Map.member k . Map.fromList $ l + +insertS :: Integer -> Integer -> AssocListS Integer Integer -> AssocListS Integer Integer +insertS k v (AssocListS l) = + AssocListS . Map.toList . Map.insert k v . Map.fromList $ l + +deleteS :: Integer -> AssocListS Integer Integer -> AssocListS Integer Integer +deleteS k (AssocListS l) = + AssocListS . Map.toList . Map.delete k . Map.fromList $ l + +allS :: (Integer -> Bool) -> AssocListS Integer Integer -> Bool +allS p (AssocListS l) = all (p . snd) l + +anyS :: (Integer -> Bool) -> AssocListS Integer Integer -> Bool +anyS p (AssocListS l) = any (p . snd) l + +keysS :: AssocListS Integer Integer -> [Integer] +keysS (AssocListS l) = map fst l + +unconsS :: AssocListS Integer Integer -> Maybe ((Integer, Integer), AssocListS Integer Integer) +unconsS (AssocListS []) = Nothing +unconsS (AssocListS (x : xs)) = Just (x, AssocListS xs) + +unsafeUnconsS :: AssocListS Integer Integer -> ((Integer, Integer), AssocListS Integer Integer) +unsafeUnconsS (AssocListS []) = error "unsafeUnconsS: empty list" +unsafeUnconsS (AssocListS (x : xs)) = (x, AssocListS xs) + +noDuplicateKeysS :: AssocListS Integer Integer -> Bool +noDuplicateKeysS (AssocListS l) = + length l == length (nubBy (\(k1, _) (k2, _) -> k1 == k2) l) + +genAssocListS :: Gen (AssocListS Integer Integer) +genAssocListS = + AssocListS . Map.toList <$> Gen.map rangeLength genPair + where + genPair :: Gen (Integer, Integer) + genPair = do + (,) <$> Gen.integral rangeElem <*> Gen.integral rangeElem + +genUnsafeAssocListS :: Gen (AssocListS Integer Integer) +genUnsafeAssocListS = do + AssocListS <$> Gen.list rangeLength genPair + where + genPair :: Gen (Integer, Integer) + genPair = do + (,) <$> Gen.integral rangeElem <*> Gen.integral rangeElem + +unionS + :: AssocListS Integer Integer + -> AssocListS Integer Integer + -> AssocListS Integer (These Integer Integer) +unionS (AssocListS ls) (AssocListS rs) = + let + f a b' = case b' of + Nothing -> This a + Just b -> These a b + + ls' = fmap (\(c, i) -> (c, f i (lookupS c (AssocListS rs)))) ls + + -- Keeps only those keys which don't appear in the left map. + rs' = filter (\(c, _) -> not (any (\(c', _) -> c' == c) ls)) rs + + rs'' = fmap (fmap That) rs' + in + AssocListS (ls' ++ rs'') + +class Equivalence l where + (~~) :: + ( MonadTest m + , Show k + , Show v + , Ord k + , Ord v + , P.UnsafeFromData k + , P.UnsafeFromData v + ) => AssocListS k v -> l k v -> m () + +instance Equivalence AssocMap.Map where + assocListS ~~ assocMap = + sortS assocListS === sortS (assocMapToSemantics assocMap) + +instance Equivalence AssocList where + assocListS ~~ assocList = + sortS assocListS === sortS (assocListToSemantics assocList) + +rangeElem :: Range Integer +rangeElem = Range.linear 0 100 + +rangeLength :: Range Int +rangeLength = Range.linear 0 100 + +safeFromListSpec :: Property +safeFromListSpec = property $ do + assocListS <- forAll genAssocListS + let assocMap = AssocMap.safeFromList . toListS $ assocListS + assocList = Data.AssocList.safeFromList . toListS $ assocListS + assocListS ~~ assocMap + assocListS ~~ assocList + +unsafeFromListSpec :: Property +unsafeFromListSpec = property $ do + assocListS <- forAll genAssocListS + let assocMap = AssocMap.unsafeFromList . toListS $ assocListS + assocList = Data.AssocList.unsafeFromList . toListS $ assocListS + assocListS ~~ assocMap + assocListS ~~ assocList + +lookupSpec :: Property +lookupSpec = property $ do + assocListS <- forAll genAssocListS + key <- forAll $ Gen.integral rangeElem + let assocMap = semanticsToAssocMap assocListS + assocList = semanticsToAssocList assocListS + lookupS key assocListS === AssocMap.lookup key assocMap + lookupS key assocListS === Data.AssocList.lookup key assocList + +memberSpec :: Property +memberSpec = property $ do + assocListS <- forAll genAssocListS + key <- forAll $ Gen.integral rangeElem + let assocMap = semanticsToAssocMap assocListS + assocList = semanticsToAssocList assocListS + memberS key assocListS === AssocMap.member key assocMap + memberS key assocListS === Data.AssocList.member key assocList + +insertSpec :: Property +insertSpec = property $ do + assocListS <- forAll genAssocListS + key <- forAll $ Gen.integral rangeElem + value <- forAll $ Gen.integral rangeElem + let assocMap = semanticsToAssocMap assocListS + assocList = semanticsToAssocList assocListS + insertS key value assocListS ~~ AssocMap.insert key value assocMap + insertS key value assocListS ~~ Data.AssocList.insert key value assocList + +deleteSpec :: Property +deleteSpec = property $ do + assocListS <- forAll genAssocListS + key <- forAll $ Gen.integral rangeElem + let assocMap = semanticsToAssocMap assocListS + assocList = semanticsToAssocList assocListS + deleteS key assocListS ~~ AssocMap.delete key assocMap + deleteS key assocListS ~~ Data.AssocList.delete key assocList + +allSpec :: Property +allSpec = property $ do + assocListS <- forAll genAssocListS + num <- forAll $ Gen.integral rangeElem + let assocMap = semanticsToAssocMap assocListS + assocList = semanticsToAssocList assocListS + predicate x = x < num + allS predicate assocListS === AssocMap.all predicate assocMap + allS predicate assocListS === Data.AssocList.all predicate assocList + +anySpec :: Property +anySpec = property $ do + assocListS <- forAll genAssocListS + num <- forAll $ Gen.integral rangeElem + let assocList = semanticsToAssocList assocListS + predicate x = x < num + anyS predicate assocListS === Data.AssocList.any predicate assocList + +keysSpec :: Property +keysSpec = property $ do + assocListS <- forAll genAssocListS + let assocMap = semanticsToAssocMap assocListS + keysS assocListS === AssocMap.keys assocMap + +unconsSpec :: Property +unconsSpec = property $ do + assocListS <- forAll genAssocListS + let assocList = semanticsToAssocList assocListS + unconsS assocListS `equiv` Data.AssocList.uncons assocList + where + equiv res1 res2 = + res1 === (fmap . fmap) assocListToSemantics res2 + +unsafeUnconsSpec :: Property +unsafeUnconsSpec = property $ do + assocListS <- forAll $ Gen.filter (not . nullS) genAssocListS + let assocList = semanticsToAssocList assocListS + unsafeUnconsS assocListS `equiv` Data.AssocList.unsafeUncons assocList + where + equiv res1 res2 = + res1 === fmap assocListToSemantics res2 + +noDuplicateKeysSpec :: Property +noDuplicateKeysSpec = property $ do + assocListS <- forAll genAssocListS + let assocList = semanticsToAssocList assocListS + noDuplicateKeysS assocListS === Data.AssocList.noDuplicateKeys assocList + +unionSpec :: Property +unionSpec = property $ do + assocListS1 <- forAll genAssocListS + assocListS2 <- forAll genAssocListS + let assocMap1 = semanticsToAssocMap assocListS1 + assocMap2 = semanticsToAssocMap assocListS2 + assocList1 = semanticsToAssocList assocListS1 + assocList2 = semanticsToAssocList assocListS1 + unionS assocListS1 assocListS2 ~~ AssocMap.union assocMap1 assocMap2 + unionS assocListS1 assocListS2 ~~ Data.AssocList.union assocList1 assocList2 + diff --git a/plutus-tx-plugin/test/Budget/Spec.hs b/plutus-tx-plugin/test/Budget/Spec.hs index 3c779f5177d..d9be44960b1 100644 --- a/plutus-tx-plugin/test/Budget/Spec.hs +++ b/plutus-tx-plugin/test/Budget/Spec.hs @@ -19,7 +19,7 @@ import Test.Tasty.Extras import Budget.WithGHCOptimisations qualified as WithGHCOptTest import Budget.WithoutGHCOptimisations qualified as WithoutGHCOptTest import PlutusTx.AsData qualified as AsData -import PlutusTx.Builtins qualified as PlutusTx +import PlutusTx.Builtins qualified as PlutusTx hiding (null) import PlutusTx.Code import PlutusTx.IsData qualified as IsData import PlutusTx.Lift (liftCodeDef, makeLift) diff --git a/plutus-tx/plutus-tx.cabal b/plutus-tx/plutus-tx.cabal index 764d98f70bd..864b6073193 100644 --- a/plutus-tx/plutus-tx.cabal +++ b/plutus-tx/plutus-tx.cabal @@ -74,6 +74,7 @@ library PlutusTx.Builtins.Internal PlutusTx.Code PlutusTx.Coverage + PlutusTx.Data.AssocList PlutusTx.Either PlutusTx.Enum PlutusTx.Eq diff --git a/plutus-tx/src/PlutusTx/AssocMap.hs b/plutus-tx/src/PlutusTx/AssocMap.hs index 12cfce5684c..f49d7c8f940 100644 --- a/plutus-tx/src/PlutusTx/AssocMap.hs +++ b/plutus-tx/src/PlutusTx/AssocMap.hs @@ -39,7 +39,7 @@ module PlutusTx.AssocMap ( import Prelude qualified as Haskell -import PlutusTx.Builtins qualified as P +import PlutusTx.Builtins qualified as P hiding (null) import PlutusTx.Builtins.Internal qualified as BI import PlutusTx.IsData import PlutusTx.Lift (makeLift) @@ -235,6 +235,7 @@ delete key (Map ls) = Map (go ls) keys :: Map k v -> [k] keys (Map xs) = P.fmap (\(k, _ :: v) -> k) xs +{-# INLINEABLE union #-} -- | Combine two 'Map's. Keeps both values on key collisions. -- Note that well-formedness is only preserved if the two input maps -- are also well-formed. diff --git a/plutus-tx/src/PlutusTx/Builtins.hs b/plutus-tx/src/PlutusTx/Builtins.hs index 775d24c9bfc..4eb97a9a15b 100644 --- a/plutus-tx/src/PlutusTx/Builtins.hs +++ b/plutus-tx/src/PlutusTx/Builtins.hs @@ -68,6 +68,7 @@ module PlutusTx.Builtins ( -- * Pairs , pairToPair -- * Lists + , null , matchList , headMaybe , BI.head @@ -383,6 +384,10 @@ trace = BI.trace encodeUtf8 :: BuiltinString -> BuiltinByteString encodeUtf8 = BI.encodeUtf8 +{-# INLINABLE null #-} +null :: forall a. BI.BuiltinList a -> Bool +null l = fromBuiltin (BI.null l) + {-# INLINABLE matchList #-} matchList :: forall a r . BI.BuiltinList a -> r -> (a -> BI.BuiltinList a -> r) -> r matchList l nilCase consCase = BI.chooseList l (const nilCase) (\_ -> consCase (BI.head l) (BI.tail l)) () diff --git a/plutus-tx/src/PlutusTx/Data/AssocList.hs b/plutus-tx/src/PlutusTx/Data/AssocList.hs new file mode 100644 index 00000000000..a1e6733723a --- /dev/null +++ b/plutus-tx/src/PlutusTx/Data/AssocList.hs @@ -0,0 +1,395 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ViewPatterns #-} + +module PlutusTx.Data.AssocList ( + AssocList, + lookup, + member, + insert, + delete, + singleton, + empty, + null, + toList, + toBuiltinList, + safeFromList, + unsafeFromList, + unsafeFromBuiltinList, + uncons, + unsafeUncons, + noDuplicateKeys, + all, + any, + union, + unionWith, + ) where + +import PlutusTx.Builtins qualified as P +import PlutusTx.Builtins.Internal qualified as BI +import PlutusTx.IsData qualified as P +import PlutusTx.Prelude hiding (all, any, null, toList, uncons) +import PlutusTx.These + +import Prelude qualified as Haskell + +-- TODO: fix docs +{- | An associative map implementation backed by `P.BuiltinData`. + +This map implementation has the following characteristics: + + * The `P.toBuiltinData` and `P.unsafeFromBuiltinData` operations are no-op. + * Other operations are slower than @PlutusTx.AssocMap.Map@, although equality + checks on keys can be faster due to `P.equalsData`. + * Many operations involve converting the keys and/or values to/from `P.BuiltinData`. + +Therefore this map implementation is likely a better choice than @PlutusTx.AssocMap.Map@ +if it is part of a data type defined using @asData@, and the key and value types +have efficient `P.toBuiltinData` and `P.unsafeFromBuiltinData` operations (e.g., they +are primitive types or types defined using @asData@). +-} +newtype AssocList k a = AssocList P.BuiltinData + deriving stock (Haskell.Eq, Haskell.Show) + deriving newtype (Eq) + +instance P.ToData (AssocList k a) where + {-# INLINEABLE toBuiltinData #-} + toBuiltinData (AssocList d) = d + +instance P.FromData (AssocList k a) where + fromBuiltinData = Just . AssocList + +instance P.UnsafeFromData (AssocList k a) where + unsafeFromBuiltinData = AssocList + +{-# INLINEABLE lookup #-} +lookup :: forall k a. (P.ToData k, P.UnsafeFromData a) => k -> AssocList k a -> Maybe a +lookup (P.toBuiltinData -> k) m = case lookup' k (toBuiltinList m) of + Just a -> Just (P.unsafeFromBuiltinData a) + Nothing -> Nothing + +{-# INLINEABLE lookup' #-} +lookup' :: + BuiltinData -> + BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> + Maybe BuiltinData +lookup' k = go + where + go xs = + P.matchList + xs + Nothing + ( \hd tl -> + let k' = BI.fst hd + in if P.equalsData k k' + then Just (BI.snd hd) + else go tl + ) + +{-# INLINEABLE member #-} +member :: forall k a. (P.ToData k) => k -> AssocList k a -> Bool +member (P.toBuiltinData -> k) m = member' k (toBuiltinList m) + +{-# INLINEABLE member' #-} +member' :: BuiltinData -> BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> Bool +member' k = go + where + go :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> Bool + go xs = + P.matchList + xs + False + ( \hd tl -> + let k' = BI.fst hd + in if P.equalsData k k' + then True + else go tl + ) + +{-# INLINEABLE insert #-} +insert :: forall k a. (P.ToData k, P.ToData a) => k -> a -> AssocList k a -> AssocList k a +insert (P.toBuiltinData -> k) (P.toBuiltinData -> a) m = + unsafeFromBuiltinList (go (toBuiltinList m)) + where + go :: + BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> + BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) + go xs = + P.matchList + xs + (BI.mkCons (BI.mkPairData k a) nil) + ( \hd tl -> + let k' = BI.fst hd + in if P.equalsData k k' + then BI.mkCons (BI.mkPairData k a) tl + else BI.mkCons hd (go tl) + ) + +{-# INLINEABLE delete #-} +delete :: forall k a. (P.ToData k) => k -> AssocList k a -> AssocList k a +delete (P.toBuiltinData -> k) m = unsafeFromBuiltinList (go (toBuiltinList m)) + where + go :: + BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> + BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) + go xs = + P.matchList + xs + nil + ( \hd tl -> + let k' = BI.fst hd + in if P.equalsData k k' + then tl + else BI.mkCons hd (go tl) + ) + +{-# INLINEABLE singleton #-} +singleton :: forall k a. (P.ToData k, P.ToData a) => k -> a -> AssocList k a +singleton (P.toBuiltinData -> k) (P.toBuiltinData -> a) = unsafeFromBuiltinList xs + where + xs = BI.mkCons (BI.mkPairData k a) nil + +{-# INLINEABLE empty #-} +empty :: forall k a. AssocList k a +empty = unsafeFromBuiltinList nil + +{-# INLINEABLE null #-} +null :: forall k a. AssocList k a -> Bool +null = P.null . toBuiltinList + +{-# INLINEABLE safeFromList #-} +safeFromList :: forall k a . (Eq k, P.ToData k, P.ToData a) => [(k, a)] -> AssocList k a +safeFromList = + unsafeFromBuiltinList + . toBuiltin + . PlutusTx.Prelude.map (\(k, a) -> (P.toBuiltinData k, P.toBuiltinData a)) + . foldr (uncurry go) [] + where + go :: k -> a -> [(k, a)] -> [(k, a)] + go k v [] = [(k, v)] + go k v ((k', v') : rest) = + if k == k' + then (k, v) : rest + else (k', v') : go k v rest + +{-# INLINEABLE unsafeFromList #-} +unsafeFromList :: (P.ToData k, P.ToData a) => [(k, a)] -> AssocList k a +unsafeFromList = + unsafeFromBuiltinList + . toBuiltin + . PlutusTx.Prelude.map (\(k, a) -> (P.toBuiltinData k, P.toBuiltinData a)) + +{-# INLINEABLE uncons #-} +uncons :: + forall k a. + (P.UnsafeFromData k, P.UnsafeFromData a) => + AssocList k a -> + Maybe ((k, a), AssocList k a) +uncons m = case P.uncons (toBuiltinList m) of + Nothing -> Nothing + Just (pair, rest) -> + let (k, a) = P.pairToPair pair + in Just ((P.unsafeFromBuiltinData k, P.unsafeFromBuiltinData a), unsafeFromBuiltinList rest) + +{-# INLINEABLE unsafeUncons #-} +unsafeUncons :: + forall k a. + (P.UnsafeFromData k, P.UnsafeFromData a) => + AssocList k a -> + ((k, a), AssocList k a) +unsafeUncons m = + ((P.unsafeFromBuiltinData k, P.unsafeFromBuiltinData a), unsafeFromBuiltinList tl) + where + (hd, tl) = P.unsafeUncons (toBuiltinList m) + (k, a) = P.pairToPair hd + +{-# INLINEABLE noDuplicateKeys #-} +noDuplicateKeys :: forall k a. AssocList k a -> Bool +noDuplicateKeys m = go (toBuiltinList m) + where + go :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> Bool + go xs = + P.matchList + xs + True + ( \hd tl -> + let k = BI.fst hd + in if member' k tl then False else go tl + ) + +{-# INLINEABLE all #-} +all :: forall k a. (P.UnsafeFromData a) => (a -> Bool) -> AssocList k a -> Bool +all p m = go (toBuiltinList m) + where + go :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> Bool + go xs = + P.matchList + xs + True + ( \hd tl -> + let a = P.unsafeFromBuiltinData (BI.snd hd) + in if p a then go tl else False + ) + +{-# INLINEABLE any #-} +any :: forall k a. (P.UnsafeFromData a) => (a -> Bool) -> AssocList k a -> Bool +any p m = go (toBuiltinList m) + where + go :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> Bool + go xs = + P.matchList + xs + False + ( \hd tl -> + let a = P.unsafeFromBuiltinData (BI.snd hd) + in if p a then True else go tl + ) + +{-# INLINEABLE union #-} + +-- TODO: This is broken! +-- The value should be a correct encoding of a `These` value, but it is not. +-- Example: +-- > union (safeFromList []) (safeFromList [(0, 0)]) :: AssocList Integer (These Integer Integer) +-- > AssocList Map [(I 0,I 0)] +-- The second element of the pair should be encoded as the appropriate `Constr`! +-- | Combine two 'AssocList's. +union :: + forall k a b. + (P.UnsafeFromData a, P.UnsafeFromData b, P.ToData a, P.ToData b) => + AssocList k a -> + AssocList k b -> + AssocList k (These a b) +union (toBuiltinList -> ls) (toBuiltinList -> rs) = unsafeFromBuiltinList res + where + ls' :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) + ls' = go ls + where + go xs = + P.matchList + xs + nil + ( \hd tl -> + let k' = BI.fst hd + v' = BI.snd hd + v'' = case lookup' k' rs of + Just r -> + P.toBuiltinData + ( These + (P.unsafeFromBuiltinData v') + (P.unsafeFromBuiltinData r) :: + These a b + ) + Nothing -> P.toBuiltinData (This (P.unsafeFromBuiltinData v') :: These a b) + in BI.mkCons (BI.mkPairData k' v'') (go tl) + ) + + rs' :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) + rs' = go rs + where + go xs = + P.matchList + xs + nil + ( \hd tl -> + let k' = BI.fst hd + tl' = go tl + in if member' k' ls + then tl' + else BI.mkCons hd tl' + ) + + res :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) + res = go rs' ls' + where + go acc xs = + P.matchList + xs + acc + (\hd -> go (BI.mkCons hd acc)) + +-- | Combine two 'AssocList's with the given combination function. +unionWith :: + forall k a. + (P.UnsafeFromData a, P.ToData a) => + (a -> a -> a) -> + AssocList k a -> + AssocList k a -> + AssocList k a +unionWith f (toBuiltinList -> ls) (toBuiltinList -> rs) = + unsafeFromBuiltinList res + where + ls' :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) + ls' = go ls + where + go xs = + P.matchList + xs + nil + ( \hd tl -> + let k' = BI.fst hd + v' = BI.snd hd + v'' = case lookup' k' rs of + Just r -> + P.toBuiltinData + (f (P.unsafeFromBuiltinData v') (P.unsafeFromBuiltinData r)) + Nothing -> v' + in BI.mkCons (BI.mkPairData k' v'') (go tl) + ) + + rs' :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) + rs' = go rs + where + go xs = + P.matchList + xs + nil + ( \hd tl -> + let k' = BI.fst hd + tl' = go tl + in if member' k' ls + then tl' + else BI.mkCons hd tl' + ) + + res :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) + res = go rs' ls' + where + go acc xs = + P.matchList + xs + acc + (\hd -> go (BI.mkCons hd acc)) + +{-# INLINEABLE toList #-} + +{- | `toList` is expensive since it traverses the whole map. +`toBuiltinList` is much faster. +-} +toList :: (P.UnsafeFromData k, P.UnsafeFromData a) => AssocList k a -> [(k, a)] +toList d = go (toBuiltinList d) + where + go xs = + P.matchList + xs + [] + ( \hd tl -> + (P.unsafeFromBuiltinData (BI.fst hd), P.unsafeFromBuiltinData (BI.snd hd)) + : go tl + ) + +{-# INLINEABLE toBuiltinList #-} +toBuiltinList :: AssocList k a -> BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) +toBuiltinList (AssocList d) = BI.unsafeDataAsMap d + +{-# INLINEABLE unsafeFromBuiltinList #-} +unsafeFromBuiltinList :: + forall k a. + BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> + AssocList k a +unsafeFromBuiltinList = AssocList . BI.mkMap + +{-# INLINEABLE nil #-} +nil :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) +nil = BI.mkNilPairData BI.unitval diff --git a/plutus-tx/src/PlutusTx/IsData/Instances.hs b/plutus-tx/src/PlutusTx/IsData/Instances.hs index 0da5b45e979..24ed9a19ca8 100644 --- a/plutus-tx/src/PlutusTx/IsData/Instances.hs +++ b/plutus-tx/src/PlutusTx/IsData/Instances.hs @@ -12,12 +12,14 @@ import PlutusTx.Bool (Bool (..)) import PlutusTx.Either (Either (..)) import PlutusTx.IsData.TH (makeIsDataIndexed, unstableMakeIsData) import PlutusTx.Maybe (Maybe (..)) +import PlutusTx.These (These (..)) -- While these types should be stable, we really don't want them changing, so index -- them explicitly to be sure. makeIsDataIndexed ''Bool [('False,0),('True,1)] makeIsDataIndexed ''Maybe [('Just,0),('Nothing,1)] makeIsDataIndexed ''Either [('Left,0),('Right,1)] +makeIsDataIndexed ''These [('This,1),('That,2),('These,3)] -- Okay to use unstableMakeIsData here since there's only one alternative and we're sure -- that will never change. From 0fcaac82a755c63ef41f890454047f17fac4b6e1 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Mon, 29 Apr 2024 13:32:40 +0300 Subject: [PATCH 02/41] Fix build Signed-off-by: Ana Pantilie --- plutus-tx-plugin/plutus-tx-plugin.cabal | 1 + plutus-tx-plugin/test/Spec.hs | 4 +++- plutus-tx/src/PlutusTx/These.hs | 6 +++++- 3 files changed, 9 insertions(+), 2 deletions(-) diff --git a/plutus-tx-plugin/plutus-tx-plugin.cabal b/plutus-tx-plugin/plutus-tx-plugin.cabal index 97e0fc41834..ba2b9aef372 100644 --- a/plutus-tx-plugin/plutus-tx-plugin.cabal +++ b/plutus-tx-plugin/plutus-tx-plugin.cabal @@ -128,6 +128,7 @@ test-suite plutus-tx-plugin-tests other-modules: AsData.Budget.Spec AsData.Budget.Types + AssocList.Spec Blueprint.Tests Blueprint.Tests.Lib Blueprint.Tests.Lib.AsData.Blueprint diff --git a/plutus-tx-plugin/test/Spec.hs b/plutus-tx-plugin/test/Spec.hs index 5847ced49e5..b57eede5322 100644 --- a/plutus-tx-plugin/test/Spec.hs +++ b/plutus-tx-plugin/test/Spec.hs @@ -1,6 +1,7 @@ module Main (main) where import AsData.Budget.Spec qualified as AsData.Budget +import AssocList.Spec qualified as AssocList import Blueprint.Tests qualified import Budget.Spec qualified as Budget import IntegerLiterals.NoStrict.NegativeLiterals.Spec qualified @@ -20,7 +21,7 @@ import TH.Spec qualified as TH import Unicode.Spec qualified as Unicode main :: IO () -main = defaultMain $ runTestNestedIn ["test"] tests +main = defaultMain $ testGroup "" [runTestNestedIn ["test"] tests, AssocList.propertyTests] tests :: TestNested tests = @@ -42,4 +43,5 @@ tests = , Strictness.tests , Blueprint.Tests.goldenTests , pure Unicode.tests + , AssocList.goldenTests ] diff --git a/plutus-tx/src/PlutusTx/These.hs b/plutus-tx/src/PlutusTx/These.hs index 4ec6742e344..7a22822b136 100644 --- a/plutus-tx/src/PlutusTx/These.hs +++ b/plutus-tx/src/PlutusTx/These.hs @@ -1,15 +1,19 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} +{-# LANGUAGE DerivingStrategies #-} module PlutusTx.These( These(..) , these , theseWithDefault ) where +import Prelude + -- | A 'These' @a@ @b@ is either an @a@, or a @b@ or an @a@ and a @b@. -- Plutus version of 'Data.These'. data These a b = This a | That b | These a b + deriving stock (Show, Eq, Ord) {-# INLINABLE theseWithDefault #-} -- | Consume a 'These a b' value. From 360474d8ddad1f092f84c3b15d368fa42c5f244c Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Mon, 29 Apr 2024 14:12:49 +0300 Subject: [PATCH 03/41] Fix AssocList union Signed-off-by: Ana Pantilie --- plutus-tx-plugin/test/AssocList/Spec.hs | 2 +- plutus-tx/src/PlutusTx/Data/AssocList.hs | 108 +++++++++++++---------- 2 files changed, 62 insertions(+), 48 deletions(-) diff --git a/plutus-tx-plugin/test/AssocList/Spec.hs b/plutus-tx-plugin/test/AssocList/Spec.hs index 479915eef3a..f57fe184e7f 100644 --- a/plutus-tx-plugin/test/AssocList/Spec.hs +++ b/plutus-tx-plugin/test/AssocList/Spec.hs @@ -362,7 +362,7 @@ unionSpec = property $ do let assocMap1 = semanticsToAssocMap assocListS1 assocMap2 = semanticsToAssocMap assocListS2 assocList1 = semanticsToAssocList assocListS1 - assocList2 = semanticsToAssocList assocListS1 + assocList2 = semanticsToAssocList assocListS2 unionS assocListS1 assocListS2 ~~ AssocMap.union assocMap1 assocMap2 unionS assocListS1 assocListS2 ~~ Data.AssocList.union assocList1 assocList2 diff --git a/plutus-tx/src/PlutusTx/Data/AssocList.hs b/plutus-tx/src/PlutusTx/Data/AssocList.hs index a1e6733723a..74c8fe5f1d0 100644 --- a/plutus-tx/src/PlutusTx/Data/AssocList.hs +++ b/plutus-tx/src/PlutusTx/Data/AssocList.hs @@ -107,10 +107,13 @@ member' k = go else go tl ) -{-# INLINEABLE insert #-} -insert :: forall k a. (P.ToData k, P.ToData a) => k -> a -> AssocList k a -> AssocList k a -insert (P.toBuiltinData -> k) (P.toBuiltinData -> a) m = - unsafeFromBuiltinList (go (toBuiltinList m)) +{-# INLINEABLE insert' #-} +insert' + :: BuiltinData + -> BuiltinData + -> BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) + -> BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) +insert' (P.toBuiltinData -> k) (P.toBuiltinData -> a) = go where go :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> @@ -126,6 +129,11 @@ insert (P.toBuiltinData -> k) (P.toBuiltinData -> a) m = else BI.mkCons hd (go tl) ) +{-# INLINEABLE insert #-} +insert :: forall k a. (P.ToData k, P.ToData a) => k -> a -> AssocList k a -> AssocList k a +insert (P.toBuiltinData -> k) (P.toBuiltinData -> a) m = + unsafeFromBuiltinList (insert' k a (toBuiltinList m)) + {-# INLINEABLE delete #-} delete :: forall k a. (P.ToData k) => k -> AssocList k a -> AssocList k a delete (P.toBuiltinData -> k) m = unsafeFromBuiltinList (go (toBuiltinList m)) @@ -263,51 +271,57 @@ union :: AssocList k (These a b) union (toBuiltinList -> ls) (toBuiltinList -> rs) = unsafeFromBuiltinList res where - ls' :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) - ls' = go ls - where - go xs = - P.matchList - xs - nil - ( \hd tl -> - let k' = BI.fst hd - v' = BI.snd hd - v'' = case lookup' k' rs of - Just r -> - P.toBuiltinData - ( These - (P.unsafeFromBuiltinData v') - (P.unsafeFromBuiltinData r) :: - These a b - ) - Nothing -> P.toBuiltinData (This (P.unsafeFromBuiltinData v') :: These a b) - in BI.mkCons (BI.mkPairData k' v'') (go tl) - ) + goLeft xs = + P.matchList + xs + nil + ( \hd tl -> + let k = BI.fst hd + v = BI.snd hd + v' = case lookup' k rs of + Just r -> + P.toBuiltinData + ( These + (P.unsafeFromBuiltinData v) + (P.unsafeFromBuiltinData r) + :: These a b + ) + Nothing -> + P.toBuiltinData (This (P.unsafeFromBuiltinData v) :: These a b) + in BI.mkCons (BI.mkPairData k v') (goLeft tl) + ) - rs' :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) - rs' = go rs - where - go xs = - P.matchList - xs - nil - ( \hd tl -> - let k' = BI.fst hd - tl' = go tl - in if member' k' ls - then tl' - else BI.mkCons hd tl' - ) + goRight xs = + P.matchList + xs + nil + ( \hd tl -> + let k = BI.fst hd + v = BI.snd hd + v' = case lookup' k ls of + Just r -> + P.toBuiltinData + ( These + (P.unsafeFromBuiltinData v) + (P.unsafeFromBuiltinData r) + :: These a b + ) + Nothing -> + P.toBuiltinData (That (P.unsafeFromBuiltinData v) :: These a b) + in BI.mkCons (BI.mkPairData k v') (goRight tl) + ) - res :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) - res = go rs' ls' - where - go acc xs = - P.matchList - xs - acc - (\hd -> go (BI.mkCons hd acc)) + res = goLeft ls `safeAppend` goRight rs + + safeAppend xs1 xs2 = + P.matchList + xs1 + xs2 + ( \hd tl -> + let k = BI.fst hd + v = BI.snd hd + in insert' k v (safeAppend tl xs2) + ) -- | Combine two 'AssocList's with the given combination function. unionWith :: From a730d6b9ce7b327ab07af5db1582db7bf9e03858 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Mon, 29 Apr 2024 14:21:30 +0300 Subject: [PATCH 04/41] Add unionWith property test Signed-off-by: Ana Pantilie --- plutus-tx-plugin/test/AssocList/Spec.hs | 22 ++++++++++++++++++++++ plutus-tx/src/PlutusTx/Data/AssocList.hs | 10 +++++----- 2 files changed, 27 insertions(+), 5 deletions(-) diff --git a/plutus-tx-plugin/test/AssocList/Spec.hs b/plutus-tx-plugin/test/AssocList/Spec.hs index f57fe184e7f..dce8dd3edb3 100644 --- a/plutus-tx-plugin/test/AssocList/Spec.hs +++ b/plutus-tx-plugin/test/AssocList/Spec.hs @@ -71,6 +71,7 @@ propertyTests = , testProperty "noDuplicateKeys" noDuplicateKeysSpec , testProperty "delete" deleteSpec , testProperty "union" unionSpec + , testProperty "unionWith" unionWithSpec ] map1 :: @@ -229,6 +230,16 @@ unionS (AssocListS ls) (AssocListS rs) = in AssocListS (ls' ++ rs'') +unionWithS + :: (Integer -> Integer -> Integer) + -> AssocListS Integer Integer + -> AssocListS Integer Integer + -> AssocListS Integer Integer +unionWithS merge (AssocListS ls) (AssocListS rs) = + AssocListS + . Map.toList + $ Map.unionWith merge (Map.fromList ls) (Map.fromList rs) + class Equivalence l where (~~) :: ( MonadTest m @@ -366,3 +377,14 @@ unionSpec = property $ do unionS assocListS1 assocListS2 ~~ AssocMap.union assocMap1 assocMap2 unionS assocListS1 assocListS2 ~~ Data.AssocList.union assocList1 assocList2 +unionWithSpec :: Property +unionWithSpec = property $ do + assocListS1 <- forAll genAssocListS + assocListS2 <- forAll genAssocListS + let assocMap1 = semanticsToAssocMap assocListS1 + assocMap2 = semanticsToAssocMap assocListS2 + assocList1 = semanticsToAssocList assocListS1 + assocList2 = semanticsToAssocList assocListS2 + merge i1 _ = i1 + unionWithS merge assocListS1 assocListS2 ~~ AssocMap.unionWith merge assocMap1 assocMap2 + unionWithS merge assocListS1 assocListS2 ~~ Data.AssocList.unionWith merge assocList1 assocList2 diff --git a/plutus-tx/src/PlutusTx/Data/AssocList.hs b/plutus-tx/src/PlutusTx/Data/AssocList.hs index 74c8fe5f1d0..14bb613ba83 100644 --- a/plutus-tx/src/PlutusTx/Data/AssocList.hs +++ b/plutus-tx/src/PlutusTx/Data/AssocList.hs @@ -107,6 +107,11 @@ member' k = go else go tl ) +{-# INLINEABLE insert #-} +insert :: forall k a. (P.ToData k, P.ToData a) => k -> a -> AssocList k a -> AssocList k a +insert (P.toBuiltinData -> k) (P.toBuiltinData -> a) m = + unsafeFromBuiltinList $ insert' k a (toBuiltinList m) + {-# INLINEABLE insert' #-} insert' :: BuiltinData @@ -129,11 +134,6 @@ insert' (P.toBuiltinData -> k) (P.toBuiltinData -> a) = go else BI.mkCons hd (go tl) ) -{-# INLINEABLE insert #-} -insert :: forall k a. (P.ToData k, P.ToData a) => k -> a -> AssocList k a -> AssocList k a -insert (P.toBuiltinData -> k) (P.toBuiltinData -> a) m = - unsafeFromBuiltinList (insert' k a (toBuiltinList m)) - {-# INLINEABLE delete #-} delete :: forall k a. (P.ToData k) => k -> AssocList k a -> AssocList k a delete (P.toBuiltinData -> k) m = unsafeFromBuiltinList (go (toBuiltinList m)) From 0d75e65d1e180c831fa4c4ef46cf2d4304ab16fb Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Mon, 29 Apr 2024 14:52:47 +0300 Subject: [PATCH 05/41] Clean-up Signed-off-by: Ana Pantilie --- plutus-tx-plugin/test/AssocList/Spec.hs | 8 ++------ plutus-tx/src/PlutusTx/Data/AssocList.hs | 7 +++---- 2 files changed, 5 insertions(+), 10 deletions(-) diff --git a/plutus-tx-plugin/test/AssocList/Spec.hs b/plutus-tx-plugin/test/AssocList/Spec.hs index dce8dd3edb3..a6b5f920689 100644 --- a/plutus-tx-plugin/test/AssocList/Spec.hs +++ b/plutus-tx-plugin/test/AssocList/Spec.hs @@ -16,13 +16,9 @@ module AssocList.Spec where import Test.Tasty.Extras -import Control.Monad (when) import Data.List (nubBy, sort) -import Data.Map.Strict qualified as HMap import Data.Map.Strict qualified as Map -import Debug.Trace (traceM) -import Hedgehog (Gen, MonadTest, Property, Range, assert, forAll, property, (===)) -import Hedgehog.Gen (discard) +import Hedgehog (Gen, MonadTest, Property, Range, forAll, property, (===)) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range import PlutusTx.AssocMap qualified as AssocMap @@ -130,7 +126,7 @@ map2 = ) newtype AssocListS k v = AssocListS [(k, v)] - deriving (Show, Eq) + deriving stock (Show, Eq) nullS :: AssocListS k v -> Bool nullS (AssocListS l) = null l diff --git a/plutus-tx/src/PlutusTx/Data/AssocList.hs b/plutus-tx/src/PlutusTx/Data/AssocList.hs index 14bb613ba83..cc5dadbcda4 100644 --- a/plutus-tx/src/PlutusTx/Data/AssocList.hs +++ b/plutus-tx/src/PlutusTx/Data/AssocList.hs @@ -34,17 +34,16 @@ import PlutusTx.These import Prelude qualified as Haskell --- TODO: fix docs -{- | An associative map implementation backed by `P.BuiltinData`. +{- | A list associating keys and values backed by `P.BuiltinData`. -This map implementation has the following characteristics: +This implementation has the following characteristics: * The `P.toBuiltinData` and `P.unsafeFromBuiltinData` operations are no-op. * Other operations are slower than @PlutusTx.AssocMap.Map@, although equality checks on keys can be faster due to `P.equalsData`. * Many operations involve converting the keys and/or values to/from `P.BuiltinData`. -Therefore this map implementation is likely a better choice than @PlutusTx.AssocMap.Map@ +Therefore this implementation is likely a better choice than @PlutusTx.AssocMap.Map@ if it is part of a data type defined using @asData@, and the key and value types have efficient `P.toBuiltinData` and `P.unsafeFromBuiltinData` operations (e.g., they are primitive types or types defined using @asData@). From ec6bccd588239fa2f7784731f9c6f262ca1efaa4 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Mon, 29 Apr 2024 15:11:12 +0300 Subject: [PATCH 06/41] Fix performance bug Signed-off-by: Ana Pantilie --- plutus-tx/src/PlutusTx/AssocMap.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/plutus-tx/src/PlutusTx/AssocMap.hs b/plutus-tx/src/PlutusTx/AssocMap.hs index f49d7c8f940..d5c6c800150 100644 --- a/plutus-tx/src/PlutusTx/AssocMap.hs +++ b/plutus-tx/src/PlutusTx/AssocMap.hs @@ -235,7 +235,6 @@ delete key (Map ls) = Map (go ls) keys :: Map k v -> [k] keys (Map xs) = P.fmap (\(k, _ :: v) -> k) xs -{-# INLINEABLE union #-} -- | Combine two 'Map's. Keeps both values on key collisions. -- Note that well-formedness is only preserved if the two input maps -- are also well-formed. From 634bea662b12b4d8a094c9c243bedb79753c44eb Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Mon, 29 Apr 2024 15:11:27 +0300 Subject: [PATCH 07/41] Add golden files for new tests Signed-off-by: Ana Pantilie --- .../test/Budget/9.6/map1-budget.budget.golden | 2 + .../test/Budget/9.6/map1.eval.golden | 8 + .../test/Budget/9.6/map1.pir.golden | 412 ++++++++++++++++++ .../test/Budget/9.6/map1.uplc.golden | 412 ++++++++++++++++++ .../test/Budget/9.6/map2-budget.budget.golden | 2 + .../test/Budget/9.6/map2.eval.golden | 27 ++ .../test/Budget/9.6/map2.pir.golden | 341 +++++++++++++++ .../test/Budget/9.6/map2.uplc.golden | 273 ++++++++++++ 8 files changed, 1477 insertions(+) create mode 100644 plutus-tx-plugin/test/Budget/9.6/map1-budget.budget.golden create mode 100644 plutus-tx-plugin/test/Budget/9.6/map1.eval.golden create mode 100644 plutus-tx-plugin/test/Budget/9.6/map1.pir.golden create mode 100644 plutus-tx-plugin/test/Budget/9.6/map1.uplc.golden create mode 100644 plutus-tx-plugin/test/Budget/9.6/map2-budget.budget.golden create mode 100644 plutus-tx-plugin/test/Budget/9.6/map2.eval.golden create mode 100644 plutus-tx-plugin/test/Budget/9.6/map2.pir.golden create mode 100644 plutus-tx-plugin/test/Budget/9.6/map2.uplc.golden diff --git a/plutus-tx-plugin/test/Budget/9.6/map1-budget.budget.golden b/plutus-tx-plugin/test/Budget/9.6/map1-budget.budget.golden new file mode 100644 index 00000000000..eac1529d67e --- /dev/null +++ b/plutus-tx-plugin/test/Budget/9.6/map1-budget.budget.golden @@ -0,0 +1,2 @@ +({cpu: 449378976 +| mem: 1091917}) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Budget/9.6/map1.eval.golden b/plutus-tx-plugin/test/Budget/9.6/map1.eval.golden new file mode 100644 index 00000000000..2976eddf5c9 --- /dev/null +++ b/plutus-tx-plugin/test/Budget/9.6/map1.eval.golden @@ -0,0 +1,8 @@ +(constr + 0 + (constr 0 (con bytestring #30)) + (constr 0 (con bytestring #35)) + (constr 0 (con bytestring #3130)) + (constr 1) + (constr 1) +) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Budget/9.6/map1.pir.golden b/plutus-tx-plugin/test/Budget/9.6/map1.pir.golden new file mode 100644 index 00000000000..745c72b8796 --- /dev/null +++ b/plutus-tx-plugin/test/Budget/9.6/map1.pir.golden @@ -0,0 +1,412 @@ +letrec + data (List :: * -> *) a | List_match where + Nil : List a + Cons : a -> List a -> List a +in +letrec + !`$fEnumBool_$cenumFromTo` : integer -> integer -> List integer + = \(x : integer) (lim : integer) -> + ifThenElse + {all dead. List integer} + (lessThanEqualsInteger x lim) + (/\dead -> + Cons {integer} x (`$fEnumBool_$cenumFromTo` (addInteger 1 x) lim)) + (/\dead -> Nil {integer}) + {all dead. dead} +in +letrec + !go : List integer -> integer -> List integer + = \(acc : List integer) (n : integer) -> + let + !x : integer = quotientInteger n 10 + in + ifThenElse + {all dead. List integer} + (equalsInteger 0 x) + (/\dead -> Cons {integer} (remainderInteger n 10) acc) + (/\dead -> go (Cons {integer} (remainderInteger n 10) acc) x) + {all dead. dead} +in +letrec + !go : + List integer -> List string -> List string + = \(ds : List integer) -> + List_match + {integer} + ds + {all dead. List string -> List string} + (/\dead -> \(x : List string) -> x) + (\(x : integer) + (xs : List integer) -> + /\dead -> + let + !acc : List string -> List string = go xs + in + \(eta : List string) -> + Cons + {string} + (ifThenElse + {all dead. string} + (equalsInteger 0 x) + (/\dead -> "0") + (/\dead -> + ifThenElse + {all dead. string} + (equalsInteger 1 x) + (/\dead -> "1") + (/\dead -> + ifThenElse + {all dead. string} + (equalsInteger 2 x) + (/\dead -> "2") + (/\dead -> + ifThenElse + {all dead. string} + (equalsInteger 3 x) + (/\dead -> "3") + (/\dead -> + ifThenElse + {all dead. string} + (equalsInteger 4 x) + (/\dead -> "4") + (/\dead -> + ifThenElse + {all dead. string} + (equalsInteger 5 x) + (/\dead -> "5") + (/\dead -> + ifThenElse + {all dead. string} + (equalsInteger 6 x) + (/\dead -> "6") + (/\dead -> + ifThenElse + {all dead. string} + (equalsInteger 7 x) + (/\dead -> "7") + (/\dead -> + ifThenElse + {all dead. string} + (equalsInteger + 8 + x) + (/\dead -> "8") + (/\dead -> + ifThenElse + {string} + (equalsInteger + 9 + x) + "9" + "") + {all dead. dead}) + {all dead. dead}) + {all dead. dead}) + {all dead. dead}) + {all dead. dead}) + {all dead. dead}) + {all dead. dead}) + {all dead. dead}) + {all dead. dead}) + (acc eta)) + {all dead. dead} +in +letrec + !`$fShowBuiltinByteString_$cshowsPrec` : + integer -> integer -> List string -> List string + = \(p : integer) (n : integer) -> + ifThenElse + {all dead. List string -> List string} + (lessThanInteger n 0) + (/\dead -> + \(eta : List string) -> + Cons + {string} + "-" + (`$fShowBuiltinByteString_$cshowsPrec` + p + (subtractInteger 0 n) + eta)) + (/\dead -> go (go (Nil {integer}) n)) + {all dead. dead} +in +let + data (Tuple5 :: * -> * -> * -> * -> * -> *) a b c d e | Tuple5_match where + Tuple5 : a -> b -> c -> d -> e -> Tuple5 a b c d e + data (Tuple2 :: * -> * -> *) a b | Tuple2_match where + Tuple2 : a -> b -> Tuple2 a b +in +letrec + !go : all a. integer -> List a -> Tuple2 (List a) (List a) + = /\a -> + \(ds : integer) (ds : List a) -> + List_match + {a} + ds + {all dead. Tuple2 (List a) (List a)} + (/\dead -> Tuple2 {List a} {List a} (Nil {a}) (Nil {a})) + (\(y : a) (ys : List a) -> + /\dead -> + ifThenElse + {all dead. Tuple2 (List a) (List a)} + (equalsInteger 1 ds) + (/\dead -> + Tuple2 + {List a} + {List a} + ((let + a = List a + in + \(c : a -> a -> a) (n : a) -> c y n) + (\(ds : a) (ds : List a) -> Cons {a} ds ds) + (Nil {a})) + ys) + (/\dead -> + Tuple2_match + {List a} + {List a} + (go {a} (subtractInteger ds 1) ys) + {Tuple2 (List a) (List a)} + (\(zs : List a) (ws : List a) -> + Tuple2 {List a} {List a} (Cons {a} y zs) ws)) + {all dead. dead}) + {all dead. dead} +in +letrec + !go : List string -> integer + = \(ds : List string) -> + List_match + {string} + ds + {all dead. integer} + (/\dead -> 0) + (\(x : string) (xs : List string) -> /\dead -> addInteger 1 (go xs)) + {all dead. dead} +in +letrec + !concatBuiltinStrings : List string -> string + = \(ds : List string) -> + List_match + {string} + ds + {string} + "" + (\(x : string) (ds : List string) -> + List_match + {string} + ds + {all dead. string} + (/\dead -> x) + (\(ipv : string) (ipv : List string) -> + /\dead -> + Tuple2_match + {List string} + {List string} + (let + !n : integer = divideInteger (go ds) 2 + in + ifThenElse + {all dead. Tuple2 (List string) (List string)} + (lessThanEqualsInteger n 0) + (/\dead -> + Tuple2 {List string} {List string} (Nil {string}) ds) + (/\dead -> go {string} n ds) + {all dead. dead}) + {string} + (\(ipv : List string) (ipv : List string) -> + appendString + (concatBuiltinStrings ipv) + (concatBuiltinStrings ipv))) + {all dead. dead}) +in +let + data (Maybe :: * -> *) a | Maybe_match where + Just : a -> Maybe a + Nothing : Maybe a + data Unit | Unit_match where + Unit : Unit + !lookup : + all k a. + (\a -> a -> data) k -> + (\a -> data -> a) a -> + k -> + (\k a -> data) k a -> + Maybe a + = /\k a -> + \(`$dToData` : (\a -> a -> data) k) + (`$dUnsafeFromData` : (\a -> data -> a) a) + (ds : k) + (m : (\k a -> data) k a) -> + Maybe_match + {data} + (let + !k : data = `$dToData` ds + 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 + !tl : list (pair data data) + = tailList {pair data data} xs + in + ifThenElse + {all dead. Maybe data} + (equalsData k (fstPair {data} {data} hd)) + (/\dead -> Just {data} (sndPair {data} {data} hd)) + (/\dead -> go tl) + {all dead. dead}) + Unit + in + let + !eta : list (pair data data) = unMapData m + in + go eta) + {all dead. Maybe a} + (\(a : data) -> /\dead -> Just {a} (`$dUnsafeFromData` a)) + (/\dead -> Nothing {a}) + {all dead. dead} + !matchList : all a r. list a -> r -> (a -> list a -> r) -> r + = /\a r -> + \(l : list a) (nilCase : r) (consCase : a -> list a -> r) -> + chooseList + {a} + {Unit -> r} + l + (\(ds : Unit) -> nilCase) + (\(ds : Unit) -> consCase (headList {a} l) (tailList {a} l)) + Unit + data Bool | Bool_match where + True : Bool + False : Bool +in +\(n : integer) -> + let + !nt : data + = (let + b = (\k a -> data) integer bytestring + in + \(k : integer -> b -> b) (z : b) -> + letrec + !go : List integer -> b + = \(ds : List integer) -> + List_match + {integer} + ds + {all dead. b} + (/\dead -> z) + (\(y : integer) (ys : List integer) -> + /\dead -> k y (go ys)) + {all dead. dead} + in + \(eta : List integer) -> go eta) + (\(i : integer) -> + let + !ds : integer = addInteger n i + !ds : bytestring + = encodeUtf8 + (concatBuiltinStrings + (`$fShowBuiltinByteString_$cshowsPrec` + 0 + i + (Nil {string}))) + in + \(m : (\k a -> data) integer bytestring) -> + mapData + (let + !ds : data = iData ds + !ds : data = bData ds + in + letrec + !go : list (pair data data) -> list (pair data data) + = \(xs : list (pair data data)) -> + matchList + {pair data data} + {list (pair data data)} + xs + (mkCons {pair data data} (mkPairData ds ds) []) + (\(hd : pair data data) + (tl : list (pair data data)) -> + ifThenElse + {all dead. list (pair data data)} + (equalsData ds (fstPair {data} {data} hd)) + (/\dead -> + mkCons + {pair data data} + (mkPairData ds ds) + tl) + (/\dead -> mkCons {pair data data} hd (go tl)) + {all dead. dead}) + in + let + !eta : list (pair data data) = unMapData m + in + go eta)) + (mapData (mkCons {pair data data} (mkPairData (iData n) (B #30)) [])) + (`$fEnumBool_$cenumFromTo` 1 10) + !nt : data + = let + !ds : integer = addInteger 5 n + in + letrec + !go : list (pair data data) -> list (pair data data) + = \(xs : list (pair data data)) -> + matchList + {pair data data} + {list (pair data data)} + xs + [] + (\(hd : pair data data) (tl : list (pair data data)) -> + let + !k' : data = fstPair {data} {data} hd + in + ifThenElse + {all dead. list (pair data data)} + (equalsData (iData ds) k') + (/\dead -> tl) + (/\dead -> mkCons {pair data data} hd (go tl)) + {all dead. dead}) + in + mapData (go (unMapData nt)) + in + Tuple5 + {Maybe bytestring} + {Maybe bytestring} + {Maybe bytestring} + {Maybe bytestring} + {Maybe bytestring} + (lookup {integer} {bytestring} (\(i : integer) -> iData i) unBData n nt) + (lookup + {integer} + {bytestring} + (\(i : integer) -> iData i) + unBData + (addInteger 5 n) + nt) + (lookup + {integer} + {bytestring} + (\(i : integer) -> iData i) + unBData + (addInteger 10 n) + nt) + (lookup + {integer} + {bytestring} + (\(i : integer) -> iData i) + unBData + (addInteger 20 n) + nt) + (lookup + {integer} + {bytestring} + (\(i : integer) -> iData i) + unBData + (addInteger 5 n) + nt) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Budget/9.6/map1.uplc.golden b/plutus-tx-plugin/test/Budget/9.6/map1.uplc.golden new file mode 100644 index 00000000000..4d017d4f9aa --- /dev/null +++ b/plutus-tx-plugin/test/Budget/9.6/map1.uplc.golden @@ -0,0 +1,412 @@ +program + 1.1.0 + ((\fix1 -> + (\`$fEnumBool_$cenumFromTo` -> + (\go -> + (\go -> + (\`$fShowBuiltinByteString_$cshowsPrec` -> + (\go -> + (\go -> + (\concatBuiltinStrings + n -> + (\matchList -> + (\nt -> + (\cse -> + (\nt -> + (\lookup -> + constr 0 + [ (lookup + (\i -> iData i) + unBData + n + nt) + , (lookup + (\i -> iData i) + unBData + cse + nt) + , (lookup + (\i -> iData i) + unBData + (addInteger 10 n) + nt) + , (lookup + (\i -> iData i) + unBData + (addInteger 20 n) + nt) + , (lookup + (\i -> iData i) + unBData + cse + nt) ]) + (\`$dToData` + `$dUnsafeFromData` + ds + m -> + force + (case + ((\k -> + fix1 + (\go + xs -> + force + (force chooseList) + xs + (\ds -> constr 1 []) + (\ds -> + (\hd -> + (\tl -> + force + (force + ifThenElse + (equalsData + k + (force + (force + fstPair) + hd)) + (delay + (constr 0 + [ (force + (force + sndPair) + hd) ])) + (delay + (go + tl)))) + (force + tailList + xs)) + (force headList + xs)) + (constr 0 [])) + (unMapData m)) + (`$dToData` ds)) + [ (\a -> + delay + (constr 0 + [ (`$dUnsafeFromData` + a) ])) + , (delay (constr 1 [])) ]))) + (mapData + (fix1 + (\go xs -> + matchList + xs + [] + (\hd tl -> + (\k' -> + force + (force ifThenElse + (equalsData + (iData cse) + k') + (delay tl) + (delay + (force mkCons + hd + (go tl))))) + (force (force fstPair) + hd))) + (unMapData nt)))) + (addInteger 5 n)) + ((\z -> + (\go eta -> + go eta) + (fix1 + (\go + ds -> + force + (case + ds + [ (delay z) + , (\y + ys -> + delay + ((\ds -> + (\ds + m -> + mapData + ((\ds -> + (\ds -> + fix1 + (\go + xs -> + (\cse -> + (\cse -> + matchList + xs + (cse + [ ]) + (\hd + tl -> + force + (force + ifThenElse + (equalsData + ds + (force + (force + fstPair) + hd)) + (delay + (cse + tl)) + (delay + (force + mkCons + hd + (go + tl)))))) + (force + mkCons + cse)) + (mkPairData + ds + ds)) + (unMapData + m)) + (bData + ds)) + (iData ds))) + (encodeUtf8 + (concatBuiltinStrings + (`$fShowBuiltinByteString_$cshowsPrec` + 0 + y + (constr 0 + [ ]))))) + (addInteger n y) + (go ys))) ])))) + (mapData + (force mkCons + (mkPairData (iData n) (B #30)) + [])) + (`$fEnumBool_$cenumFromTo` 1 10))) + (\l nilCase consCase -> + force (force chooseList) + l + (\ds -> nilCase) + (\ds -> + consCase + (force headList l) + (force tailList l)) + (constr 0 []))) + (fix1 + (\concatBuiltinStrings + ds -> + case + ds + [ "" + , (\x + ds -> + force + (case + ds + [ (delay x) + , (\ipv + ipv -> + delay + (case + ((\n -> + force + (force + ifThenElse + (lessThanEqualsInteger + n + 0) + (delay + (constr 0 + [ (constr 0 + []) + , ds ])) + (delay + (force go + n + ds)))) + (divideInteger + (go ds) + 2)) + [ (\ipv + ipv -> + appendString + (concatBuiltinStrings + ipv) + (concatBuiltinStrings + ipv)) ])) ])) ]))) + (fix1 + (\go ds -> + force + (case + ds + [ (delay 0) + , (\x xs -> + delay (addInteger 1 (go xs))) ])))) + (fix1 + (\go + arg -> + delay + (\ds + ds -> + force + (case + ds + [ (delay + (constr 0 + [(constr 0 []), (constr 0 [])])) + , (\y + ys -> + delay + (force + (force + ifThenElse + (equalsInteger 1 ds) + (delay + (constr 0 + [ (constr 1 + [y, (constr 0 [])]) + , ys ])) + (delay + (case + (force + (go (delay (\x -> x))) + (subtractInteger ds 1) + ys) + [ (\zs + ws -> + constr 0 + [ (constr 1 + [y, zs]) + , ws ]) ]))))) ]))) + (delay (\x -> x)))) + (fix1 + (\`$fShowBuiltinByteString_$cshowsPrec` p n -> + force + (force ifThenElse + (lessThanInteger n 0) + (delay + (\eta -> + constr 1 + [ "-" + , (`$fShowBuiltinByteString_$cshowsPrec` + p + (subtractInteger 0 n) + eta) ])) + (delay (go (go (constr 0 []) n))))))) + (fix1 + (\go + ds -> + force + (case + ds + [ (delay (\x -> x)) + , (\x + xs -> + delay + ((\acc + eta -> + constr 1 + [ (force + (force + ifThenElse + (equalsInteger 0 x) + (delay "0") + (delay + (force + (force + ifThenElse + (equalsInteger 1 x) + (delay "1") + (delay + (force + (force + ifThenElse + (equalsInteger + 2 + x) + (delay "2") + (delay + (force + (force + ifThenElse + (equalsInteger + 3 + x) + (delay + "3") + (delay + (force + (force + ifThenElse + (equalsInteger + 4 + x) + (delay + "4") + (delay + (force + (force + ifThenElse + (equalsInteger + 5 + x) + (delay + "5") + (delay + (force + (force + ifThenElse + (equalsInteger + 6 + x) + (delay + "6") + (delay + (force + (force + ifThenElse + (equalsInteger + 7 + x) + (delay + "7") + (delay + (force + (force + ifThenElse + (equalsInteger + 8 + x) + (delay + "8") + (delay + (force + ifThenElse + (equalsInteger + 9 + x) + "9" + "")))))))))))))))))))))))))))) + , (acc eta) ]) + (go xs))) ])))) + (fix1 + (\go acc n -> + (\x -> + force + (force ifThenElse + (equalsInteger 0 x) + (delay (constr 1 [(remainderInteger n 10), acc])) + (delay + (go (constr 1 [(remainderInteger n 10), acc]) x)))) + (quotientInteger n 10)))) + (fix1 + (\`$fEnumBool_$cenumFromTo` x lim -> + force + (force ifThenElse + (lessThanEqualsInteger x lim) + (delay + (constr 1 + [x, (`$fEnumBool_$cenumFromTo` (addInteger 1 x) lim)])) + (delay (constr 0 [])))))) + (\f -> (\s -> s s) (\s x -> f (s s) x))) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Budget/9.6/map2-budget.budget.golden b/plutus-tx-plugin/test/Budget/9.6/map2-budget.budget.golden new file mode 100644 index 00000000000..6215d03406e --- /dev/null +++ b/plutus-tx-plugin/test/Budget/9.6/map2-budget.budget.golden @@ -0,0 +1,2 @@ +({cpu: 165082681 +| mem: 433602}) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Budget/9.6/map2.eval.golden b/plutus-tx-plugin/test/Budget/9.6/map2.eval.golden new file mode 100644 index 00000000000..e8e3b12565c --- /dev/null +++ b/plutus-tx-plugin/test/Budget/9.6/map2.eval.golden @@ -0,0 +1,27 @@ +(constr + 1 + (constr 0 (con integer 105) (con string "five")) + (constr + 1 + (constr 0 (con integer 104) (con string "fourFOUR")) + (constr + 1 + (constr 0 (con integer 103) (con string "threeTHREE")) + (constr + 1 + (constr 0 (con integer 102) (con string "two")) + (constr + 1 + (constr 0 (con integer 101) (con string "one")) + (constr + 1 + (constr 0 (con integer 106) (con string "SIX")) + (constr + 1 (constr 0 (con integer 107) (con string "SEVEN")) (constr 0) + ) + ) + ) + ) + ) + ) +) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Budget/9.6/map2.pir.golden b/plutus-tx-plugin/test/Budget/9.6/map2.pir.golden new file mode 100644 index 00000000000..4c07383cc2b --- /dev/null +++ b/plutus-tx-plugin/test/Budget/9.6/map2.pir.golden @@ -0,0 +1,341 @@ +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 integer bytestring) + = \(xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> List (Tuple2 integer bytestring)} + xs + (\(ds : Unit) -> Nil {Tuple2 integer bytestring}) + (\(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 integer bytestring} + (Tuple2 + {integer} + {bytestring} + (unIData (fstPair {data} {data} hd)) + (unBData (sndPair {data} {data} hd))) + (go tl)) + Unit +in +letrec + !go : list (pair data data) -> list (pair data data) -> list (pair data data) + = \(acc : list (pair data data)) (xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> list (pair data data)} + xs + (\(ds : Unit) -> acc) + (\(ds : Unit) -> + go + (mkCons {pair data data} (headList {pair data data} xs) acc) + (tailList {pair data data} xs)) + Unit +in +let + data (Maybe :: * -> *) a | Maybe_match where + Just : a -> Maybe a + Nothing : Maybe a + !matchList : all a r. list a -> r -> (a -> list a -> r) -> r + = /\a r -> + \(l : list a) (nilCase : r) (consCase : a -> list a -> r) -> + chooseList + {a} + {Unit -> r} + l + (\(ds : Unit) -> nilCase) + (\(ds : Unit) -> consCase (headList {a} l) (tailList {a} l)) + Unit + data Bool | Bool_match where + True : Bool + False : Bool +in +letrec + !`$fToBuiltinListBuiltinList_$ctoBuiltin` : + List (Tuple2 data data) -> list (pair data data) + = \(ds : List (Tuple2 data data)) -> + List_match + {Tuple2 data data} + ds + {all dead. list (pair data data)} + (/\dead -> []) + (\(d : Tuple2 data data) (ds : List (Tuple2 data data)) -> + /\dead -> + mkCons + {pair data data} + (Tuple2_match + {data} + {data} + d + {pair data data} + (\(d : data) (d : data) -> mkPairData d d)) + (`$fToBuiltinListBuiltinList_$ctoBuiltin` ds)) + {all dead. dead} +in +let + !unsafeFromList : + all k a. + (\a -> a -> data) k -> + (\a -> a -> data) a -> + List (Tuple2 k a) -> + (\k a -> data) k a + = /\k a -> + \(`$dToData` : (\a -> a -> data) k) + (`$dToData` : (\a -> a -> data) a) -> + letrec + !go : List (Tuple2 k a) -> List (Tuple2 data data) + = \(ds : List (Tuple2 k a)) -> + List_match + {Tuple2 k a} + ds + {all dead. List (Tuple2 data data)} + (/\dead -> Nil {Tuple2 data data}) + (\(x : Tuple2 k a) (xs : List (Tuple2 k a)) -> + /\dead -> + Cons + {Tuple2 data data} + (Tuple2_match + {k} + {a} + x + {Tuple2 data data} + (\(k : k) (a : a) -> + Tuple2 + {data} + {data} + (`$dToData` k) + (`$dToData` a))) + (go xs)) + {all dead. dead} + in + \(eta : List (Tuple2 k a)) -> + mapData (`$fToBuiltinListBuiltinList_$ctoBuiltin` (go eta)) +in +\(n : integer) -> + let + !nt : data + = unsafeFromList + {integer} + {bytestring} + (\(i : integer) -> iData i) + bData + ((let + a = Tuple2 integer bytestring + 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 integer bytestring -> a -> a) (n : a) -> + c + (Tuple2 {integer} {bytestring} (addInteger 3 n) #5448524545) + (c + (Tuple2 + {integer} + {bytestring} + (addInteger 4 n) + #464f5552) + (c + (Tuple2 + {integer} + {bytestring} + (addInteger 6 n) + #534958) + (c + (Tuple2 + {integer} + {bytestring} + (addInteger 7 n) + #534556454e) + n))))) + ~rs : list (pair data data) = unMapData nt + in + letrec + !go : list (pair data data) -> list (pair data data) + = \(xs : list (pair data data)) -> + matchList + {pair data data} + {list (pair data data)} + xs + [] + (\(hd : pair data data) (tl : list (pair data data)) -> + let + !v' : data = sndPair {data} {data} hd + !k' : data = fstPair {data} {data} hd + 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 + !tl : list (pair data data) + = tailList {pair data data} xs + in + ifThenElse + {all dead. Maybe data} + (equalsData k' (fstPair {data} {data} hd)) + (/\dead -> Just {data} (sndPair {data} {data} hd)) + (/\dead -> go tl) + {all dead. dead}) + Unit + in + Maybe_match + {data} + (let + !eta : list (pair data data) = rs + in + go eta) + {all dead. list (pair data data)} + (\(r : data) -> + /\dead -> + mkCons + {pair data data} + (mkPairData + k' + (bData (appendByteString (unBData v') (unBData r)))) + (go tl)) + (/\dead -> mkCons {pair data data} (mkPairData k' v') (go tl)) + {all dead. dead}) + in + let + !nt : data + = unsafeFromList + {integer} + {bytestring} + (\(i : integer) -> iData i) + bData + ((let + a = Tuple2 integer bytestring + 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 integer bytestring -> a -> a) (n : a) -> + c + (Tuple2 {integer} {bytestring} (addInteger 1 n) #6f6e65) + (c + (Tuple2 {integer} {bytestring} (addInteger 2 n) #74776f) + (c + (Tuple2 + {integer} + {bytestring} + (addInteger 3 n) + #7468726565) + (c + (Tuple2 + {integer} + {bytestring} + (addInteger 4 n) + #666f7572) + (c + (Tuple2 + {integer} + {bytestring} + (addInteger 5 n) + #66697665) + n)))))) + ~ls : list (pair data data) = unMapData nt + in + letrec + !go : list (pair data data) -> list (pair data data) + = \(xs : list (pair data data)) -> + matchList + {pair data data} + {list (pair data data)} + xs + [] + (\(hd : pair data data) (tl : list (pair data data)) -> + let + !tl' : list (pair data data) = go tl + in + Bool_match + (let + !k : data = fstPair {data} {data} hd + in + letrec + !go : list (pair data data) -> Bool + = \(xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> Bool} + xs + (\(ds : Unit) -> False) + (\(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. Bool} + (equalsData k (fstPair {data} {data} hd)) + (/\dead -> True) + (/\dead -> go tl) + {all dead. dead}) + Unit + in + let + !eta : list (pair data data) = ls + in + go eta) + {all dead. list (pair data data)} + (/\dead -> tl') + (/\dead -> mkCons {pair data data} hd tl') + {all dead. dead}) + in + let + !nt : data + = let + !rs' : list (pair data data) = go rs + !ls' : list (pair data data) = go ls + in + mapData (go rs' ls') + in + (let + a = Tuple2 integer bytestring + in + /\b -> + \(f : a -> b) -> + letrec + !go : List a -> List b + = \(ds : List a) -> + List_match + {a} + ds + {all dead. List b} + (/\dead -> Nil {b}) + (\(x : a) (xs : List a) -> /\dead -> Cons {b} (f x) (go xs)) + {all dead. dead} + in + \(eta : List a) -> go eta) + {Tuple2 integer string} + (\(ds : Tuple2 integer bytestring) -> + Tuple2_match + {integer} + {bytestring} + ds + {Tuple2 integer string} + (\(k : integer) (v : bytestring) -> + Tuple2 {integer} {string} k (decodeUtf8 v))) + (go (unMapData nt)) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Budget/9.6/map2.uplc.golden b/plutus-tx-plugin/test/Budget/9.6/map2.uplc.golden new file mode 100644 index 00000000000..c88f69a0ec0 --- /dev/null +++ b/plutus-tx-plugin/test/Budget/9.6/map2.uplc.golden @@ -0,0 +1,273 @@ +program + 1.1.0 + ((\fix1 -> + (\go -> + (\go -> + (\matchList -> + (\`$fToBuiltinListBuiltinList_$ctoBuiltin` + n -> + (\unsafeFromList -> + (\cse -> + (\cse -> + (\nt -> + (\go -> + (\nt -> + (\nt -> + fix1 + (\go + ds -> + force + (case + ds + [ (delay (constr 0 [])) + , (\x + xs -> + delay + (constr 1 + [ (case + x + [ (\k + v -> + constr 0 + [ k + , (decodeUtf8 + v) ]) ]) + , (go xs) ])) ])) + (go (unMapData nt))) + ((\rs' -> + (\ls' -> mapData (go rs' ls')) + (go (unMapData nt))) + (fix1 + (\go + xs -> + matchList + xs + [] + (\hd + tl -> + (\tl' -> + force + (case + ((\k -> + fix1 + (\go + xs -> + force + (force + chooseList) + xs + (\ds -> + constr 1 + []) + (\ds -> + (\hd -> + (\tl -> + force + (force + ifThenElse + (equalsData + k + (force + (force + fstPair) + hd)) + (delay + (constr 0 + [ ])) + (delay + (go + tl)))) + (force + tailList + xs)) + (force + headList + xs)) + (constr 0 + [])) + (unMapData + nt)) + (force + (force + fstPair) + hd)) + [ (delay tl') + , (delay + (force mkCons + hd + tl')) ])) + (go tl))) + (unMapData nt)))) + (unsafeFromList + (\i -> iData i) + bData + (constr 1 + [ (constr 0 + [(addInteger 1 n), #6f6e65]) + , (constr 1 + [ (constr 0 + [(addInteger 2 n), #74776f]) + , (constr 1 + [ (constr 0 + [cse, #7468726565]) + , (constr 1 + [ (constr 0 + [cse, #666f7572]) + , (constr 1 + [ (constr 0 + [ (addInteger + 5 + n) + , #66697665 ]) + , (constr 0 + [ ]) ]) ]) ]) ]) ]))) + (fix1 + (\go + xs -> + matchList + xs + [] + (\hd + tl -> + (\v' -> + (\k' -> + force + (case + (fix1 + (\go + xs -> + force + (force chooseList) + xs + (\ds -> + constr 1 []) + (\ds -> + (\hd -> + (\tl -> + force + (force + ifThenElse + (equalsData + k' + (force + (force + fstPair) + hd)) + (delay + (constr 0 + [ (force + (force + sndPair) + hd) ])) + (delay + (go + tl)))) + (force + tailList + xs)) + (force + headList + xs)) + (constr 0 [])) + (unMapData nt)) + [ (\r -> + delay + (force + mkCons + (mkPairData + k' + (bData + (appendByteString + (unBData + v') + (unBData + r)))) + (go tl))) + , (delay + (force mkCons + (mkPairData k' v') + (go tl))) ])) + (force (force fstPair) hd)) + (force (force sndPair) hd))))) + (unsafeFromList + (\i -> iData i) + bData + (constr 1 + [ (constr 0 [cse, #5448524545]) + , (constr 1 + [ (constr 0 [cse, #464f5552]) + , (constr 1 + [ (constr 0 + [(addInteger 6 n), #534958]) + , (constr 1 + [ (constr 0 + [ (addInteger 7 n) + , #534556454e ]) + , (constr 0 []) ]) ]) ]) ]))) + (addInteger 4 n)) + (addInteger 3 n)) + (\`$dToData` `$dToData` -> + (\go eta -> + mapData + (`$fToBuiltinListBuiltinList_$ctoBuiltin` (go eta))) + (fix1 + (\go ds -> + force + (case + ds + [ (delay (constr 0 [])) + , (\x xs -> + delay + (constr 1 + [ (case + x + [ (\k a -> + constr 0 + [ (`$dToData` k) + , (`$dToData` a) ]) ]) + , (go xs) ])) ]))))) + (fix1 + (\`$fToBuiltinListBuiltinList_$ctoBuiltin` ds -> + force + (case + ds + [ (delay []) + , (\d ds -> + delay + (force mkCons + (case d [(\d d -> mkPairData d d)]) + (`$fToBuiltinListBuiltinList_$ctoBuiltin` + ds))) ])))) + (\l nilCase consCase -> + force (force chooseList) + l + (\ds -> nilCase) + (\ds -> consCase (force headList l) (force tailList l)) + (constr 0 []))) + (fix1 + (\go acc xs -> + force (force chooseList) + xs + (\ds -> acc) + (\ds -> + go + (force mkCons (force headList xs) acc) + (force tailList xs)) + (constr 0 [])))) + (fix1 + (\go xs -> + force (force chooseList) + xs + (\ds -> constr 0 []) + (\ds -> + (\hd -> + (\tl -> + constr 1 + [ (constr 0 + [ (unIData (force (force fstPair) hd)) + , (unBData (force (force sndPair) hd)) ]) + , (go tl) ]) + (force tailList xs)) + (force headList xs)) + (constr 0 [])))) + (\f -> (\s -> s s) (\s x -> f (s s) x))) \ No newline at end of file From 857f418818f2e568f74e8744eefc3c537075cee1 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Mon, 29 Apr 2024 16:06:39 +0300 Subject: [PATCH 08/41] Add documentation to AssocList Signed-off-by: Ana Pantilie --- plutus-tx/src/PlutusTx/Data/AssocList.hs | 51 +++++++++++++++++++----- 1 file changed, 40 insertions(+), 11 deletions(-) diff --git a/plutus-tx/src/PlutusTx/Data/AssocList.hs b/plutus-tx/src/PlutusTx/Data/AssocList.hs index cc5dadbcda4..b6b6093991b 100644 --- a/plutus-tx/src/PlutusTx/Data/AssocList.hs +++ b/plutus-tx/src/PlutusTx/Data/AssocList.hs @@ -47,6 +47,9 @@ Therefore this implementation is likely a better choice than @PlutusTx.AssocMap. if it is part of a data type defined using @asData@, and the key and value types have efficient `P.toBuiltinData` and `P.unsafeFromBuiltinData` operations (e.g., they are primitive types or types defined using @asData@). + +An `AssocList` is considered well-defined if it has no duplicate keys. Most operations +preserve the definedness of the resulting `AssocList` unless otherwise noted. -} newtype AssocList k a = AssocList P.BuiltinData deriving stock (Haskell.Eq, Haskell.Show) @@ -63,12 +66,16 @@ instance P.UnsafeFromData (AssocList k a) where unsafeFromBuiltinData = AssocList {-# INLINEABLE lookup #-} +-- | Look up the value corresponding to the key. +-- If the `AssocList` is not well-defined, the result is the value associated with +-- the left-most occurrence of the key in the list. lookup :: forall k a. (P.ToData k, P.UnsafeFromData a) => k -> AssocList k a -> Maybe a lookup (P.toBuiltinData -> k) m = case lookup' k (toBuiltinList m) of Just a -> Just (P.unsafeFromBuiltinData a) Nothing -> Nothing {-# INLINEABLE lookup' #-} +-- | Similar to 'lookup', but operates on the underlying `BuiltinList` representation. lookup' :: BuiltinData -> BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> @@ -87,10 +94,12 @@ lookup' k = go ) {-# INLINEABLE member #-} +-- | Check if the key is in the `AssocList`. member :: forall k a. (P.ToData k) => k -> AssocList k a -> Bool member (P.toBuiltinData -> k) m = member' k (toBuiltinList m) {-# INLINEABLE member' #-} +-- | Similar to 'member', but operates on the underlying `BuiltinList` representation. member' :: BuiltinData -> BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> Bool member' k = go where @@ -107,11 +116,14 @@ member' k = go ) {-# INLINEABLE insert #-} +-- | Insert a key-value pair into the `AssocList`. If the key is already present, +-- the value is updated. insert :: forall k a. (P.ToData k, P.ToData a) => k -> a -> AssocList k a -> AssocList k a insert (P.toBuiltinData -> k) (P.toBuiltinData -> a) m = unsafeFromBuiltinList $ insert' k a (toBuiltinList m) {-# INLINEABLE insert' #-} +-- | Similar to 'insert', but operates on the underlying `BuiltinList` representation. insert' :: BuiltinData -> BuiltinData @@ -134,6 +146,9 @@ insert' (P.toBuiltinData -> k) (P.toBuiltinData -> a) = go ) {-# INLINEABLE delete #-} +-- | Delete a key value pair from the `AssocList`. +-- If the `AssocList` is not well-defined, it deletes the pair associated with the +-- left-most occurrence of the key in the list. delete :: forall k a. (P.ToData k) => k -> AssocList k a -> AssocList k a delete (P.toBuiltinData -> k) m = unsafeFromBuiltinList (go (toBuiltinList m)) where @@ -152,20 +167,26 @@ delete (P.toBuiltinData -> k) m = unsafeFromBuiltinList (go (toBuiltinList m)) ) {-# INLINEABLE singleton #-} +-- | Create an `AssocList` with a single key-value pair. singleton :: forall k a. (P.ToData k, P.ToData a) => k -> a -> AssocList k a singleton (P.toBuiltinData -> k) (P.toBuiltinData -> a) = unsafeFromBuiltinList xs where xs = BI.mkCons (BI.mkPairData k a) nil {-# INLINEABLE empty #-} +-- | An empty `AssocList`. empty :: forall k a. AssocList k a empty = unsafeFromBuiltinList nil {-# INLINEABLE null #-} +-- | Check if the `AssocList` is empty. null :: forall k a. AssocList k a -> Bool null = P.null . toBuiltinList {-# INLINEABLE safeFromList #-} +-- | Create an `AssocList` 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 . (Eq k, P.ToData k, P.ToData a) => [(k, a)] -> AssocList k a safeFromList = unsafeFromBuiltinList @@ -181,6 +202,10 @@ safeFromList = else (k', v') : go k v rest {-# INLINEABLE unsafeFromList #-} +-- | Unsafely create an 'AssocList' from a list of pairs. +-- This should _only_ be applied to lists which have been checked to not +-- contain duplicate keys, otherwise the resulting 'AssocList' will contain +-- conflicting entries (two entries sharing the same key), and therefore be ill-defined. unsafeFromList :: (P.ToData k, P.ToData a) => [(k, a)] -> AssocList k a unsafeFromList = unsafeFromBuiltinList @@ -188,6 +213,7 @@ unsafeFromList = . PlutusTx.Prelude.map (\(k, a) -> (P.toBuiltinData k, P.toBuiltinData a)) {-# INLINEABLE uncons #-} +-- | Decompose an 'AssocList' into its first key-value pair and the rest of the list. uncons :: forall k a. (P.UnsafeFromData k, P.UnsafeFromData a) => @@ -200,6 +226,9 @@ uncons m = case P.uncons (toBuiltinList m) of in Just ((P.unsafeFromBuiltinData k, P.unsafeFromBuiltinData a), unsafeFromBuiltinList rest) {-# INLINEABLE unsafeUncons #-} +-- | Decompose an 'AssocList' into its first key-value pair and the rest of the list. +-- This function is unsafe because it assumes that the elements of the list can be safely +-- decoded from their 'BuiltinData' representation. unsafeUncons :: forall k a. (P.UnsafeFromData k, P.UnsafeFromData a) => @@ -212,6 +241,7 @@ unsafeUncons m = (k, a) = P.pairToPair hd {-# INLINEABLE noDuplicateKeys #-} +-- | Check if the `AssocList` is well-defined. Warning: this operation is O(n^2). noDuplicateKeys :: forall k a. AssocList k a -> Bool noDuplicateKeys m = go (toBuiltinList m) where @@ -226,6 +256,7 @@ noDuplicateKeys m = go (toBuiltinList m) ) {-# INLINEABLE all #-} +--- | Check if all values in the `AssocList` satisfy the predicate. all :: forall k a. (P.UnsafeFromData a) => (a -> Bool) -> AssocList k a -> Bool all p m = go (toBuiltinList m) where @@ -240,6 +271,7 @@ all p m = go (toBuiltinList m) ) {-# INLINEABLE any #-} +-- | Check if any value in the `AssocList` satisfies the predicate. any :: forall k a. (P.UnsafeFromData a) => (a -> Bool) -> AssocList k a -> Bool any p m = go (toBuiltinList m) where @@ -255,13 +287,7 @@ any p m = go (toBuiltinList m) {-# INLINEABLE union #-} --- TODO: This is broken! --- The value should be a correct encoding of a `These` value, but it is not. --- Example: --- > union (safeFromList []) (safeFromList [(0, 0)]) :: AssocList Integer (These Integer Integer) --- > AssocList Map [(I 0,I 0)] --- The second element of the pair should be encoded as the appropriate `Constr`! --- | Combine two 'AssocList's. +-- | Combine two 'AssocList's into one. It saves both values if the key is present in both lists. union :: forall k a b. (P.UnsafeFromData a, P.UnsafeFromData b, P.ToData a, P.ToData b) => @@ -376,10 +402,8 @@ unionWith f (toBuiltinList -> ls) (toBuiltinList -> rs) = (\hd -> go (BI.mkCons hd acc)) {-# INLINEABLE toList #-} - -{- | `toList` is expensive since it traverses the whole map. -`toBuiltinList` is much faster. --} +-- | Convert the `AssocList` to a list of key-value pairs. This operation is O(n). +-- See 'toBuiltinList' for a more efficient alternative. toList :: (P.UnsafeFromData k, P.UnsafeFromData a) => AssocList k a -> [(k, a)] toList d = go (toBuiltinList d) where @@ -393,10 +417,14 @@ toList d = go (toBuiltinList d) ) {-# INLINEABLE toBuiltinList #-} +-- | Convert the `AssocList` to a `P.BuiltinList` of key-value pairs. This operation is O(1). toBuiltinList :: AssocList k a -> BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) toBuiltinList (AssocList d) = BI.unsafeDataAsMap d {-# INLINEABLE unsafeFromBuiltinList #-} +-- | Unsafely create an 'AssocList' from a `P.BuiltinList` of key-value pairs. +-- This function is unsafe because it assumes that the elements of the list can be safely +-- decoded from their 'BuiltinData' representation. unsafeFromBuiltinList :: forall k a. BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> @@ -404,5 +432,6 @@ unsafeFromBuiltinList :: unsafeFromBuiltinList = AssocList . BI.mkMap {-# INLINEABLE nil #-} +-- | An empty `P.BuiltinList` of key-value pairs. nil :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) nil = BI.mkNilPairData BI.unitval From 8e620e51d522572144575657c69b39bb2c2a6e65 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Mon, 29 Apr 2024 17:15:57 +0300 Subject: [PATCH 09/41] Add docs to tests Signed-off-by: Ana Pantilie --- plutus-tx-plugin/test/AssocList/Spec.hs | 63 +++++++++++++++--------- plutus-tx/src/PlutusTx/Data/AssocList.hs | 3 +- 2 files changed, 40 insertions(+), 26 deletions(-) diff --git a/plutus-tx-plugin/test/AssocList/Spec.hs b/plutus-tx-plugin/test/AssocList/Spec.hs index a6b5f920689..a02ca0d3c23 100644 --- a/plutus-tx-plugin/test/AssocList/Spec.hs +++ b/plutus-tx-plugin/test/AssocList/Spec.hs @@ -1,4 +1,3 @@ --- editorconfig-checker-disable-file {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} @@ -53,7 +52,7 @@ goldenTests = propertyTests :: TestTree propertyTests = - testGroup "TESTING Map property tests" + testGroup "Map property tests" [ testProperty "safeFromList" safeFromListSpec , testProperty "unsafeFromList" unsafeFromListSpec , testProperty "lookup" lookupSpec @@ -87,7 +86,11 @@ map1 = let m :: AssocList Integer PlutusTx.BuiltinByteString m = foldr - (\i -> Data.AssocList.insert (n PlutusTx.+ i) (PlutusTx.encodeUtf8 (PlutusTx.show i))) + (\i -> + Data.AssocList.insert + (n PlutusTx.+ i) + (PlutusTx.encodeUtf8 (PlutusTx.show i)) + ) (Data.AssocList.singleton n "0") (PlutusTx.enumFromTo 1 10) m' = Data.AssocList.delete (n PlutusTx.+ 5) m @@ -125,25 +128,31 @@ map2 = ||] ) +-- | The semantics of association lists and their operations. +-- The 'PlutusTx' implementations of association lists ('AssocList' and 'AssocMap') +-- are checked against the semantics to ensure correctness. newtype AssocListS k v = AssocListS [(k, v)] deriving stock (Show, Eq) -nullS :: AssocListS k v -> Bool -nullS (AssocListS l) = null l - semanticsToAssocMap :: AssocListS k v -> AssocMap.Map k v semanticsToAssocMap = AssocMap.unsafeFromList . toListS -semanticsToAssocList :: (P.ToData k, P.ToData v) => AssocListS k v -> AssocList k v +semanticsToAssocList + :: (P.ToData k, P.ToData v) + => AssocListS k v -> AssocList k v semanticsToAssocList = Data.AssocList.unsafeFromList . toListS assocMapToSemantics :: AssocMap.Map k v -> AssocListS k v assocMapToSemantics = unsafeFromListS . AssocMap.toList assocListToSemantics - :: (P.UnsafeFromData k, P.UnsafeFromData v) => AssocList k v -> AssocListS k v + :: (P.UnsafeFromData k, P.UnsafeFromData v) + => AssocList k v -> AssocListS k v assocListToSemantics = unsafeFromListS . Data.AssocList.toList +nullS :: AssocListS k v -> Bool +nullS (AssocListS l) = null l + sortS :: (Ord k, Ord v) => AssocListS k v -> AssocListS k v sortS (AssocListS l) = AssocListS $ sort l @@ -191,22 +200,8 @@ noDuplicateKeysS :: AssocListS Integer Integer -> Bool noDuplicateKeysS (AssocListS l) = length l == length (nubBy (\(k1, _) (k2, _) -> k1 == k2) l) -genAssocListS :: Gen (AssocListS Integer Integer) -genAssocListS = - AssocListS . Map.toList <$> Gen.map rangeLength genPair - where - genPair :: Gen (Integer, Integer) - genPair = do - (,) <$> Gen.integral rangeElem <*> Gen.integral rangeElem - -genUnsafeAssocListS :: Gen (AssocListS Integer Integer) -genUnsafeAssocListS = do - AssocListS <$> Gen.list rangeLength genPair - where - genPair :: Gen (Integer, Integer) - genPair = do - (,) <$> Gen.integral rangeElem <*> Gen.integral rangeElem - +-- | The semantics of 'union' is based on the 'AssocMap' implementation. +-- The code is duplicated here to avoid any issues if the 'AssocMap' implementation changes. unionS :: AssocListS Integer Integer -> AssocListS Integer Integer @@ -236,6 +231,24 @@ unionWithS merge (AssocListS ls) (AssocListS rs) = . Map.toList $ Map.unionWith merge (Map.fromList ls) (Map.fromList rs) +genAssocListS :: Gen (AssocListS Integer Integer) +genAssocListS = + AssocListS . Map.toList <$> Gen.map rangeLength genPair + where + genPair :: Gen (Integer, Integer) + genPair = do + (,) <$> Gen.integral rangeElem <*> Gen.integral rangeElem + +genUnsafeAssocListS :: Gen (AssocListS Integer Integer) +genUnsafeAssocListS = do + AssocListS <$> Gen.list rangeLength genPair + where + genPair :: Gen (Integer, Integer) + genPair = do + (,) <$> Gen.integral rangeElem <*> Gen.integral rangeElem + +-- | The 'Equivalence' class is used to define an equivalence relation +-- between `AssocListS` and the 'PlutusTx' implementations. class Equivalence l where (~~) :: ( MonadTest m @@ -247,10 +260,12 @@ class Equivalence l where , P.UnsafeFromData v ) => AssocListS k v -> l k v -> m () +-- | An `AssocMap.Map` is equivalent to an `AssocListS` if they have the same elements. instance Equivalence AssocMap.Map where assocListS ~~ assocMap = sortS assocListS === sortS (assocMapToSemantics assocMap) +-- | An `AssocList` is equivalent to an `AssocListS` if they have the same elements. instance Equivalence AssocList where assocListS ~~ assocList = sortS assocListS === sortS (assocListToSemantics assocList) diff --git a/plutus-tx/src/PlutusTx/Data/AssocList.hs b/plutus-tx/src/PlutusTx/Data/AssocList.hs index b6b6093991b..aeb5eeffcf9 100644 --- a/plutus-tx/src/PlutusTx/Data/AssocList.hs +++ b/plutus-tx/src/PlutusTx/Data/AssocList.hs @@ -227,8 +227,7 @@ uncons m = case P.uncons (toBuiltinList m) of {-# INLINEABLE unsafeUncons #-} -- | Decompose an 'AssocList' into its first key-value pair and the rest of the list. --- This function is unsafe because it assumes that the elements of the list can be safely --- decoded from their 'BuiltinData' representation. +-- This function is unsafe because it assumes that the `AssocList` is not empty. unsafeUncons :: forall k a. (P.UnsafeFromData k, P.UnsafeFromData a) => From 721d82da7dd20da5aa532aa48cd1dbf538590bb4 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Mon, 29 Apr 2024 17:35:41 +0300 Subject: [PATCH 10/41] Add data encoding test Signed-off-by: Ana Pantilie --- plutus-tx-plugin/test/AssocList/Spec.hs | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/plutus-tx-plugin/test/AssocList/Spec.hs b/plutus-tx-plugin/test/AssocList/Spec.hs index a02ca0d3c23..da722889d82 100644 --- a/plutus-tx-plugin/test/AssocList/Spec.hs +++ b/plutus-tx-plugin/test/AssocList/Spec.hs @@ -17,6 +17,7 @@ import Test.Tasty.Extras import Data.List (nubBy, sort) import Data.Map.Strict qualified as Map +import Data.Maybe (fromJust) import Hedgehog (Gen, MonadTest, Property, Range, forAll, property, (===)) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range @@ -67,6 +68,7 @@ propertyTests = , testProperty "delete" deleteSpec , testProperty "union" unionSpec , testProperty "unionWith" unionWithSpec + , testProperty "builtinDataEncoding" builtinDataEncodingSpec ] map1 :: @@ -399,3 +401,24 @@ unionWithSpec = property $ do merge i1 _ = i1 unionWithS merge assocListS1 assocListS2 ~~ AssocMap.unionWith merge assocMap1 assocMap2 unionWithS merge assocListS1 assocListS2 ~~ Data.AssocList.unionWith merge assocList1 assocList2 + +builtinDataEncodingSpec :: Property +builtinDataEncodingSpec = property $ do + assocListS <- forAll genAssocListS + let assocMap = semanticsToAssocMap assocListS + assocList = semanticsToAssocList assocListS + encodedAssocList = P.toBuiltinData assocList + encodedAssocMap = P.toBuiltinData assocMap + mDecodedAssocList :: Maybe (AssocList Integer Integer) + mDecodedAssocList = P.fromBuiltinData encodedAssocList + mDecodedAssocMap :: Maybe (AssocMap.Map Integer Integer) + mDecodedAssocMap = P.fromBuiltinData encodedAssocMap + decodedAssocList :: AssocList Integer Integer + decodedAssocList = P.unsafeFromBuiltinData encodedAssocList + decodedAssocMap :: AssocMap.Map Integer Integer + decodedAssocMap = P.unsafeFromBuiltinData encodedAssocMap + encodedAssocList === encodedAssocMap + assocListS ~~ fromJust mDecodedAssocMap + assocListS ~~ fromJust mDecodedAssocList + assocListS ~~ decodedAssocMap + assocListS ~~ decodedAssocList From 0f1d945c57b43028ecd2af7ba070f06324b0e730 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Tue, 30 Apr 2024 13:31:03 +0300 Subject: [PATCH 11/41] Address some review comments Signed-off-by: Ana Pantilie --- .../test/Budget/9.6/map1-budget.budget.golden | 4 +- .../test/Budget/9.6/map1.pir.golden | 11 ++- .../test/Budget/9.6/map1.uplc.golden | 38 ++++---- .../test/Budget/9.6/map2-budget.budget.golden | 4 +- .../test/Budget/9.6/map2.pir.golden | 33 ++++--- .../test/Budget/9.6/map2.uplc.golden | 86 ++++++++++--------- plutus-tx/src/PlutusTx/Data/AssocList.hs | 22 ++--- plutus-tx/src/PlutusTx/These.hs | 4 +- 8 files changed, 110 insertions(+), 92 deletions(-) diff --git a/plutus-tx-plugin/test/Budget/9.6/map1-budget.budget.golden b/plutus-tx-plugin/test/Budget/9.6/map1-budget.budget.golden index eac1529d67e..156ac164742 100644 --- a/plutus-tx-plugin/test/Budget/9.6/map1-budget.budget.golden +++ b/plutus-tx-plugin/test/Budget/9.6/map1-budget.budget.golden @@ -1,2 +1,2 @@ -({cpu: 449378976 -| mem: 1091917}) \ No newline at end of file +({cpu: 447446976 +| mem: 1083517}) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Budget/9.6/map1.pir.golden b/plutus-tx-plugin/test/Budget/9.6/map1.pir.golden index 745c72b8796..533937ec113 100644 --- a/plutus-tx-plugin/test/Budget/9.6/map1.pir.golden +++ b/plutus-tx-plugin/test/Budget/9.6/map1.pir.golden @@ -253,14 +253,17 @@ let (\(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. Maybe data} (equalsData k (fstPair {data} {data} hd)) - (/\dead -> Just {data} (sndPair {data} {data} hd)) - (/\dead -> go tl) + (/\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 diff --git a/plutus-tx-plugin/test/Budget/9.6/map1.uplc.golden b/plutus-tx-plugin/test/Budget/9.6/map1.uplc.golden index 4d017d4f9aa..468ae78fb8f 100644 --- a/plutus-tx-plugin/test/Budget/9.6/map1.uplc.golden +++ b/plutus-tx-plugin/test/Budget/9.6/map1.uplc.golden @@ -56,28 +56,30 @@ program (\ds -> constr 1 []) (\ds -> (\hd -> - (\tl -> - force - (force - ifThenElse - (equalsData - k + force + (force + ifThenElse + (equalsData + k + (force (force - (force - fstPair) - hd)) - (delay - (constr 0 + fstPair) + hd)) + (delay + ((\ds -> + constr 0 [ (force (force sndPair) - hd) ])) - (delay - (go - tl)))) - (force - tailList - xs)) + hd) ]) + (force + tailList + xs))) + (delay + (go + (force + tailList + xs))))) (force headList xs)) (constr 0 [])) diff --git a/plutus-tx-plugin/test/Budget/9.6/map2-budget.budget.golden b/plutus-tx-plugin/test/Budget/9.6/map2-budget.budget.golden index 6215d03406e..5eb9c377668 100644 --- a/plutus-tx-plugin/test/Budget/9.6/map2-budget.budget.golden +++ b/plutus-tx-plugin/test/Budget/9.6/map2-budget.budget.golden @@ -1,2 +1,2 @@ -({cpu: 165082681 -| mem: 433602}) \ No newline at end of file +({cpu: 161977681 +| mem: 420102}) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Budget/9.6/map2.pir.golden b/plutus-tx-plugin/test/Budget/9.6/map2.pir.golden index 4c07383cc2b..216d09f15fe 100644 --- a/plutus-tx-plugin/test/Budget/9.6/map2.pir.golden +++ b/plutus-tx-plugin/test/Budget/9.6/map2.pir.golden @@ -188,14 +188,17 @@ in let !hd : pair data data = headList {pair data data} xs - !tl : list (pair data data) - = tailList {pair data data} xs in ifThenElse {all dead. Maybe data} (equalsData k' (fstPair {data} {data} hd)) - (/\dead -> Just {data} (sndPair {data} {data} hd)) - (/\dead -> go tl) + (/\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 @@ -281,17 +284,21 @@ in xs (\(ds : Unit) -> False) (\(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. Bool} - (equalsData k (fstPair {data} {data} hd)) - (/\dead -> True) - (/\dead -> go tl) + (equalsData + k + (fstPair + {data} + {data} + (headList {pair data data} xs))) + (/\dead -> + let + !ds : list (pair data data) + = tailList {pair data data} xs + in + True) + (/\dead -> go (tailList {pair data data} xs)) {all dead. dead}) Unit in diff --git a/plutus-tx-plugin/test/Budget/9.6/map2.uplc.golden b/plutus-tx-plugin/test/Budget/9.6/map2.uplc.golden index c88f69a0ec0..320e236fb27 100644 --- a/plutus-tx-plugin/test/Budget/9.6/map2.uplc.golden +++ b/plutus-tx-plugin/test/Budget/9.6/map2.uplc.golden @@ -60,29 +60,29 @@ program constr 1 []) (\ds -> - (\hd -> - (\tl -> - force - (force - ifThenElse - (equalsData - k - (force - (force - fstPair) - hd)) - (delay - (constr 0 - [ ])) - (delay - (go - tl)))) - (force - tailList - xs)) + force (force - headList - xs)) + ifThenElse + (equalsData + k + (force + (force + fstPair) + (force + headList + xs))) + (delay + ((\ds -> + constr 0 + [ ]) + (force + tailList + xs))) + (delay + (go + (force + tailList + xs))))) (constr 0 [])) (unMapData @@ -143,28 +143,30 @@ program constr 1 []) (\ds -> (\hd -> - (\tl -> - force - (force - ifThenElse - (equalsData - k' + force + (force + ifThenElse + (equalsData + k' + (force (force - (force - fstPair) - hd)) - (delay - (constr 0 + fstPair) + hd)) + (delay + ((\ds -> + constr 0 [ (force (force sndPair) - hd) ])) - (delay - (go - tl)))) - (force - tailList - xs)) + hd) ]) + (force + tailList + xs))) + (delay + (go + (force + tailList + xs))))) (force headList xs)) @@ -204,8 +206,8 @@ program [ (addInteger 7 n) , #534556454e ]) , (constr 0 []) ]) ]) ]) ]))) - (addInteger 4 n)) - (addInteger 3 n)) + (addInteger 3 n)) + (addInteger 4 n)) (\`$dToData` `$dToData` -> (\go eta -> mapData diff --git a/plutus-tx/src/PlutusTx/Data/AssocList.hs b/plutus-tx/src/PlutusTx/Data/AssocList.hs index aeb5eeffcf9..8f750d419f9 100644 --- a/plutus-tx/src/PlutusTx/Data/AssocList.hs +++ b/plutus-tx/src/PlutusTx/Data/AssocList.hs @@ -60,9 +60,11 @@ instance P.ToData (AssocList k a) where toBuiltinData (AssocList d) = d instance P.FromData (AssocList k a) where + {-# INLINABLE fromBuiltinData #-} fromBuiltinData = Just . AssocList instance P.UnsafeFromData (AssocList k a) where + {-# INLINABLE unsafeFromBuiltinData #-} unsafeFromBuiltinData = AssocList {-# INLINEABLE lookup #-} @@ -86,11 +88,11 @@ lookup' k = go P.matchList xs Nothing - ( \hd tl -> + ( \hd -> let k' = BI.fst hd in if P.equalsData k k' - then Just (BI.snd hd) - else go tl + then \_ -> Just (BI.snd hd) + else go ) {-# INLINEABLE member #-} @@ -108,11 +110,11 @@ member' k = go P.matchList xs False - ( \hd tl -> + ( \hd -> let k' = BI.fst hd in if P.equalsData k k' - then True - else go tl + then \_ -> True + else go ) {-# INLINEABLE insert #-} @@ -264,9 +266,9 @@ all p m = go (toBuiltinList m) P.matchList xs True - ( \hd tl -> + ( \hd -> let a = P.unsafeFromBuiltinData (BI.snd hd) - in if p a then go tl else False + in if p a then go else \_ -> False ) {-# INLINEABLE any #-} @@ -279,9 +281,9 @@ any p m = go (toBuiltinList m) P.matchList xs False - ( \hd tl -> + ( \hd -> let a = P.unsafeFromBuiltinData (BI.snd hd) - in if p a then True else go tl + in if p a then \_ -> True else go ) {-# INLINEABLE union #-} diff --git a/plutus-tx/src/PlutusTx/These.hs b/plutus-tx/src/PlutusTx/These.hs index 7a22822b136..42306b4d99a 100644 --- a/plutus-tx/src/PlutusTx/These.hs +++ b/plutus-tx/src/PlutusTx/These.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE LambdaCase #-} + {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} -{-# LANGUAGE DerivingStrategies #-} + module PlutusTx.These( These(..) , these From 7dbd045c5e3176746df38922f659c24de8eb6b29 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Tue, 7 May 2024 15:41:15 +0300 Subject: [PATCH 12/41] Rename AssocList to AssocMap Signed-off-by: Ana Pantilie --- plutus-tx-plugin/plutus-tx-plugin.cabal | 2 +- plutus-tx-plugin/test/AssocList/Spec.hs | 424 ------------------ plutus-tx-plugin/test/AssocMap/Spec.hs | 396 ++++++++++++++++ plutus-tx-plugin/test/Spec.hs | 6 +- plutus-tx/plutus-tx.cabal | 2 +- .../Data/{AssocList.hs => AssocMap.hs} | 140 +++--- 6 files changed, 458 insertions(+), 512 deletions(-) delete mode 100644 plutus-tx-plugin/test/AssocList/Spec.hs create mode 100644 plutus-tx-plugin/test/AssocMap/Spec.hs rename plutus-tx/src/PlutusTx/Data/{AssocList.hs => AssocMap.hs} (71%) diff --git a/plutus-tx-plugin/plutus-tx-plugin.cabal b/plutus-tx-plugin/plutus-tx-plugin.cabal index ba2b9aef372..2ffbd8a8501 100644 --- a/plutus-tx-plugin/plutus-tx-plugin.cabal +++ b/plutus-tx-plugin/plutus-tx-plugin.cabal @@ -128,7 +128,7 @@ test-suite plutus-tx-plugin-tests other-modules: AsData.Budget.Spec AsData.Budget.Types - AssocList.Spec + AssocMap.Spec Blueprint.Tests Blueprint.Tests.Lib Blueprint.Tests.Lib.AsData.Blueprint diff --git a/plutus-tx-plugin/test/AssocList/Spec.hs b/plutus-tx-plugin/test/AssocList/Spec.hs deleted file mode 100644 index da722889d82..00000000000 --- a/plutus-tx-plugin/test/AssocList/Spec.hs +++ /dev/null @@ -1,424 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# 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 #-} -{-# LANGUAGE FlexibleInstances #-} - -module AssocList.Spec where - -import Test.Tasty.Extras - -import Data.List (nubBy, sort) -import Data.Map.Strict qualified as Map -import Data.Maybe (fromJust) -import Hedgehog (Gen, MonadTest, Property, Range, forAll, property, (===)) -import Hedgehog.Gen qualified as Gen -import Hedgehog.Range qualified as Range -import PlutusTx.AssocMap qualified as AssocMap -import PlutusTx.Builtins qualified as PlutusTx -import PlutusTx.Code -import PlutusTx.Data.AssocList (AssocList) -import PlutusTx.Data.AssocList qualified as Data.AssocList -import PlutusTx.IsData () -import PlutusTx.IsData qualified as P -import PlutusTx.Lift (liftCodeDef) -import PlutusTx.Prelude qualified as PlutusTx -import PlutusTx.Show qualified as PlutusTx -import PlutusTx.Test -import PlutusTx.TH (compile) -import PlutusTx.These (These (..)) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.Hedgehog (testProperty) - -goldenTests :: TestNested -goldenTests = - testNestedGhc - "Budget" - [ goldenPirReadable "map1" map1 - , goldenUPlcReadable "map1" map1 - , goldenEvalCekCatch "map1" $ [map1 `unsafeApplyCode` (liftCodeDef 100)] - , goldenBudget "map1-budget" $ map1 `unsafeApplyCode` (liftCodeDef 100) - , goldenPirReadable "map2" map2 - , goldenUPlcReadable "map2" map2 - , goldenEvalCekCatch "map2" $ [map2 `unsafeApplyCode` (liftCodeDef 100)] - , goldenBudget "map2-budget" $ map2 `unsafeApplyCode` (liftCodeDef 100) - ] - -propertyTests :: TestTree -propertyTests = - testGroup "Map property tests" - [ testProperty "safeFromList" safeFromListSpec - , testProperty "unsafeFromList" unsafeFromListSpec - , testProperty "lookup" lookupSpec - , testProperty "member" memberSpec - , testProperty "insert" insertSpec - , testProperty "all" allSpec - , testProperty "any" anySpec - , testProperty "keys" keysSpec - , testProperty "uncons" unconsSpec - , testProperty "unsafeUncons" unsafeUnconsSpec - , testProperty "noDuplicateKeys" noDuplicateKeysSpec - , testProperty "delete" deleteSpec - , testProperty "union" unionSpec - , testProperty "unionWith" unionWithSpec - , testProperty "builtinDataEncoding" builtinDataEncodingSpec - ] - -map1 :: - CompiledCode - ( Integer -> - ( Maybe PlutusTx.BuiltinByteString - , Maybe PlutusTx.BuiltinByteString - , Maybe PlutusTx.BuiltinByteString - , Maybe PlutusTx.BuiltinByteString - , Maybe PlutusTx.BuiltinByteString - ) - ) -map1 = - $$( compile - [|| - \n -> - let m :: AssocList Integer PlutusTx.BuiltinByteString - m = - foldr - (\i -> - Data.AssocList.insert - (n PlutusTx.+ i) - (PlutusTx.encodeUtf8 (PlutusTx.show i)) - ) - (Data.AssocList.singleton n "0") - (PlutusTx.enumFromTo 1 10) - m' = Data.AssocList.delete (n PlutusTx.+ 5) m - in ( Data.AssocList.lookup n m - , Data.AssocList.lookup (n PlutusTx.+ 5) m - , Data.AssocList.lookup (n PlutusTx.+ 10) m - , Data.AssocList.lookup (n PlutusTx.+ 20) m - , Data.AssocList.lookup (n PlutusTx.+ 5) m' - ) - ||] - ) - -map2 :: CompiledCode (Integer -> [(Integer, PlutusTx.BuiltinString)]) -map2 = - $$( compile - [|| - \n -> - let m1 = - Data.AssocList.unsafeFromList - [ (n PlutusTx.+ 1, "one") - , (n PlutusTx.+ 2, "two") - , (n PlutusTx.+ 3, "three") - , (n PlutusTx.+ 4, "four") - , (n PlutusTx.+ 5, "five") - ] - m2 = - Data.AssocList.unsafeFromList - [ (n PlutusTx.+ 3, "THREE") - , (n PlutusTx.+ 4, "FOUR") - , (n PlutusTx.+ 6, "SIX") - , (n PlutusTx.+ 7, "SEVEN") - ] - m = Data.AssocList.unionWith PlutusTx.appendByteString m1 m2 - in PlutusTx.fmap (\(k, v) -> (k, PlutusTx.decodeUtf8 v)) (Data.AssocList.toList m) - ||] - ) - --- | The semantics of association lists and their operations. --- The 'PlutusTx' implementations of association lists ('AssocList' and 'AssocMap') --- are checked against the semantics to ensure correctness. -newtype AssocListS k v = AssocListS [(k, v)] - deriving stock (Show, Eq) - -semanticsToAssocMap :: AssocListS k v -> AssocMap.Map k v -semanticsToAssocMap = AssocMap.unsafeFromList . toListS - -semanticsToAssocList - :: (P.ToData k, P.ToData v) - => AssocListS k v -> AssocList k v -semanticsToAssocList = Data.AssocList.unsafeFromList . toListS - -assocMapToSemantics :: AssocMap.Map k v -> AssocListS k v -assocMapToSemantics = unsafeFromListS . AssocMap.toList - -assocListToSemantics - :: (P.UnsafeFromData k, P.UnsafeFromData v) - => AssocList k v -> AssocListS k v -assocListToSemantics = unsafeFromListS . Data.AssocList.toList - -nullS :: AssocListS k v -> Bool -nullS (AssocListS l) = null l - -sortS :: (Ord k, Ord v) => AssocListS k v -> AssocListS k v -sortS (AssocListS l) = AssocListS $ sort l - -toListS :: AssocListS k v -> [(k, v)] -toListS (AssocListS l) = l - -unsafeFromListS :: [(k, v)] -> AssocListS k v -unsafeFromListS = AssocListS - -safeFromListS :: Ord k => [(k, v)] -> AssocListS k v -safeFromListS = AssocListS . Map.toList . Map.fromList - -lookupS :: Integer -> AssocListS Integer Integer -> Maybe Integer -lookupS k (AssocListS l) = Map.lookup k . Map.fromList $ l - -memberS :: Integer -> AssocListS Integer Integer -> Bool -memberS k (AssocListS l) = Map.member k . Map.fromList $ l - -insertS :: Integer -> Integer -> AssocListS Integer Integer -> AssocListS Integer Integer -insertS k v (AssocListS l) = - AssocListS . Map.toList . Map.insert k v . Map.fromList $ l - -deleteS :: Integer -> AssocListS Integer Integer -> AssocListS Integer Integer -deleteS k (AssocListS l) = - AssocListS . Map.toList . Map.delete k . Map.fromList $ l - -allS :: (Integer -> Bool) -> AssocListS Integer Integer -> Bool -allS p (AssocListS l) = all (p . snd) l - -anyS :: (Integer -> Bool) -> AssocListS Integer Integer -> Bool -anyS p (AssocListS l) = any (p . snd) l - -keysS :: AssocListS Integer Integer -> [Integer] -keysS (AssocListS l) = map fst l - -unconsS :: AssocListS Integer Integer -> Maybe ((Integer, Integer), AssocListS Integer Integer) -unconsS (AssocListS []) = Nothing -unconsS (AssocListS (x : xs)) = Just (x, AssocListS xs) - -unsafeUnconsS :: AssocListS Integer Integer -> ((Integer, Integer), AssocListS Integer Integer) -unsafeUnconsS (AssocListS []) = error "unsafeUnconsS: empty list" -unsafeUnconsS (AssocListS (x : xs)) = (x, AssocListS xs) - -noDuplicateKeysS :: AssocListS Integer Integer -> Bool -noDuplicateKeysS (AssocListS l) = - length l == length (nubBy (\(k1, _) (k2, _) -> k1 == k2) l) - --- | The semantics of 'union' is based on the 'AssocMap' implementation. --- The code is duplicated here to avoid any issues if the 'AssocMap' implementation changes. -unionS - :: AssocListS Integer Integer - -> AssocListS Integer Integer - -> AssocListS Integer (These Integer Integer) -unionS (AssocListS ls) (AssocListS rs) = - let - f a b' = case b' of - Nothing -> This a - Just b -> These a b - - ls' = fmap (\(c, i) -> (c, f i (lookupS c (AssocListS rs)))) ls - - -- Keeps only those keys which don't appear in the left map. - rs' = filter (\(c, _) -> not (any (\(c', _) -> c' == c) ls)) rs - - rs'' = fmap (fmap That) rs' - in - AssocListS (ls' ++ rs'') - -unionWithS - :: (Integer -> Integer -> Integer) - -> AssocListS Integer Integer - -> AssocListS Integer Integer - -> AssocListS Integer Integer -unionWithS merge (AssocListS ls) (AssocListS rs) = - AssocListS - . Map.toList - $ Map.unionWith merge (Map.fromList ls) (Map.fromList rs) - -genAssocListS :: Gen (AssocListS Integer Integer) -genAssocListS = - AssocListS . Map.toList <$> Gen.map rangeLength genPair - where - genPair :: Gen (Integer, Integer) - genPair = do - (,) <$> Gen.integral rangeElem <*> Gen.integral rangeElem - -genUnsafeAssocListS :: Gen (AssocListS Integer Integer) -genUnsafeAssocListS = do - AssocListS <$> Gen.list rangeLength genPair - where - genPair :: Gen (Integer, Integer) - genPair = do - (,) <$> Gen.integral rangeElem <*> Gen.integral rangeElem - --- | The 'Equivalence' class is used to define an equivalence relation --- between `AssocListS` and the 'PlutusTx' implementations. -class Equivalence l where - (~~) :: - ( MonadTest m - , Show k - , Show v - , Ord k - , Ord v - , P.UnsafeFromData k - , P.UnsafeFromData v - ) => AssocListS k v -> l k v -> m () - --- | An `AssocMap.Map` is equivalent to an `AssocListS` if they have the same elements. -instance Equivalence AssocMap.Map where - assocListS ~~ assocMap = - sortS assocListS === sortS (assocMapToSemantics assocMap) - --- | An `AssocList` is equivalent to an `AssocListS` if they have the same elements. -instance Equivalence AssocList where - assocListS ~~ assocList = - sortS assocListS === sortS (assocListToSemantics assocList) - -rangeElem :: Range Integer -rangeElem = Range.linear 0 100 - -rangeLength :: Range Int -rangeLength = Range.linear 0 100 - -safeFromListSpec :: Property -safeFromListSpec = property $ do - assocListS <- forAll genAssocListS - let assocMap = AssocMap.safeFromList . toListS $ assocListS - assocList = Data.AssocList.safeFromList . toListS $ assocListS - assocListS ~~ assocMap - assocListS ~~ assocList - -unsafeFromListSpec :: Property -unsafeFromListSpec = property $ do - assocListS <- forAll genAssocListS - let assocMap = AssocMap.unsafeFromList . toListS $ assocListS - assocList = Data.AssocList.unsafeFromList . toListS $ assocListS - assocListS ~~ assocMap - assocListS ~~ assocList - -lookupSpec :: Property -lookupSpec = property $ do - assocListS <- forAll genAssocListS - key <- forAll $ Gen.integral rangeElem - let assocMap = semanticsToAssocMap assocListS - assocList = semanticsToAssocList assocListS - lookupS key assocListS === AssocMap.lookup key assocMap - lookupS key assocListS === Data.AssocList.lookup key assocList - -memberSpec :: Property -memberSpec = property $ do - assocListS <- forAll genAssocListS - key <- forAll $ Gen.integral rangeElem - let assocMap = semanticsToAssocMap assocListS - assocList = semanticsToAssocList assocListS - memberS key assocListS === AssocMap.member key assocMap - memberS key assocListS === Data.AssocList.member key assocList - -insertSpec :: Property -insertSpec = property $ do - assocListS <- forAll genAssocListS - key <- forAll $ Gen.integral rangeElem - value <- forAll $ Gen.integral rangeElem - let assocMap = semanticsToAssocMap assocListS - assocList = semanticsToAssocList assocListS - insertS key value assocListS ~~ AssocMap.insert key value assocMap - insertS key value assocListS ~~ Data.AssocList.insert key value assocList - -deleteSpec :: Property -deleteSpec = property $ do - assocListS <- forAll genAssocListS - key <- forAll $ Gen.integral rangeElem - let assocMap = semanticsToAssocMap assocListS - assocList = semanticsToAssocList assocListS - deleteS key assocListS ~~ AssocMap.delete key assocMap - deleteS key assocListS ~~ Data.AssocList.delete key assocList - -allSpec :: Property -allSpec = property $ do - assocListS <- forAll genAssocListS - num <- forAll $ Gen.integral rangeElem - let assocMap = semanticsToAssocMap assocListS - assocList = semanticsToAssocList assocListS - predicate x = x < num - allS predicate assocListS === AssocMap.all predicate assocMap - allS predicate assocListS === Data.AssocList.all predicate assocList - -anySpec :: Property -anySpec = property $ do - assocListS <- forAll genAssocListS - num <- forAll $ Gen.integral rangeElem - let assocList = semanticsToAssocList assocListS - predicate x = x < num - anyS predicate assocListS === Data.AssocList.any predicate assocList - -keysSpec :: Property -keysSpec = property $ do - assocListS <- forAll genAssocListS - let assocMap = semanticsToAssocMap assocListS - keysS assocListS === AssocMap.keys assocMap - -unconsSpec :: Property -unconsSpec = property $ do - assocListS <- forAll genAssocListS - let assocList = semanticsToAssocList assocListS - unconsS assocListS `equiv` Data.AssocList.uncons assocList - where - equiv res1 res2 = - res1 === (fmap . fmap) assocListToSemantics res2 - -unsafeUnconsSpec :: Property -unsafeUnconsSpec = property $ do - assocListS <- forAll $ Gen.filter (not . nullS) genAssocListS - let assocList = semanticsToAssocList assocListS - unsafeUnconsS assocListS `equiv` Data.AssocList.unsafeUncons assocList - where - equiv res1 res2 = - res1 === fmap assocListToSemantics res2 - -noDuplicateKeysSpec :: Property -noDuplicateKeysSpec = property $ do - assocListS <- forAll genAssocListS - let assocList = semanticsToAssocList assocListS - noDuplicateKeysS assocListS === Data.AssocList.noDuplicateKeys assocList - -unionSpec :: Property -unionSpec = property $ do - assocListS1 <- forAll genAssocListS - assocListS2 <- forAll genAssocListS - let assocMap1 = semanticsToAssocMap assocListS1 - assocMap2 = semanticsToAssocMap assocListS2 - assocList1 = semanticsToAssocList assocListS1 - assocList2 = semanticsToAssocList assocListS2 - unionS assocListS1 assocListS2 ~~ AssocMap.union assocMap1 assocMap2 - unionS assocListS1 assocListS2 ~~ Data.AssocList.union assocList1 assocList2 - -unionWithSpec :: Property -unionWithSpec = property $ do - assocListS1 <- forAll genAssocListS - assocListS2 <- forAll genAssocListS - let assocMap1 = semanticsToAssocMap assocListS1 - assocMap2 = semanticsToAssocMap assocListS2 - assocList1 = semanticsToAssocList assocListS1 - assocList2 = semanticsToAssocList assocListS2 - merge i1 _ = i1 - unionWithS merge assocListS1 assocListS2 ~~ AssocMap.unionWith merge assocMap1 assocMap2 - unionWithS merge assocListS1 assocListS2 ~~ Data.AssocList.unionWith merge assocList1 assocList2 - -builtinDataEncodingSpec :: Property -builtinDataEncodingSpec = property $ do - assocListS <- forAll genAssocListS - let assocMap = semanticsToAssocMap assocListS - assocList = semanticsToAssocList assocListS - encodedAssocList = P.toBuiltinData assocList - encodedAssocMap = P.toBuiltinData assocMap - mDecodedAssocList :: Maybe (AssocList Integer Integer) - mDecodedAssocList = P.fromBuiltinData encodedAssocList - mDecodedAssocMap :: Maybe (AssocMap.Map Integer Integer) - mDecodedAssocMap = P.fromBuiltinData encodedAssocMap - decodedAssocList :: AssocList Integer Integer - decodedAssocList = P.unsafeFromBuiltinData encodedAssocList - decodedAssocMap :: AssocMap.Map Integer Integer - decodedAssocMap = P.unsafeFromBuiltinData encodedAssocMap - encodedAssocList === encodedAssocMap - assocListS ~~ fromJust mDecodedAssocMap - assocListS ~~ fromJust mDecodedAssocList - assocListS ~~ decodedAssocMap - assocListS ~~ decodedAssocList diff --git a/plutus-tx-plugin/test/AssocMap/Spec.hs b/plutus-tx-plugin/test/AssocMap/Spec.hs new file mode 100644 index 00000000000..385fbda6e36 --- /dev/null +++ b/plutus-tx-plugin/test/AssocMap/Spec.hs @@ -0,0 +1,396 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# 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 #-} +{-# LANGUAGE FlexibleInstances #-} + +module AssocMap.Spec where + +import Test.Tasty.Extras + +import Data.List (nubBy, sort) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromJust) +import Hedgehog (Gen, MonadTest, Property, Range, forAll, property, (===)) +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import PlutusTx.AssocMap qualified as AssocMap +import PlutusTx.Builtins qualified as PlutusTx +import PlutusTx.Code +import PlutusTx.Data.AssocMap qualified as Data.AssocMap +import PlutusTx.IsData () +import PlutusTx.IsData qualified as P +import PlutusTx.Lift (liftCodeDef) +import PlutusTx.Prelude qualified as PlutusTx +import PlutusTx.Show qualified as PlutusTx +import PlutusTx.Test +import PlutusTx.TH (compile) +import PlutusTx.These (These (..)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testProperty) + +goldenTests :: TestNested +goldenTests = + testNestedGhc + "Budget" + [ goldenPirReadable "map1" map1 + , goldenUPlcReadable "map1" map1 + , goldenEvalCekCatch "map1" $ [map1 `unsafeApplyCode` (liftCodeDef 100)] + , goldenBudget "map1-budget" $ map1 `unsafeApplyCode` (liftCodeDef 100) + , goldenPirReadable "map2" map2 + , goldenUPlcReadable "map2" map2 + , goldenEvalCekCatch "map2" $ [map2 `unsafeApplyCode` (liftCodeDef 100)] + , goldenBudget "map2-budget" $ map2 `unsafeApplyCode` (liftCodeDef 100) + ] + +propertyTests :: TestTree +propertyTests = + testGroup "Map property tests" + [ testProperty "safeFromList" safeFromListSpec + , testProperty "unsafeFromList" unsafeFromListSpec + , testProperty "lookup" lookupSpec + , testProperty "member" memberSpec + , testProperty "insert" insertSpec + , testProperty "all" allSpec + , testProperty "any" anySpec + , testProperty "keys" keysSpec + , testProperty "noDuplicateKeys" noDuplicateKeysSpec + , testProperty "delete" deleteSpec + , testProperty "union" unionSpec + , testProperty "unionWith" unionWithSpec + , testProperty "builtinDataEncoding" builtinDataEncodingSpec + ] + +map1 :: + CompiledCode + ( Integer -> + ( Maybe PlutusTx.BuiltinByteString + , Maybe PlutusTx.BuiltinByteString + , Maybe PlutusTx.BuiltinByteString + , Maybe PlutusTx.BuiltinByteString + , Maybe PlutusTx.BuiltinByteString + ) + ) +map1 = + $$( compile + [|| + \n -> + let m :: Data.AssocMap.Map Integer PlutusTx.BuiltinByteString + m = + foldr + (\i -> + Data.AssocMap.insert + (n PlutusTx.+ i) + (PlutusTx.encodeUtf8 (PlutusTx.show i)) + ) + (Data.AssocMap.singleton n "0") + (PlutusTx.enumFromTo 1 10) + m' = Data.AssocMap.delete (n PlutusTx.+ 5) m + in ( Data.AssocMap.lookup n m + , Data.AssocMap.lookup (n PlutusTx.+ 5) m + , Data.AssocMap.lookup (n PlutusTx.+ 10) m + , Data.AssocMap.lookup (n PlutusTx.+ 20) m + , Data.AssocMap.lookup (n PlutusTx.+ 5) m' + ) + ||] + ) + +map2 :: CompiledCode (Integer -> [(Integer, PlutusTx.BuiltinString)]) +map2 = + $$( compile + [|| + \n -> + let m1 = + Data.AssocMap.unsafeFromList + [ (n PlutusTx.+ 1, "one") + , (n PlutusTx.+ 2, "two") + , (n PlutusTx.+ 3, "three") + , (n PlutusTx.+ 4, "four") + , (n PlutusTx.+ 5, "five") + ] + m2 = + Data.AssocMap.unsafeFromList + [ (n PlutusTx.+ 3, "THREE") + , (n PlutusTx.+ 4, "FOUR") + , (n PlutusTx.+ 6, "SIX") + , (n PlutusTx.+ 7, "SEVEN") + ] + m = Data.AssocMap.unionWith PlutusTx.appendByteString m1 m2 + in PlutusTx.fmap (\(k, v) -> (k, PlutusTx.decodeUtf8 v)) (Data.AssocMap.toList m) + ||] + ) + +-- | The semantics of PlutusTx maps and their operations. +-- The 'PlutusTx' implementations maps ('Data.AssocMap.Map' and 'AssocMap.Map') +-- are checked against the semantics to ensure correctness. +newtype AssocMapS k v = AssocMapS [(k, v)] + deriving stock (Show, Eq) + +semanticsToAssocMap :: AssocMapS k v -> AssocMap.Map k v +semanticsToAssocMap = AssocMap.unsafeFromList . toListS + +semanticsToDataAssocMap + :: (P.ToData k, P.ToData v) + => AssocMapS k v -> Data.AssocMap.Map k v +semanticsToDataAssocMap = Data.AssocMap.unsafeFromList . toListS + +assocMapToSemantics :: AssocMap.Map k v -> AssocMapS k v +assocMapToSemantics = unsafeFromListS . AssocMap.toList + +dataAssocMapToSemantics + :: (P.UnsafeFromData k, P.UnsafeFromData v) + => Data.AssocMap.Map k v -> AssocMapS k v +dataAssocMapToSemantics = unsafeFromListS . Data.AssocMap.toList + +nullS :: AssocMapS k v -> Bool +nullS (AssocMapS l) = null l + +sortS :: (Ord k, Ord v) => AssocMapS k v -> AssocMapS k v +sortS (AssocMapS l) = AssocMapS $ sort l + +toListS :: AssocMapS k v -> [(k, v)] +toListS (AssocMapS l) = l + +unsafeFromListS :: [(k, v)] -> AssocMapS k v +unsafeFromListS = AssocMapS + +safeFromListS :: Ord k => [(k, v)] -> AssocMapS k v +safeFromListS = AssocMapS . Map.toList . Map.fromList + +lookupS :: Integer -> AssocMapS Integer Integer -> Maybe Integer +lookupS k (AssocMapS l) = Map.lookup k . Map.fromList $ l + +memberS :: Integer -> AssocMapS Integer Integer -> Bool +memberS k (AssocMapS l) = Map.member k . Map.fromList $ l + +insertS :: Integer -> Integer -> AssocMapS Integer Integer -> AssocMapS Integer Integer +insertS k v (AssocMapS l) = + AssocMapS . Map.toList . Map.insert k v . Map.fromList $ l + +deleteS :: Integer -> AssocMapS Integer Integer -> AssocMapS Integer Integer +deleteS k (AssocMapS l) = + AssocMapS . Map.toList . Map.delete k . Map.fromList $ l + +allS :: (Integer -> Bool) -> AssocMapS Integer Integer -> Bool +allS p (AssocMapS l) = all (p . snd) l + +anyS :: (Integer -> Bool) -> AssocMapS Integer Integer -> Bool +anyS p (AssocMapS l) = any (p . snd) l + +keysS :: AssocMapS Integer Integer -> [Integer] +keysS (AssocMapS l) = map fst l + +noDuplicateKeysS :: AssocMapS Integer Integer -> Bool +noDuplicateKeysS (AssocMapS l) = + length l == length (nubBy (\(k1, _) (k2, _) -> k1 == k2) l) + +-- | The semantics of 'union' is based on the 'AssocMap' implementation. +-- The code is duplicated here to avoid any issues if the 'AssocMap' implementation changes. +unionS + :: AssocMapS Integer Integer + -> AssocMapS Integer Integer + -> AssocMapS Integer (These Integer Integer) +unionS (AssocMapS ls) (AssocMapS rs) = + let + f a b' = case b' of + Nothing -> This a + Just b -> These a b + + ls' = fmap (\(c, i) -> (c, f i (lookupS c (AssocMapS rs)))) ls + + -- Keeps only those keys which don't appear in the left map. + rs' = filter (\(c, _) -> not (any (\(c', _) -> c' == c) ls)) rs + + rs'' = fmap (fmap That) rs' + in + AssocMapS (ls' ++ rs'') + +unionWithS + :: (Integer -> Integer -> Integer) + -> AssocMapS Integer Integer + -> AssocMapS Integer Integer + -> AssocMapS Integer Integer +unionWithS merge (AssocMapS ls) (AssocMapS rs) = + AssocMapS + . Map.toList + $ Map.unionWith merge (Map.fromList ls) (Map.fromList rs) + +genAssocMapS :: Gen (AssocMapS Integer Integer) +genAssocMapS = + AssocMapS . Map.toList <$> Gen.map rangeLength genPair + where + genPair :: Gen (Integer, Integer) + genPair = do + (,) <$> Gen.integral rangeElem <*> Gen.integral rangeElem + +genUnsafeAssocMapS :: Gen (AssocMapS Integer Integer) +genUnsafeAssocMapS = do + AssocMapS <$> Gen.list rangeLength genPair + where + genPair :: Gen (Integer, Integer) + genPair = do + (,) <$> Gen.integral rangeElem <*> Gen.integral rangeElem + +-- | The 'Equivalence' class is used to define an equivalence relation +-- between `AssocMapS` and the 'PlutusTx' implementations. +class Equivalence l where + (~~) :: + ( MonadTest m + , Show k + , Show v + , Ord k + , Ord v + , P.UnsafeFromData k + , P.UnsafeFromData v + ) => AssocMapS k v -> l k v -> m () + +-- | An `AssocMap.Map` is equivalent to an `AssocMapS` if they have the same elements. +instance Equivalence AssocMap.Map where + assocMapS ~~ assocMap = + sortS assocMapS === sortS (assocMapToSemantics assocMap) + +-- | An `Data.AssocMap.Map` is equivalent to an `AssocMapS` if they have the same elements. +instance Equivalence Data.AssocMap.Map where + assocMapS ~~ dataAssocMap = + sortS assocMapS === sortS (dataAssocMapToSemantics dataAssocMap) + +rangeElem :: Range Integer +rangeElem = Range.linear 0 100 + +rangeLength :: Range Int +rangeLength = Range.linear 0 100 + +safeFromListSpec :: Property +safeFromListSpec = property $ do + assocMapS <- forAll genAssocMapS + let assocMap = AssocMap.safeFromList . toListS $ assocMapS + dataAssocMap = Data.AssocMap.safeFromList . toListS $ assocMapS + assocMapS ~~ assocMap + assocMapS ~~ dataAssocMap + +unsafeFromListSpec :: Property +unsafeFromListSpec = property $ do + assocMapS <- forAll genAssocMapS + let assocMap = AssocMap.unsafeFromList . toListS $ assocMapS + dataAssocMap = Data.AssocMap.unsafeFromList . toListS $ assocMapS + assocMapS ~~ assocMap + assocMapS ~~ dataAssocMap + +lookupSpec :: Property +lookupSpec = property $ do + assocMapS <- forAll genAssocMapS + key <- forAll $ Gen.integral rangeElem + let assocMap = semanticsToAssocMap assocMapS + dataAssocMap = semanticsToDataAssocMap assocMapS + lookupS key assocMapS === AssocMap.lookup key assocMap + lookupS key assocMapS === Data.AssocMap.lookup key dataAssocMap + +memberSpec :: Property +memberSpec = property $ do + assocMapS <- forAll genAssocMapS + key <- forAll $ Gen.integral rangeElem + let assocMap = semanticsToAssocMap assocMapS + dataAssocMap = semanticsToDataAssocMap assocMapS + memberS key assocMapS === AssocMap.member key assocMap + memberS key assocMapS === Data.AssocMap.member key dataAssocMap + +insertSpec :: Property +insertSpec = property $ do + assocMapS <- forAll genAssocMapS + key <- forAll $ Gen.integral rangeElem + value <- forAll $ Gen.integral rangeElem + let assocMap = semanticsToAssocMap assocMapS + dataAssocMap = semanticsToDataAssocMap assocMapS + insertS key value assocMapS ~~ AssocMap.insert key value assocMap + insertS key value assocMapS ~~ Data.AssocMap.insert key value dataAssocMap + +deleteSpec :: Property +deleteSpec = property $ do + assocMapS <- forAll genAssocMapS + key <- forAll $ Gen.integral rangeElem + let assocMap = semanticsToAssocMap assocMapS + dataAssocMap = semanticsToDataAssocMap assocMapS + deleteS key assocMapS ~~ AssocMap.delete key assocMap + deleteS key assocMapS ~~ Data.AssocMap.delete key dataAssocMap + +allSpec :: Property +allSpec = property $ do + assocMapS <- forAll genAssocMapS + num <- forAll $ Gen.integral rangeElem + let assocMap = semanticsToAssocMap assocMapS + dataAssocMap = semanticsToDataAssocMap assocMapS + predicate x = x < num + allS predicate assocMapS === AssocMap.all predicate assocMap + allS predicate assocMapS === Data.AssocMap.all predicate dataAssocMap + +anySpec :: Property +anySpec = property $ do + assocMapS <- forAll genAssocMapS + num <- forAll $ Gen.integral rangeElem + let dataAssocMap = semanticsToDataAssocMap assocMapS + predicate x = x < num + anyS predicate assocMapS === Data.AssocMap.any predicate dataAssocMap + +keysSpec :: Property +keysSpec = property $ do + assocMapS <- forAll genAssocMapS + let assocMap = semanticsToAssocMap assocMapS + keysS assocMapS === AssocMap.keys assocMap + +noDuplicateKeysSpec :: Property +noDuplicateKeysSpec = property $ do + assocMapS <- forAll genAssocMapS + let dataAssocMap = semanticsToDataAssocMap assocMapS + noDuplicateKeysS assocMapS === Data.AssocMap.noDuplicateKeys dataAssocMap + +unionSpec :: Property +unionSpec = property $ do + assocMapS1 <- forAll genAssocMapS + assocMapS2 <- forAll genAssocMapS + let assocMap1 = semanticsToAssocMap assocMapS1 + assocMap2 = semanticsToAssocMap assocMapS2 + dataAssocMap1 = semanticsToDataAssocMap assocMapS1 + dataAssocMap2 = semanticsToDataAssocMap assocMapS2 + unionS assocMapS1 assocMapS2 ~~ AssocMap.union assocMap1 assocMap2 + unionS assocMapS1 assocMapS2 ~~ Data.AssocMap.union dataAssocMap1 dataAssocMap2 + +unionWithSpec :: Property +unionWithSpec = property $ do + assocMapS1 <- forAll genAssocMapS + assocMapS2 <- forAll genAssocMapS + let assocMap1 = semanticsToAssocMap assocMapS1 + assocMap2 = semanticsToAssocMap assocMapS2 + dataAssocMap1 = semanticsToDataAssocMap assocMapS1 + dataAssocMap2 = semanticsToDataAssocMap assocMapS2 + merge i1 _ = i1 + unionWithS merge assocMapS1 assocMapS2 ~~ AssocMap.unionWith merge assocMap1 assocMap2 + unionWithS merge assocMapS1 assocMapS2 + ~~ Data.AssocMap.unionWith merge dataAssocMap1 dataAssocMap2 + +builtinDataEncodingSpec :: Property +builtinDataEncodingSpec = property $ do + assocMapS <- forAll genAssocMapS + let assocMap = semanticsToAssocMap assocMapS + dataAssocMap = semanticsToDataAssocMap assocMapS + encodedDataAssocMap = P.toBuiltinData dataAssocMap + encodedAssocMap = P.toBuiltinData assocMap + mDecodedDataAssocMap :: Maybe (Data.AssocMap.Map Integer Integer) + mDecodedDataAssocMap = P.fromBuiltinData encodedDataAssocMap + mDecodedAssocMap :: Maybe (AssocMap.Map Integer Integer) + mDecodedAssocMap = P.fromBuiltinData encodedAssocMap + decodedDataAssocMap :: Data.AssocMap.Map Integer Integer + decodedDataAssocMap = P.unsafeFromBuiltinData encodedDataAssocMap + decodedAssocMap :: AssocMap.Map Integer Integer + decodedAssocMap = P.unsafeFromBuiltinData encodedAssocMap + encodedDataAssocMap === encodedAssocMap + assocMapS ~~ fromJust mDecodedAssocMap + assocMapS ~~ fromJust mDecodedDataAssocMap + assocMapS ~~ decodedAssocMap + assocMapS ~~ decodedDataAssocMap diff --git a/plutus-tx-plugin/test/Spec.hs b/plutus-tx-plugin/test/Spec.hs index b57eede5322..85228a20758 100644 --- a/plutus-tx-plugin/test/Spec.hs +++ b/plutus-tx-plugin/test/Spec.hs @@ -1,7 +1,7 @@ module Main (main) where import AsData.Budget.Spec qualified as AsData.Budget -import AssocList.Spec qualified as AssocList +import AssocMap.Spec qualified as AssocMap import Blueprint.Tests qualified import Budget.Spec qualified as Budget import IntegerLiterals.NoStrict.NegativeLiterals.Spec qualified @@ -21,7 +21,7 @@ import TH.Spec qualified as TH import Unicode.Spec qualified as Unicode main :: IO () -main = defaultMain $ testGroup "" [runTestNestedIn ["test"] tests, AssocList.propertyTests] +main = defaultMain $ testGroup "" [runTestNestedIn ["test"] tests, AssocMap.propertyTests] tests :: TestNested tests = @@ -43,5 +43,5 @@ tests = , Strictness.tests , Blueprint.Tests.goldenTests , pure Unicode.tests - , AssocList.goldenTests + , AssocMap.goldenTests ] diff --git a/plutus-tx/plutus-tx.cabal b/plutus-tx/plutus-tx.cabal index 864b6073193..554881b1484 100644 --- a/plutus-tx/plutus-tx.cabal +++ b/plutus-tx/plutus-tx.cabal @@ -74,7 +74,7 @@ library PlutusTx.Builtins.Internal PlutusTx.Code PlutusTx.Coverage - PlutusTx.Data.AssocList + PlutusTx.Data.AssocMap PlutusTx.Either PlutusTx.Enum PlutusTx.Eq diff --git a/plutus-tx/src/PlutusTx/Data/AssocList.hs b/plutus-tx/src/PlutusTx/Data/AssocMap.hs similarity index 71% rename from plutus-tx/src/PlutusTx/Data/AssocList.hs rename to plutus-tx/src/PlutusTx/Data/AssocMap.hs index 8f750d419f9..41dafe2deb2 100644 --- a/plutus-tx/src/PlutusTx/Data/AssocList.hs +++ b/plutus-tx/src/PlutusTx/Data/AssocMap.hs @@ -3,8 +3,8 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ViewPatterns #-} -module PlutusTx.Data.AssocList ( - AssocList, +module PlutusTx.Data.AssocMap ( + Map, lookup, member, insert, @@ -17,8 +17,6 @@ module PlutusTx.Data.AssocList ( safeFromList, unsafeFromList, unsafeFromBuiltinList, - uncons, - unsafeUncons, noDuplicateKeys, all, any, @@ -34,7 +32,7 @@ import PlutusTx.These import Prelude qualified as Haskell -{- | A list associating keys and values backed by `P.BuiltinData`. +{- | A map associating keys and values backed by `P.BuiltinData`. This implementation has the following characteristics: @@ -48,30 +46,33 @@ if it is part of a data type defined using @asData@, and the key and value types have efficient `P.toBuiltinData` and `P.unsafeFromBuiltinData` operations (e.g., they are primitive types or types defined using @asData@). -An `AssocList` is considered well-defined if it has no duplicate keys. Most operations -preserve the definedness of the resulting `AssocList` unless otherwise noted. +An `Map` is considered well-defined if it has no duplicate keys. Most operations +preserve the definedness of the resulting `Map` unless otherwise noted. +It is important to observe that, in comparison to standard map implementations, +this implementation provides slow lookup and update operations. -} -newtype AssocList k a = AssocList P.BuiltinData +newtype Map k a = Map P.BuiltinData deriving stock (Haskell.Eq, Haskell.Show) deriving newtype (Eq) -instance P.ToData (AssocList k a) where +instance P.ToData (Map k a) where {-# INLINEABLE toBuiltinData #-} - toBuiltinData (AssocList d) = d + toBuiltinData (Map d) = d -instance P.FromData (AssocList k a) where +instance P.FromData (Map k a) where {-# INLINABLE fromBuiltinData #-} - fromBuiltinData = Just . AssocList + fromBuiltinData = Just . Map -instance P.UnsafeFromData (AssocList k a) where +instance P.UnsafeFromData (Map k a) where {-# INLINABLE unsafeFromBuiltinData #-} - unsafeFromBuiltinData = AssocList + unsafeFromBuiltinData = Map {-# INLINEABLE lookup #-} -- | Look up the value corresponding to the key. --- If the `AssocList` is not well-defined, the result is the value associated with +-- If the `Map` is not well-defined, the result is the value associated with -- the left-most occurrence of the key in the list. -lookup :: forall k a. (P.ToData k, P.UnsafeFromData a) => k -> AssocList k a -> Maybe a +-- This operation is O(n). +lookup :: forall k a. (P.ToData k, P.UnsafeFromData a) => k -> Map k a -> Maybe a lookup (P.toBuiltinData -> k) m = case lookup' k (toBuiltinList m) of Just a -> Just (P.unsafeFromBuiltinData a) Nothing -> Nothing @@ -96,8 +97,8 @@ lookup' k = go ) {-# INLINEABLE member #-} --- | Check if the key is in the `AssocList`. -member :: forall k a. (P.ToData k) => k -> AssocList k a -> Bool +-- | Check if the key is in the `Map`. +member :: forall k a. (P.ToData k) => k -> Map k a -> Bool member (P.toBuiltinData -> k) m = member' k (toBuiltinList m) {-# INLINEABLE member' #-} @@ -118,9 +119,9 @@ member' k = go ) {-# INLINEABLE insert #-} --- | Insert a key-value pair into the `AssocList`. If the key is already present, +-- | Insert a key-value pair into the `Map`. If the key is already present, -- the value is updated. -insert :: forall k a. (P.ToData k, P.ToData a) => k -> a -> AssocList k a -> AssocList k a +insert :: forall k a. (P.ToData k, P.ToData a) => k -> a -> Map k a -> Map k a insert (P.toBuiltinData -> k) (P.toBuiltinData -> a) m = unsafeFromBuiltinList $ insert' k a (toBuiltinList m) @@ -148,10 +149,10 @@ insert' (P.toBuiltinData -> k) (P.toBuiltinData -> a) = go ) {-# INLINEABLE delete #-} --- | Delete a key value pair from the `AssocList`. --- If the `AssocList` is not well-defined, it deletes the pair associated with the +-- | Delete a key value pair from the `Map`. +-- If the `Map` is not well-defined, it deletes the pair associated with the -- left-most occurrence of the key in the list. -delete :: forall k a. (P.ToData k) => k -> AssocList k a -> AssocList k a +delete :: forall k a. (P.ToData k) => k -> Map k a -> Map k a delete (P.toBuiltinData -> k) m = unsafeFromBuiltinList (go (toBuiltinList m)) where go :: @@ -169,27 +170,27 @@ delete (P.toBuiltinData -> k) m = unsafeFromBuiltinList (go (toBuiltinList m)) ) {-# INLINEABLE singleton #-} --- | Create an `AssocList` with a single key-value pair. -singleton :: forall k a. (P.ToData k, P.ToData a) => k -> a -> AssocList k a +-- | Create an `Map` with a single key-value pair. +singleton :: forall k a. (P.ToData k, P.ToData a) => k -> a -> Map k a singleton (P.toBuiltinData -> k) (P.toBuiltinData -> a) = unsafeFromBuiltinList xs where xs = BI.mkCons (BI.mkPairData k a) nil {-# INLINEABLE empty #-} --- | An empty `AssocList`. -empty :: forall k a. AssocList k a +-- | An empty `Map`. +empty :: forall k a. Map k a empty = unsafeFromBuiltinList nil {-# INLINEABLE null #-} --- | Check if the `AssocList` is empty. -null :: forall k a. AssocList k a -> Bool +-- | Check if the `Map` is empty. +null :: forall k a. Map k a -> Bool null = P.null . toBuiltinList {-# INLINEABLE safeFromList #-} --- | Create an `AssocList` from a list of key-value pairs. +-- | 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 . (Eq k, P.ToData k, P.ToData a) => [(k, a)] -> AssocList k a +safeFromList :: forall k a . (Eq k, P.ToData k, P.ToData a) => [(k, a)] -> Map k a safeFromList = unsafeFromBuiltinList . toBuiltin @@ -204,46 +205,19 @@ safeFromList = else (k', v') : go k v rest {-# INLINEABLE unsafeFromList #-} --- | Unsafely create an 'AssocList' from a list of pairs. +-- | Unsafely create an 'Map' from a list of pairs. -- This should _only_ be applied to lists which have been checked to not --- contain duplicate keys, otherwise the resulting 'AssocList' will contain +-- contain duplicate keys, otherwise the resulting 'Map' will contain -- conflicting entries (two entries sharing the same key), and therefore be ill-defined. -unsafeFromList :: (P.ToData k, P.ToData a) => [(k, a)] -> AssocList k a +unsafeFromList :: (P.ToData k, P.ToData a) => [(k, a)] -> Map k a unsafeFromList = unsafeFromBuiltinList . toBuiltin . PlutusTx.Prelude.map (\(k, a) -> (P.toBuiltinData k, P.toBuiltinData a)) -{-# INLINEABLE uncons #-} --- | Decompose an 'AssocList' into its first key-value pair and the rest of the list. -uncons :: - forall k a. - (P.UnsafeFromData k, P.UnsafeFromData a) => - AssocList k a -> - Maybe ((k, a), AssocList k a) -uncons m = case P.uncons (toBuiltinList m) of - Nothing -> Nothing - Just (pair, rest) -> - let (k, a) = P.pairToPair pair - in Just ((P.unsafeFromBuiltinData k, P.unsafeFromBuiltinData a), unsafeFromBuiltinList rest) - -{-# INLINEABLE unsafeUncons #-} --- | Decompose an 'AssocList' into its first key-value pair and the rest of the list. --- This function is unsafe because it assumes that the `AssocList` is not empty. -unsafeUncons :: - forall k a. - (P.UnsafeFromData k, P.UnsafeFromData a) => - AssocList k a -> - ((k, a), AssocList k a) -unsafeUncons m = - ((P.unsafeFromBuiltinData k, P.unsafeFromBuiltinData a), unsafeFromBuiltinList tl) - where - (hd, tl) = P.unsafeUncons (toBuiltinList m) - (k, a) = P.pairToPair hd - {-# INLINEABLE noDuplicateKeys #-} --- | Check if the `AssocList` is well-defined. Warning: this operation is O(n^2). -noDuplicateKeys :: forall k a. AssocList k a -> Bool +-- | Check if the `Map` is well-defined. Warning: this operation is O(n^2). +noDuplicateKeys :: forall k a. Map k a -> Bool noDuplicateKeys m = go (toBuiltinList m) where go :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> Bool @@ -257,8 +231,8 @@ noDuplicateKeys m = go (toBuiltinList m) ) {-# INLINEABLE all #-} ---- | Check if all values in the `AssocList` satisfy the predicate. -all :: forall k a. (P.UnsafeFromData a) => (a -> Bool) -> AssocList k a -> Bool +--- | Check if all values in the `Map` satisfy the predicate. +all :: forall k a. (P.UnsafeFromData a) => (a -> Bool) -> Map k a -> Bool all p m = go (toBuiltinList m) where go :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> Bool @@ -272,8 +246,8 @@ all p m = go (toBuiltinList m) ) {-# INLINEABLE any #-} --- | Check if any value in the `AssocList` satisfies the predicate. -any :: forall k a. (P.UnsafeFromData a) => (a -> Bool) -> AssocList k a -> Bool +-- | Check if any value in the `Map` satisfies the predicate. +any :: forall k a. (P.UnsafeFromData a) => (a -> Bool) -> Map k a -> Bool any p m = go (toBuiltinList m) where go :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> Bool @@ -288,13 +262,13 @@ any p m = go (toBuiltinList m) {-# INLINEABLE union #-} --- | Combine two 'AssocList's into one. It saves both values if the key is present in both lists. +-- | Combine two 'Map's into one. It saves both values if the key is present in both maps. union :: forall k a b. (P.UnsafeFromData a, P.UnsafeFromData b, P.ToData a, P.ToData b) => - AssocList k a -> - AssocList k b -> - AssocList k (These a b) + Map k a -> + Map k b -> + Map k (These a b) union (toBuiltinList -> ls) (toBuiltinList -> rs) = unsafeFromBuiltinList res where goLeft xs = @@ -349,14 +323,14 @@ union (toBuiltinList -> ls) (toBuiltinList -> rs) = unsafeFromBuiltinList res in insert' k v (safeAppend tl xs2) ) --- | Combine two 'AssocList's with the given combination function. +-- | Combine two 'Map's with the given combination function. unionWith :: forall k a. (P.UnsafeFromData a, P.ToData a) => (a -> a -> a) -> - AssocList k a -> - AssocList k a -> - AssocList k a + Map k a -> + Map k a -> + Map k a unionWith f (toBuiltinList -> ls) (toBuiltinList -> rs) = unsafeFromBuiltinList res where @@ -403,9 +377,9 @@ unionWith f (toBuiltinList -> ls) (toBuiltinList -> rs) = (\hd -> go (BI.mkCons hd acc)) {-# INLINEABLE toList #-} --- | Convert the `AssocList` to a list of key-value pairs. This operation is O(n). +-- | Convert the `Map` to a list of key-value pairs. This operation is O(n). -- See 'toBuiltinList' for a more efficient alternative. -toList :: (P.UnsafeFromData k, P.UnsafeFromData a) => AssocList k a -> [(k, a)] +toList :: (P.UnsafeFromData k, P.UnsafeFromData a) => Map k a -> [(k, a)] toList d = go (toBuiltinList d) where go xs = @@ -418,19 +392,19 @@ toList d = go (toBuiltinList d) ) {-# INLINEABLE toBuiltinList #-} --- | Convert the `AssocList` to a `P.BuiltinList` of key-value pairs. This operation is O(1). -toBuiltinList :: AssocList k a -> BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -toBuiltinList (AssocList d) = BI.unsafeDataAsMap d +-- | Convert the `Map` to a `P.BuiltinList` of key-value pairs. This operation is O(1). +toBuiltinList :: Map k a -> BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) +toBuiltinList (Map d) = BI.unsafeDataAsMap d {-# INLINEABLE unsafeFromBuiltinList #-} --- | Unsafely create an 'AssocList' from a `P.BuiltinList` of key-value pairs. +-- | Unsafely create an 'Map' from a `P.BuiltinList` of key-value pairs. -- This function is unsafe because it assumes that the elements of the list can be safely -- decoded from their 'BuiltinData' representation. unsafeFromBuiltinList :: forall k a. BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> - AssocList k a -unsafeFromBuiltinList = AssocList . BI.mkMap + Map k a +unsafeFromBuiltinList = Map . BI.mkMap {-# INLINEABLE nil #-} -- | An empty `P.BuiltinList` of key-value pairs. From 0b51d913eeeeeda5db9bcb9ee585fbc42b19792a Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Tue, 7 May 2024 16:48:56 +0300 Subject: [PATCH 13/41] Make Map newtype over BuiltinList Pair Signed-off-by: Ana Pantilie --- plutus-tx/src/PlutusTx/Data/AssocMap.hs | 82 +++++++++---------------- 1 file changed, 28 insertions(+), 54 deletions(-) diff --git a/plutus-tx/src/PlutusTx/Data/AssocMap.hs b/plutus-tx/src/PlutusTx/Data/AssocMap.hs index 41dafe2deb2..d5bd7b84c4d 100644 --- a/plutus-tx/src/PlutusTx/Data/AssocMap.hs +++ b/plutus-tx/src/PlutusTx/Data/AssocMap.hs @@ -46,26 +46,25 @@ if it is part of a data type defined using @asData@, and the key and value types have efficient `P.toBuiltinData` and `P.unsafeFromBuiltinData` operations (e.g., they are primitive types or types defined using @asData@). -An `Map` is considered well-defined if it has no duplicate keys. Most operations +A `Map` is considered well-defined if it has no duplicate keys. Most operations preserve the definedness of the resulting `Map` unless otherwise noted. It is important to observe that, in comparison to standard map implementations, this implementation provides slow lookup and update operations. -} -newtype Map k a = Map P.BuiltinData +newtype Map k a = Map (BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData)) deriving stock (Haskell.Eq, Haskell.Show) - deriving newtype (Eq) instance P.ToData (Map k a) where {-# INLINEABLE toBuiltinData #-} - toBuiltinData (Map d) = d + toBuiltinData (Map d) = BI.mkMap d instance P.FromData (Map k a) where {-# INLINABLE fromBuiltinData #-} - fromBuiltinData = Just . Map + fromBuiltinData = Just . Map . BI.unsafeDataAsMap instance P.UnsafeFromData (Map k a) where {-# INLINABLE unsafeFromBuiltinData #-} - unsafeFromBuiltinData = Map + unsafeFromBuiltinData = Map . BI.unsafeDataAsMap {-# INLINEABLE lookup #-} -- | Look up the value corresponding to the key. @@ -73,17 +72,7 @@ instance P.UnsafeFromData (Map k a) where -- the left-most occurrence of the key in the list. -- This operation is O(n). lookup :: forall k a. (P.ToData k, P.UnsafeFromData a) => k -> Map k a -> Maybe a -lookup (P.toBuiltinData -> k) m = case lookup' k (toBuiltinList m) of - Just a -> Just (P.unsafeFromBuiltinData a) - Nothing -> Nothing - -{-# INLINEABLE lookup' #-} --- | Similar to 'lookup', but operates on the underlying `BuiltinList` representation. -lookup' :: - BuiltinData -> - BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> - Maybe BuiltinData -lookup' k = go +lookup (P.toBuiltinData -> k) (Map m) = P.unsafeFromBuiltinData <$> go m where go xs = P.matchList @@ -99,12 +88,7 @@ lookup' k = go {-# INLINEABLE member #-} -- | Check if the key is in the `Map`. member :: forall k a. (P.ToData k) => k -> Map k a -> Bool -member (P.toBuiltinData -> k) m = member' k (toBuiltinList m) - -{-# INLINEABLE member' #-} --- | Similar to 'member', but operates on the underlying `BuiltinList` representation. -member' :: BuiltinData -> BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> Bool -member' k = go +member (P.toBuiltinData -> k) (Map m) = go m where go :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> Bool go xs = @@ -122,17 +106,7 @@ member' k = go -- | Insert a key-value pair into the `Map`. If the key is already present, -- the value is updated. insert :: forall k a. (P.ToData k, P.ToData a) => k -> a -> Map k a -> Map k a -insert (P.toBuiltinData -> k) (P.toBuiltinData -> a) m = - unsafeFromBuiltinList $ insert' k a (toBuiltinList m) - -{-# INLINEABLE insert' #-} --- | Similar to 'insert', but operates on the underlying `BuiltinList` representation. -insert' - :: BuiltinData - -> BuiltinData - -> BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) - -> BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -insert' (P.toBuiltinData -> k) (P.toBuiltinData -> a) = go +insert (P.toBuiltinData -> k) (P.toBuiltinData -> a) (Map m) = Map $ go m where go :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> @@ -153,7 +127,7 @@ insert' (P.toBuiltinData -> k) (P.toBuiltinData -> a) = go -- If the `Map` is not well-defined, it deletes the pair associated with the -- left-most occurrence of the key in the list. delete :: forall k a. (P.ToData k) => k -> Map k a -> Map k a -delete (P.toBuiltinData -> k) m = unsafeFromBuiltinList (go (toBuiltinList m)) +delete (P.toBuiltinData -> k) (Map m) = Map $ go m where go :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> @@ -172,19 +146,18 @@ delete (P.toBuiltinData -> k) m = unsafeFromBuiltinList (go (toBuiltinList m)) {-# INLINEABLE singleton #-} -- | Create an `Map` with a single key-value pair. singleton :: forall k a. (P.ToData k, P.ToData a) => k -> a -> Map k a -singleton (P.toBuiltinData -> k) (P.toBuiltinData -> a) = unsafeFromBuiltinList xs - where - xs = BI.mkCons (BI.mkPairData k a) nil +singleton (P.toBuiltinData -> k) (P.toBuiltinData -> a) = + Map $ BI.mkCons (BI.mkPairData k a) nil {-# INLINEABLE empty #-} -- | An empty `Map`. empty :: forall k a. Map k a -empty = unsafeFromBuiltinList nil +empty = Map nil {-# INLINEABLE null #-} -- | Check if the `Map` is empty. null :: forall k a. Map k a -> Bool -null = P.null . toBuiltinList +null (Map m) = P.null m {-# INLINEABLE safeFromList #-} -- | Create an `Map` from a list of key-value pairs. @@ -192,7 +165,7 @@ null = P.null . toBuiltinList -- In other words, this function de-duplicates the input list. safeFromList :: forall k a . (Eq k, P.ToData k, P.ToData a) => [(k, a)] -> Map k a safeFromList = - unsafeFromBuiltinList + Map . toBuiltin . PlutusTx.Prelude.map (\(k, a) -> (P.toBuiltinData k, P.toBuiltinData a)) . foldr (uncurry go) [] @@ -211,14 +184,14 @@ safeFromList = -- conflicting entries (two entries sharing the same key), and therefore be ill-defined. unsafeFromList :: (P.ToData k, P.ToData a) => [(k, a)] -> Map k a unsafeFromList = - unsafeFromBuiltinList + Map . toBuiltin . PlutusTx.Prelude.map (\(k, a) -> (P.toBuiltinData k, P.toBuiltinData a)) {-# INLINEABLE noDuplicateKeys #-} -- | Check if the `Map` is well-defined. Warning: this operation is O(n^2). noDuplicateKeys :: forall k a. Map k a -> Bool -noDuplicateKeys m = go (toBuiltinList m) +noDuplicateKeys (Map m) = go m where go :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> Bool go xs = @@ -227,13 +200,13 @@ noDuplicateKeys m = go (toBuiltinList m) True ( \hd tl -> let k = BI.fst hd - in if member' k tl then False else go tl + in if member k (Map tl) then False else go tl ) {-# INLINEABLE all #-} --- | Check if all values in the `Map` satisfy the predicate. all :: forall k a. (P.UnsafeFromData a) => (a -> Bool) -> Map k a -> Bool -all p m = go (toBuiltinList m) +all p (Map m) = go m where go :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> Bool go xs = @@ -248,7 +221,7 @@ all p m = go (toBuiltinList m) {-# INLINEABLE any #-} -- | Check if any value in the `Map` satisfies the predicate. any :: forall k a. (P.UnsafeFromData a) => (a -> Bool) -> Map k a -> Bool -any p m = go (toBuiltinList m) +any p (Map m) = go m where go :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> Bool go xs = @@ -269,7 +242,7 @@ union :: Map k a -> Map k b -> Map k (These a b) -union (toBuiltinList -> ls) (toBuiltinList -> rs) = unsafeFromBuiltinList res +union (Map ls) (Map rs) = Map res where goLeft xs = P.matchList @@ -278,7 +251,7 @@ union (toBuiltinList -> ls) (toBuiltinList -> rs) = unsafeFromBuiltinList res ( \hd tl -> let k = BI.fst hd v = BI.snd hd - v' = case lookup' k rs of + v' = case lookup k (Map rs) of Just r -> P.toBuiltinData ( These @@ -298,7 +271,7 @@ union (toBuiltinList -> ls) (toBuiltinList -> rs) = unsafeFromBuiltinList res ( \hd tl -> let k = BI.fst hd v = BI.snd hd - v' = case lookup' k ls of + v' = case lookup k (Map ls) of Just r -> P.toBuiltinData ( These @@ -320,7 +293,8 @@ union (toBuiltinList -> ls) (toBuiltinList -> rs) = unsafeFromBuiltinList res ( \hd tl -> let k = BI.fst hd v = BI.snd hd - in insert' k v (safeAppend tl xs2) + Map res' = insert k v (Map $ safeAppend tl xs2) + in res' ) -- | Combine two 'Map's with the given combination function. @@ -344,7 +318,7 @@ unionWith f (toBuiltinList -> ls) (toBuiltinList -> rs) = ( \hd tl -> let k' = BI.fst hd v' = BI.snd hd - v'' = case lookup' k' rs of + v'' = case lookup k' (Map rs) of Just r -> P.toBuiltinData (f (P.unsafeFromBuiltinData v') (P.unsafeFromBuiltinData r)) @@ -362,7 +336,7 @@ unionWith f (toBuiltinList -> ls) (toBuiltinList -> rs) = ( \hd tl -> let k' = BI.fst hd tl' = go tl - in if member' k' ls + in if member k' (Map ls) then tl' else BI.mkCons hd tl' ) @@ -394,7 +368,7 @@ toList d = go (toBuiltinList d) {-# INLINEABLE toBuiltinList #-} -- | Convert the `Map` to a `P.BuiltinList` of key-value pairs. This operation is O(1). toBuiltinList :: Map k a -> BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -toBuiltinList (Map d) = BI.unsafeDataAsMap d +toBuiltinList (Map d) = d {-# INLINEABLE unsafeFromBuiltinList #-} -- | Unsafely create an 'Map' from a `P.BuiltinList` of key-value pairs. @@ -404,7 +378,7 @@ unsafeFromBuiltinList :: forall k a. BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> Map k a -unsafeFromBuiltinList = Map . BI.mkMap +unsafeFromBuiltinList = Map {-# INLINEABLE nil #-} -- | An empty `P.BuiltinList` of key-value pairs. From 75edbf9ace7f0731c7bc6deebd0f462040bcf978 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Wed, 8 May 2024 16:34:04 +0300 Subject: [PATCH 14/41] Fix union implementation Signed-off-by: Ana Pantilie --- .../test/Budget/9.6/map1-budget.budget.golden | 4 +- .../test/Budget/9.6/map1.pir.golden | 143 ++++++------ .../test/Budget/9.6/map1.uplc.golden | 206 +++++++++--------- .../test/Budget/9.6/map2-budget.budget.golden | 4 +- .../test/Budget/9.6/map2.pir.golden | 94 ++++---- .../test/Budget/9.6/map2.uplc.golden | 46 ++-- plutus-tx/src/PlutusTx/Data/AssocMap.hs | 68 +++++- 7 files changed, 294 insertions(+), 271 deletions(-) diff --git a/plutus-tx-plugin/test/Budget/9.6/map1-budget.budget.golden b/plutus-tx-plugin/test/Budget/9.6/map1-budget.budget.golden index 156ac164742..7189c9ef5af 100644 --- a/plutus-tx-plugin/test/Budget/9.6/map1-budget.budget.golden +++ b/plutus-tx-plugin/test/Budget/9.6/map1-budget.budget.golden @@ -1,2 +1,2 @@ -({cpu: 447446976 -| mem: 1083517}) \ No newline at end of file +({cpu: 462682968 +| mem: 1158673}) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Budget/9.6/map1.pir.golden b/plutus-tx-plugin/test/Budget/9.6/map1.pir.golden index 533937ec113..b3f19fcd046 100644 --- a/plutus-tx-plugin/test/Budget/9.6/map1.pir.golden +++ b/plutus-tx-plugin/test/Budget/9.6/map1.pir.golden @@ -230,51 +230,46 @@ let (\a -> a -> data) k -> (\a -> data -> a) a -> k -> - (\k a -> data) k a -> + (\k a -> list (pair data data)) k a -> Maybe a = /\k a -> \(`$dToData` : (\a -> a -> data) k) (`$dUnsafeFromData` : (\a -> data -> a) a) - (ds : k) - (m : (\k a -> data) k a) -> - Maybe_match - {data} - (let - !k : data = `$dToData` ds - 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 - let - !eta : list (pair data data) = unMapData m - in - go eta) - {all dead. Maybe a} - (\(a : data) -> /\dead -> Just {a} (`$dUnsafeFromData` a)) - (/\dead -> Nothing {a}) - {all dead. dead} + (ds : k) -> + 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 + !k' : data = fstPair {data} {data} hd + in + ifThenElse + {all dead. Maybe data} + (equalsData (`$dToData` ds) k') + (/\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 + \(ds : (\k a -> list (pair data data)) k a) -> + Maybe_match + {data} + (go ds) + {all dead. Maybe a} + (\(a : data) -> /\dead -> Just {a} (`$dUnsafeFromData` a)) + (/\dead -> Nothing {a}) + {all dead. dead} !matchList : all a r. list a -> r -> (a -> list a -> r) -> r = /\a r -> \(l : list a) (nilCase : r) (consCase : a -> list a -> r) -> @@ -291,9 +286,9 @@ let in \(n : integer) -> let - !nt : data + !nt : list (pair data data) = (let - b = (\k a -> data) integer bytestring + b = (\k a -> list (pair data data)) integer bytestring in \(k : integer -> b -> b) (z : b) -> letrec @@ -312,6 +307,7 @@ in (\(i : integer) -> let !ds : integer = addInteger n i + ~k : data = iData ds !ds : bytestring = encodeUtf8 (concatBuiltinStrings @@ -319,41 +315,34 @@ in 0 i (Nil {string}))) + ~a : data = bData ds in - \(m : (\k a -> data) integer bytestring) -> - mapData - (let - !ds : data = iData ds - !ds : data = bData ds - in - letrec - !go : list (pair data data) -> list (pair data data) - = \(xs : list (pair data data)) -> - matchList - {pair data data} - {list (pair data data)} - xs - (mkCons {pair data data} (mkPairData ds ds) []) - (\(hd : pair data data) - (tl : list (pair data data)) -> - ifThenElse - {all dead. list (pair data data)} - (equalsData ds (fstPair {data} {data} hd)) - (/\dead -> - mkCons - {pair data data} - (mkPairData ds ds) - tl) - (/\dead -> mkCons {pair data data} hd (go tl)) - {all dead. dead}) - in - let - !eta : list (pair data data) = unMapData m - in - go eta)) - (mapData (mkCons {pair data data} (mkPairData (iData n) (B #30)) [])) + letrec + !go : list (pair data data) -> list (pair data data) + = \(xs : list (pair data data)) -> + matchList + {pair data data} + {list (pair data data)} + xs + (mkCons {pair data data} (mkPairData k a) []) + (\(hd : pair data data) (tl : list (pair data data)) -> + let + !k' : data = fstPair {data} {data} hd + !d : data = k + in + ifThenElse + {all dead. list (pair data data)} + (equalsData d k') + (/\dead -> + mkCons {pair data data} (mkPairData d a) tl) + (/\dead -> mkCons {pair data data} hd (go tl)) + {all dead. dead}) + in + \(ds : (\k a -> list (pair data data)) integer bytestring) -> + go ds) + (mkCons {pair data data} (mkPairData (iData n) (B #30)) []) (`$fEnumBool_$cenumFromTo` 1 10) - !nt : data + !nt : list (pair data data) = let !ds : integer = addInteger 5 n in @@ -376,7 +365,7 @@ in (/\dead -> mkCons {pair data data} hd (go tl)) {all dead. dead}) in - mapData (go (unMapData nt)) + go nt in Tuple5 {Maybe bytestring} diff --git a/plutus-tx-plugin/test/Budget/9.6/map1.uplc.golden b/plutus-tx-plugin/test/Budget/9.6/map1.uplc.golden index 468ae78fb8f..faa14d4d82f 100644 --- a/plutus-tx-plugin/test/Budget/9.6/map1.uplc.golden +++ b/plutus-tx-plugin/test/Budget/9.6/map1.uplc.golden @@ -42,76 +42,74 @@ program nt) ]) (\`$dToData` `$dUnsafeFromData` - ds - m -> - force - (case - ((\k -> - fix1 - (\go - xs -> - force - (force chooseList) - xs - (\ds -> constr 1 []) - (\ds -> - (\hd -> - force - (force - ifThenElse - (equalsData - k + ds -> + (\go + ds -> + force + (case + (go ds) + [ (\a -> + delay + (constr 0 + [ (`$dUnsafeFromData` + a) ])) + , (delay (constr 1 [])) ])) + (fix1 + (\go + xs -> + force + (force chooseList) + xs + (\ds -> constr 1 []) + (\ds -> + (\hd -> + (\k' -> + force + (force + ifThenElse + (equalsData + (`$dToData` + ds) + k') + (delay + ((\ds -> + constr 0 + [ (force + (force + sndPair) + hd) ]) (force - (force - fstPair) - hd)) - (delay - ((\ds -> - constr 0 - [ (force - (force - sndPair) - hd) ]) - (force - tailList - xs))) - (delay - (go - (force - tailList - xs))))) - (force headList - xs)) - (constr 0 [])) - (unMapData m)) - (`$dToData` ds)) - [ (\a -> - delay - (constr 0 - [ (`$dUnsafeFromData` - a) ])) - , (delay (constr 1 [])) ]))) - (mapData - (fix1 - (\go xs -> - matchList - xs - [] - (\hd tl -> - (\k' -> - force - (force ifThenElse - (equalsData - (iData cse) - k') - (delay tl) - (delay - (force mkCons - hd - (go tl))))) - (force (force fstPair) - hd))) - (unMapData nt)))) + tailList + xs))) + (delay + (go + (force + tailList + xs))))) + (force + (force fstPair) + hd)) + (force headList xs)) + (constr 0 []))))) + (fix1 + (\go xs -> + matchList + xs + [] + (\hd tl -> + (\k' -> + force + (force ifThenElse + (equalsData + (iData cse) + k') + (delay tl) + (delay + (force mkCons + hd + (go tl))))) + (force (force fstPair) hd))) + nt)) (addInteger 5 n)) ((\z -> (\go eta -> @@ -127,31 +125,28 @@ program ys -> delay ((\ds -> - (\ds - m -> - mapData - ((\ds -> - (\ds -> - fix1 - (\go - xs -> + (\ds -> + (\go ds -> + go ds) + (fix1 + (\go + xs -> + (\cse -> + (\cse -> (\cse -> - (\cse -> - matchList - xs - (cse - [ ]) - (\hd - tl -> + matchList + xs + (cse + [ ]) + (\hd + tl -> + (\k' -> force (force ifThenElse (equalsData - ds - (force - (force - fstPair) - hd)) + cse + k') (delay (cse tl)) @@ -160,18 +155,20 @@ program mkCons hd (go - tl)))))) - (force - mkCons - cse)) - (mkPairData - ds - ds)) - (unMapData - m)) - (bData - ds)) - (iData ds))) + tl))))) + (force + (force + fstPair) + hd))) + (force + mkCons + cse)) + (mkPairData + cse + (bData + ds))) + (iData + ds)))) (encodeUtf8 (concatBuiltinStrings (`$fShowBuiltinByteString_$cshowsPrec` @@ -181,10 +178,9 @@ program [ ]))))) (addInteger n y) (go ys))) ])))) - (mapData - (force mkCons - (mkPairData (iData n) (B #30)) - [])) + (force mkCons + (mkPairData (iData n) (B #30)) + []) (`$fEnumBool_$cenumFromTo` 1 10))) (\l nilCase consCase -> force (force chooseList) diff --git a/plutus-tx-plugin/test/Budget/9.6/map2-budget.budget.golden b/plutus-tx-plugin/test/Budget/9.6/map2-budget.budget.golden index 5eb9c377668..102157ec94e 100644 --- a/plutus-tx-plugin/test/Budget/9.6/map2-budget.budget.golden +++ b/plutus-tx-plugin/test/Budget/9.6/map2-budget.budget.golden @@ -1,2 +1,2 @@ -({cpu: 161977681 -| mem: 420102}) \ No newline at end of file +({cpu: 160633417 +| mem: 416622}) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Budget/9.6/map2.pir.golden b/plutus-tx-plugin/test/Budget/9.6/map2.pir.golden index 216d09f15fe..417f4715ce9 100644 --- a/plutus-tx-plugin/test/Budget/9.6/map2.pir.golden +++ b/plutus-tx-plugin/test/Budget/9.6/map2.pir.golden @@ -47,6 +47,9 @@ letrec 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 @@ -60,9 +63,6 @@ let (\(ds : Unit) -> nilCase) (\(ds : Unit) -> consCase (headList {a} l) (tailList {a} l)) Unit - data Bool | Bool_match where - True : Bool - False : Bool in letrec !`$fToBuiltinListBuiltinList_$ctoBuiltin` : @@ -92,7 +92,7 @@ let (\a -> a -> data) k -> (\a -> a -> data) a -> List (Tuple2 k a) -> - (\k a -> data) k a + (\k a -> list (pair data data)) k a = /\k a -> \(`$dToData` : (\a -> a -> data) k) (`$dToData` : (\a -> a -> data) a) -> @@ -123,11 +123,11 @@ let {all dead. dead} in \(eta : List (Tuple2 k a)) -> - mapData (`$fToBuiltinListBuiltinList_$ctoBuiltin` (go eta)) + `$fToBuiltinListBuiltinList_$ctoBuiltin` (go eta) in \(n : integer) -> let - !nt : data + !nt : list (pair data data) = unsafeFromList {integer} {bytestring} @@ -161,7 +161,6 @@ in (addInteger 7 n) #534556454e) n))))) - ~rs : list (pair data data) = unMapData nt in letrec !go : list (pair data data) -> list (pair data data) @@ -204,10 +203,7 @@ in in Maybe_match {data} - (let - !eta : list (pair data data) = rs - in - go eta) + (go nt) {all dead. list (pair data data)} (\(r : data) -> /\dead -> @@ -221,7 +217,7 @@ in {all dead. dead}) in let - !nt : data + !nt : list (pair data data) = unsafeFromList {integer} {bytestring} @@ -257,7 +253,6 @@ in (addInteger 5 n) #66697665) n)))))) - ~ls : list (pair data data) = unMapData nt in letrec !go : list (pair data data) -> list (pair data data) @@ -270,54 +265,49 @@ in (\(hd : pair data data) (tl : list (pair data data)) -> let !tl' : list (pair data data) = go tl + !k' : data = fstPair {data} {data} hd + in + letrec + !go : list (pair data data) -> Bool + = \(xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> Bool} + xs + (\(ds : Unit) -> False) + (\(ds : Unit) -> + ifThenElse + {all dead. Bool} + (equalsData + k' + (fstPair + {data} + {data} + (headList {pair data data} xs))) + (/\dead -> + let + !ds : list (pair data data) + = tailList {pair data data} xs + in + True) + (/\dead -> go (tailList {pair data data} xs)) + {all dead. dead}) + Unit in Bool_match - (let - !k : data = fstPair {data} {data} hd - in - letrec - !go : list (pair data data) -> Bool - = \(xs : list (pair data data)) -> - chooseList - {pair data data} - {Unit -> Bool} - xs - (\(ds : Unit) -> False) - (\(ds : Unit) -> - ifThenElse - {all dead. Bool} - (equalsData - k - (fstPair - {data} - {data} - (headList {pair data data} xs))) - (/\dead -> - let - !ds : list (pair data data) - = tailList {pair data data} xs - in - True) - (/\dead -> go (tailList {pair data data} xs)) - {all dead. dead}) - Unit - in - let - !eta : list (pair data data) = ls - in - go eta) + (go nt) {all dead. list (pair data data)} (/\dead -> tl') (/\dead -> mkCons {pair data data} hd tl') {all dead. dead}) in let - !nt : data + !nt : list (pair data data) = let - !rs' : list (pair data data) = go rs - !ls' : list (pair data data) = go ls + !rs' : list (pair data data) = go nt + !ls' : list (pair data data) = go nt in - mapData (go rs' ls') + go rs' ls' in (let a = Tuple2 integer bytestring @@ -345,4 +335,4 @@ in {Tuple2 integer string} (\(k : integer) (v : bytestring) -> Tuple2 {integer} {string} k (decodeUtf8 v))) - (go (unMapData nt)) \ No newline at end of file + (go nt) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Budget/9.6/map2.uplc.golden b/plutus-tx-plugin/test/Budget/9.6/map2.uplc.golden index 320e236fb27..8822138e503 100644 --- a/plutus-tx-plugin/test/Budget/9.6/map2.uplc.golden +++ b/plutus-tx-plugin/test/Budget/9.6/map2.uplc.golden @@ -33,10 +33,9 @@ program , (decodeUtf8 v) ]) ]) , (go xs) ])) ])) - (go (unMapData nt))) + (go nt)) ((\rs' -> - (\ls' -> mapData (go rs' ls')) - (go (unMapData nt))) + (\ls' -> go rs' ls') (go nt)) (fix1 (\go xs -> @@ -46,10 +45,10 @@ program (\hd tl -> (\tl' -> - force - (case - ((\k -> - fix1 + (\k' -> + force + (case + (fix1 (\go xs -> force @@ -64,7 +63,7 @@ program (force ifThenElse (equalsData - k + k' (force (force fstPair) @@ -85,19 +84,17 @@ program xs))))) (constr 0 [])) - (unMapData - nt)) - (force - (force - fstPair) - hd)) - [ (delay tl') - , (delay - (force mkCons - hd - tl')) ])) + nt) + [ (delay tl') + , (delay + (force + mkCons + hd + tl')) ])) + (force (force fstPair) + hd)) (go tl))) - (unMapData nt)))) + nt))) (unsafeFromList (\i -> iData i) bData @@ -171,7 +168,7 @@ program headList xs)) (constr 0 [])) - (unMapData nt)) + nt) [ (\r -> delay (force @@ -206,12 +203,11 @@ program [ (addInteger 7 n) , #534556454e ]) , (constr 0 []) ]) ]) ]) ]))) - (addInteger 3 n)) - (addInteger 4 n)) + (addInteger 4 n)) + (addInteger 3 n)) (\`$dToData` `$dToData` -> (\go eta -> - mapData - (`$fToBuiltinListBuiltinList_$ctoBuiltin` (go eta))) + `$fToBuiltinListBuiltinList_$ctoBuiltin` (go eta)) (fix1 (\go ds -> force diff --git a/plutus-tx/src/PlutusTx/Data/AssocMap.hs b/plutus-tx/src/PlutusTx/Data/AssocMap.hs index d5bd7b84c4d..9fac4a6b09a 100644 --- a/plutus-tx/src/PlutusTx/Data/AssocMap.hs +++ b/plutus-tx/src/PlutusTx/Data/AssocMap.hs @@ -85,6 +85,23 @@ lookup (P.toBuiltinData -> k) (Map m) = P.unsafeFromBuiltinData <$> go m else go ) +lookup' + :: BuiltinData + -> BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) + -> Maybe BuiltinData +lookup' k m = go m + where + go xs = + P.matchList + xs + Nothing + ( \hd -> + let k' = BI.fst hd + in if P.equalsData k k' + then \_ -> Just (BI.snd hd) + else go + ) + {-# INLINEABLE member #-} -- | Check if the key is in the `Map`. member :: forall k a. (P.ToData k) => k -> Map k a -> Bool @@ -102,6 +119,21 @@ member (P.toBuiltinData -> k) (Map m) = go m else go ) +member' :: BuiltinData -> BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> Bool +member' k m = go m + where + go :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> Bool + go xs = + P.matchList + xs + False + ( \hd -> + let k' = BI.fst hd + in if P.equalsData k k' + then \_ -> True + else go + ) + {-# INLINEABLE insert #-} -- | Insert a key-value pair into the `Map`. If the key is already present, -- the value is updated. @@ -122,6 +154,27 @@ insert (P.toBuiltinData -> k) (P.toBuiltinData -> a) (Map m) = Map $ go m else BI.mkCons hd (go tl) ) +insert' + :: BuiltinData + -> BuiltinData + -> BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) + -> BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) +insert' k a m = go m + where + go :: + BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> + BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) + go xs = + P.matchList + xs + (BI.mkCons (BI.mkPairData k a) nil) + ( \hd tl -> + let k' = BI.fst hd + in if P.equalsData k k' + then BI.mkCons (BI.mkPairData k a) tl + else BI.mkCons hd (go tl) + ) + {-# INLINEABLE delete #-} -- | Delete a key value pair from the `Map`. -- If the `Map` is not well-defined, it deletes the pair associated with the @@ -251,7 +304,7 @@ union (Map ls) (Map rs) = Map res ( \hd tl -> let k = BI.fst hd v = BI.snd hd - v' = case lookup k (Map rs) of + v' = case lookup' k rs of Just r -> P.toBuiltinData ( These @@ -271,7 +324,7 @@ union (Map ls) (Map rs) = Map res ( \hd tl -> let k = BI.fst hd v = BI.snd hd - v' = case lookup k (Map ls) of + v' = case lookup' k ls of Just r -> P.toBuiltinData ( These @@ -293,8 +346,7 @@ union (Map ls) (Map rs) = Map res ( \hd tl -> let k = BI.fst hd v = BI.snd hd - Map res' = insert k v (Map $ safeAppend tl xs2) - in res' + in insert' k v (safeAppend tl xs2) ) -- | Combine two 'Map's with the given combination function. @@ -305,8 +357,8 @@ unionWith :: Map k a -> Map k a -> Map k a -unionWith f (toBuiltinList -> ls) (toBuiltinList -> rs) = - unsafeFromBuiltinList res +unionWith f (Map ls) (Map rs) = + Map res where ls' :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) ls' = go ls @@ -318,7 +370,7 @@ unionWith f (toBuiltinList -> ls) (toBuiltinList -> rs) = ( \hd tl -> let k' = BI.fst hd v' = BI.snd hd - v'' = case lookup k' (Map rs) of + v'' = case lookup' k' rs of Just r -> P.toBuiltinData (f (P.unsafeFromBuiltinData v') (P.unsafeFromBuiltinData r)) @@ -336,7 +388,7 @@ unionWith f (toBuiltinList -> ls) (toBuiltinList -> rs) = ( \hd tl -> let k' = BI.fst hd tl' = go tl - in if member k' (Map ls) + in if member' k' ls then tl' else BI.mkCons hd tl' ) From cd2d843b61ad3f719d4aad616b6f68381ae46c75 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Wed, 8 May 2024 16:45:15 +0300 Subject: [PATCH 15/41] Use BuiltinList internal functions Signed-off-by: Ana Pantilie --- .../test/Budget/9.6/map1-budget.budget.golden | 4 +- .../test/Budget/9.6/map1.pir.golden | 116 ++++++------- .../test/Budget/9.6/map1.uplc.golden | 154 +++++++++--------- .../test/Budget/9.6/map2.pir.golden | 66 ++++---- .../test/Budget/9.6/map2.uplc.golden | 27 +-- plutus-tx/src/PlutusTx/Data/AssocMap.hs | 43 +---- 6 files changed, 187 insertions(+), 223 deletions(-) diff --git a/plutus-tx-plugin/test/Budget/9.6/map1-budget.budget.golden b/plutus-tx-plugin/test/Budget/9.6/map1-budget.budget.golden index 7189c9ef5af..d022e97acaa 100644 --- a/plutus-tx-plugin/test/Budget/9.6/map1-budget.budget.golden +++ b/plutus-tx-plugin/test/Budget/9.6/map1-budget.budget.golden @@ -1,2 +1,2 @@ -({cpu: 462682968 -| mem: 1158673}) \ No newline at end of file +({cpu: 444767968 +| mem: 1077021}) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Budget/9.6/map1.pir.golden b/plutus-tx-plugin/test/Budget/9.6/map1.pir.golden index b3f19fcd046..ee93d3f7a5d 100644 --- a/plutus-tx-plugin/test/Budget/9.6/map1.pir.golden +++ b/plutus-tx-plugin/test/Budget/9.6/map1.pir.golden @@ -235,41 +235,43 @@ let = /\k a -> \(`$dToData` : (\a -> a -> data) k) (`$dUnsafeFromData` : (\a -> data -> a) a) - (ds : k) -> - 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 - !k' : data = fstPair {data} {data} hd - in - ifThenElse - {all dead. Maybe data} - (equalsData (`$dToData` ds) k') - (/\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 - \(ds : (\k a -> list (pair data data)) k a) -> - Maybe_match - {data} - (go ds) - {all dead. Maybe a} - (\(a : data) -> /\dead -> Just {a} (`$dUnsafeFromData` a)) - (/\dead -> Nothing {a}) - {all dead. dead} + (ds : k) + (ds : (\k a -> list (pair data data)) k a) -> + Maybe_match + {data} + (let + !k : data = `$dToData` ds + 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) + {all dead. Maybe a} + (\(a : data) -> /\dead -> Just {a} (`$dUnsafeFromData` a)) + (/\dead -> Nothing {a}) + {all dead. dead} !matchList : all a r. list a -> r -> (a -> list a -> r) -> r = /\a r -> \(l : list a) (nilCase : r) (consCase : a -> list a -> r) -> @@ -307,7 +309,6 @@ in (\(i : integer) -> let !ds : integer = addInteger n i - ~k : data = iData ds !ds : bytestring = encodeUtf8 (concatBuiltinStrings @@ -315,30 +316,29 @@ in 0 i (Nil {string}))) - ~a : data = bData ds - in - letrec - !go : list (pair data data) -> list (pair data data) - = \(xs : list (pair data data)) -> - matchList - {pair data data} - {list (pair data data)} - xs - (mkCons {pair data data} (mkPairData k a) []) - (\(hd : pair data data) (tl : list (pair data data)) -> - let - !k' : data = fstPair {data} {data} hd - !d : data = k - in - ifThenElse - {all dead. list (pair data data)} - (equalsData d k') - (/\dead -> - mkCons {pair data data} (mkPairData d a) tl) - (/\dead -> mkCons {pair data data} hd (go tl)) - {all dead. dead}) in \(ds : (\k a -> list (pair data data)) integer bytestring) -> + let + !k : data = iData ds + !a : data = bData ds + in + letrec + !go : list (pair data data) -> list (pair data data) + = \(xs : list (pair data data)) -> + matchList + {pair data data} + {list (pair data data)} + xs + (mkCons {pair data data} (mkPairData k a) []) + (\(hd : pair data data) (tl : list (pair data data)) -> + ifThenElse + {all dead. list (pair data data)} + (equalsData k (fstPair {data} {data} hd)) + (/\dead -> + mkCons {pair data data} (mkPairData k a) tl) + (/\dead -> mkCons {pair data data} hd (go tl)) + {all dead. dead}) + in go ds) (mkCons {pair data data} (mkPairData (iData n) (B #30)) []) (`$fEnumBool_$cenumFromTo` 1 10) diff --git a/plutus-tx-plugin/test/Budget/9.6/map1.uplc.golden b/plutus-tx-plugin/test/Budget/9.6/map1.uplc.golden index faa14d4d82f..46898486eb0 100644 --- a/plutus-tx-plugin/test/Budget/9.6/map1.uplc.golden +++ b/plutus-tx-plugin/test/Budget/9.6/map1.uplc.golden @@ -42,55 +42,55 @@ program nt) ]) (\`$dToData` `$dUnsafeFromData` + ds ds -> - (\go - ds -> - force - (case - (go ds) - [ (\a -> - delay - (constr 0 - [ (`$dUnsafeFromData` - a) ])) - , (delay (constr 1 [])) ])) - (fix1 - (\go - xs -> - force - (force chooseList) - xs - (\ds -> constr 1 []) - (\ds -> - (\hd -> - (\k' -> - force - (force - ifThenElse - (equalsData - (`$dToData` - ds) - k') - (delay - ((\ds -> - constr 0 - [ (force - (force - sndPair) - hd) ]) - (force - tailList - xs))) - (delay - (go + force + (case + ((\k -> + fix1 + (\go + xs -> + force + (force chooseList) + xs + (\ds -> constr 1 []) + (\ds -> + (\hd -> + force + (force + ifThenElse + (equalsData + k (force - tailList - xs))))) - (force - (force fstPair) - hd)) - (force headList xs)) - (constr 0 []))))) + (force + fstPair) + hd)) + (delay + ((\ds -> + constr 0 + [ (force + (force + sndPair) + hd) ]) + (force + tailList + xs))) + (delay + (go + (force + tailList + xs))))) + (force headList + xs)) + (constr 0 [])) + ds) + (`$dToData` ds)) + [ (\a -> + delay + (constr 0 + [ (`$dUnsafeFromData` + a) ])) + , (delay (constr 1 [])) ]))) (fix1 (\go xs -> matchList @@ -125,13 +125,13 @@ program ys -> delay ((\ds -> - (\ds -> - (\go ds -> - go ds) - (fix1 - (\go - xs -> - (\cse -> + (\ds + ds -> + (\k -> + (\a -> + fix1 + (\go + xs -> (\cse -> (\cse -> matchList @@ -140,35 +140,33 @@ program [ ]) (\hd tl -> - (\k' -> - force - (force - ifThenElse - (equalsData - cse - k') - (delay - (cse - tl)) - (delay - (force - mkCons - hd - (go - tl))))) + force (force - (force - fstPair) - hd))) + ifThenElse + (equalsData + k + (force + (force + fstPair) + hd)) + (delay + (cse + tl)) + (delay + (force + mkCons + hd + (go + tl)))))) (force mkCons cse)) (mkPairData - cse - (bData - ds))) - (iData - ds)))) + k + a)) + ds) + (bData ds)) + (iData ds)) (encodeUtf8 (concatBuiltinStrings (`$fShowBuiltinByteString_$cshowsPrec` diff --git a/plutus-tx-plugin/test/Budget/9.6/map2.pir.golden b/plutus-tx-plugin/test/Budget/9.6/map2.pir.golden index 417f4715ce9..8289ed83adf 100644 --- a/plutus-tx-plugin/test/Budget/9.6/map2.pir.golden +++ b/plutus-tx-plugin/test/Budget/9.6/map2.pir.golden @@ -47,9 +47,6 @@ letrec 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 @@ -63,6 +60,9 @@ let (\(ds : Unit) -> nilCase) (\(ds : Unit) -> consCase (headList {a} l) (tailList {a} l)) Unit + data Bool | Bool_match where + True : Bool + False : Bool in letrec !`$fToBuiltinListBuiltinList_$ctoBuiltin` : @@ -265,37 +265,39 @@ in (\(hd : pair data data) (tl : list (pair data data)) -> let !tl' : list (pair data data) = go tl - !k' : data = fstPair {data} {data} hd - in - letrec - !go : list (pair data data) -> Bool - = \(xs : list (pair data data)) -> - chooseList - {pair data data} - {Unit -> Bool} - xs - (\(ds : Unit) -> False) - (\(ds : Unit) -> - ifThenElse - {all dead. Bool} - (equalsData - k' - (fstPair - {data} - {data} - (headList {pair data data} xs))) - (/\dead -> - let - !ds : list (pair data data) - = tailList {pair data data} xs - in - True) - (/\dead -> go (tailList {pair data data} xs)) - {all dead. dead}) - Unit in Bool_match - (go nt) + (let + !k : data = fstPair {data} {data} hd + in + letrec + !go : list (pair data data) -> Bool + = \(xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> Bool} + xs + (\(ds : Unit) -> False) + (\(ds : Unit) -> + ifThenElse + {all dead. Bool} + (equalsData + k + (fstPair + {data} + {data} + (headList {pair data data} xs))) + (/\dead -> + let + !ds : list (pair data data) + = tailList {pair data data} xs + in + True) + (/\dead -> go (tailList {pair data data} xs)) + {all dead. dead}) + Unit + in + go nt) {all dead. list (pair data data)} (/\dead -> tl') (/\dead -> mkCons {pair data data} hd tl') diff --git a/plutus-tx-plugin/test/Budget/9.6/map2.uplc.golden b/plutus-tx-plugin/test/Budget/9.6/map2.uplc.golden index 8822138e503..c3b5c686f66 100644 --- a/plutus-tx-plugin/test/Budget/9.6/map2.uplc.golden +++ b/plutus-tx-plugin/test/Budget/9.6/map2.uplc.golden @@ -45,10 +45,10 @@ program (\hd tl -> (\tl' -> - (\k' -> - force - (case - (fix1 + force + (case + ((\k -> + fix1 (\go xs -> force @@ -63,7 +63,7 @@ program (force ifThenElse (equalsData - k' + k (force (force fstPair) @@ -85,14 +85,15 @@ program (constr 0 [])) nt) - [ (delay tl') - , (delay - (force - mkCons - hd - tl')) ])) - (force (force fstPair) - hd)) + (force + (force + fstPair) + hd)) + [ (delay tl') + , (delay + (force mkCons + hd + tl')) ])) (go tl))) nt))) (unsafeFromList diff --git a/plutus-tx/src/PlutusTx/Data/AssocMap.hs b/plutus-tx/src/PlutusTx/Data/AssocMap.hs index 9fac4a6b09a..60bd704dc62 100644 --- a/plutus-tx/src/PlutusTx/Data/AssocMap.hs +++ b/plutus-tx/src/PlutusTx/Data/AssocMap.hs @@ -72,18 +72,7 @@ instance P.UnsafeFromData (Map k a) where -- the left-most occurrence of the key in the list. -- This operation is O(n). lookup :: forall k a. (P.ToData k, P.UnsafeFromData a) => k -> Map k a -> Maybe a -lookup (P.toBuiltinData -> k) (Map m) = P.unsafeFromBuiltinData <$> go m - where - go xs = - P.matchList - xs - Nothing - ( \hd -> - let k' = BI.fst hd - in if P.equalsData k k' - then \_ -> Just (BI.snd hd) - else go - ) +lookup (P.toBuiltinData -> k) (Map m) = P.unsafeFromBuiltinData <$> lookup' k m lookup' :: BuiltinData @@ -105,19 +94,7 @@ lookup' k m = go m {-# INLINEABLE member #-} -- | Check if the key is in the `Map`. member :: forall k a. (P.ToData k) => k -> Map k a -> Bool -member (P.toBuiltinData -> k) (Map m) = go m - where - go :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> Bool - go xs = - P.matchList - xs - False - ( \hd -> - let k' = BI.fst hd - in if P.equalsData k k' - then \_ -> True - else go - ) +member (P.toBuiltinData -> k) (Map m) = member' k m member' :: BuiltinData -> BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> Bool member' k m = go m @@ -138,21 +115,7 @@ member' k m = go m -- | Insert a key-value pair into the `Map`. If the key is already present, -- the value is updated. insert :: forall k a. (P.ToData k, P.ToData a) => k -> a -> Map k a -> Map k a -insert (P.toBuiltinData -> k) (P.toBuiltinData -> a) (Map m) = Map $ go m - where - go :: - BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> - BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) - go xs = - P.matchList - xs - (BI.mkCons (BI.mkPairData k a) nil) - ( \hd tl -> - let k' = BI.fst hd - in if P.equalsData k k' - then BI.mkCons (BI.mkPairData k a) tl - else BI.mkCons hd (go tl) - ) +insert (P.toBuiltinData -> k) (P.toBuiltinData -> a) (Map m) = Map $ insert' k a m insert' :: BuiltinData From 4071a8a72b95348b20fb0d41fcb61070c69dba90 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Wed, 8 May 2024 17:00:54 +0300 Subject: [PATCH 16/41] Create internal top-level delete Signed-off-by: Ana Pantilie --- .../test/Budget/9.6/map1-budget.budget.golden | 4 +- .../test/Budget/9.6/map1.pir.golden | 67 ++-- .../test/Budget/9.6/map1.uplc.golden | 341 +++++++++--------- plutus-tx/src/PlutusTx/Data/AssocMap.hs | 10 +- 4 files changed, 213 insertions(+), 209 deletions(-) diff --git a/plutus-tx-plugin/test/Budget/9.6/map1-budget.budget.golden b/plutus-tx-plugin/test/Budget/9.6/map1-budget.budget.golden index d022e97acaa..a25b08605a7 100644 --- a/plutus-tx-plugin/test/Budget/9.6/map1-budget.budget.golden +++ b/plutus-tx-plugin/test/Budget/9.6/map1-budget.budget.golden @@ -1,2 +1,2 @@ -({cpu: 444767968 -| mem: 1077021}) \ No newline at end of file +({cpu: 444554968 +| mem: 1075929}) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Budget/9.6/map1.pir.golden b/plutus-tx-plugin/test/Budget/9.6/map1.pir.golden index ee93d3f7a5d..12bfa01abdc 100644 --- a/plutus-tx-plugin/test/Budget/9.6/map1.pir.golden +++ b/plutus-tx-plugin/test/Budget/9.6/map1.pir.golden @@ -219,12 +219,40 @@ letrec (concatBuiltinStrings ipv))) {all dead. dead}) in +let + data Unit | Unit_match where + Unit : Unit + !matchList : all a r. list a -> r -> (a -> list a -> r) -> r + = /\a r -> + \(l : list a) (nilCase : r) (consCase : a -> list a -> r) -> + chooseList + {a} + {Unit -> r} + l + (\(ds : Unit) -> nilCase) + (\(ds : Unit) -> consCase (headList {a} l) (tailList {a} l)) + Unit +in +letrec + !delete' : data -> list (pair data data) -> list (pair data data) + = \(k : data) (m : list (pair data data)) -> + matchList + {pair data data} + {list (pair data data)} + m + [] + (\(hd : pair data data) (tl : list (pair data data)) -> + ifThenElse + {all dead. list (pair data data)} + (equalsData k (fstPair {data} {data} hd)) + (/\dead -> tl) + (/\dead -> mkCons {pair data data} hd (delete' k tl)) + {all dead. dead}) +in let data (Maybe :: * -> *) a | Maybe_match where Just : a -> Maybe a Nothing : Maybe a - data Unit | Unit_match where - Unit : Unit !lookup : all k a. (\a -> a -> data) k -> @@ -272,16 +300,6 @@ let (\(a : data) -> /\dead -> Just {a} (`$dUnsafeFromData` a)) (/\dead -> Nothing {a}) {all dead. dead} - !matchList : all a r. list a -> r -> (a -> list a -> r) -> r - = /\a r -> - \(l : list a) (nilCase : r) (consCase : a -> list a -> r) -> - chooseList - {a} - {Unit -> r} - l - (\(ds : Unit) -> nilCase) - (\(ds : Unit) -> consCase (headList {a} l) (tailList {a} l)) - Unit data Bool | Bool_match where True : Bool False : Bool @@ -342,30 +360,7 @@ in go ds) (mkCons {pair data data} (mkPairData (iData n) (B #30)) []) (`$fEnumBool_$cenumFromTo` 1 10) - !nt : list (pair data data) - = let - !ds : integer = addInteger 5 n - in - letrec - !go : list (pair data data) -> list (pair data data) - = \(xs : list (pair data data)) -> - matchList - {pair data data} - {list (pair data data)} - xs - [] - (\(hd : pair data data) (tl : list (pair data data)) -> - let - !k' : data = fstPair {data} {data} hd - in - ifThenElse - {all dead. list (pair data data)} - (equalsData (iData ds) k') - (/\dead -> tl) - (/\dead -> mkCons {pair data data} hd (go tl)) - {all dead. dead}) - in - go nt + !nt : list (pair data data) = delete' (iData (addInteger 5 n)) nt in Tuple5 {Maybe bytestring} diff --git a/plutus-tx-plugin/test/Budget/9.6/map1.uplc.golden b/plutus-tx-plugin/test/Budget/9.6/map1.uplc.golden index 46898486eb0..3fb12e1a7d7 100644 --- a/plutus-tx-plugin/test/Budget/9.6/map1.uplc.golden +++ b/plutus-tx-plugin/test/Budget/9.6/map1.uplc.golden @@ -7,179 +7,182 @@ program (\`$fShowBuiltinByteString_$cshowsPrec` -> (\go -> (\go -> - (\concatBuiltinStrings - n -> + (\concatBuiltinStrings -> (\matchList -> - (\nt -> - (\cse -> - (\nt -> - (\lookup -> - constr 0 - [ (lookup - (\i -> iData i) - unBData - n - nt) - , (lookup - (\i -> iData i) - unBData - cse - nt) - , (lookup - (\i -> iData i) - unBData - (addInteger 10 n) - nt) - , (lookup - (\i -> iData i) - unBData - (addInteger 20 n) - nt) - , (lookup - (\i -> iData i) - unBData - cse - nt) ]) - (\`$dToData` - `$dUnsafeFromData` - ds - ds -> - force - (case - ((\k -> - fix1 - (\go - xs -> - force - (force chooseList) - xs - (\ds -> constr 1 []) - (\ds -> - (\hd -> - force - (force - ifThenElse - (equalsData - k - (force - (force - fstPair) - hd)) - (delay - ((\ds -> - constr 0 - [ (force - (force - sndPair) - hd) ]) - (force - tailList - xs))) - (delay - (go + (\delete' + n -> + (\nt -> + (\cse -> + (\nt -> + (\lookup -> + constr 0 + [ (lookup + (\i -> iData i) + unBData + n + nt) + , (lookup + (\i -> iData i) + unBData + cse + nt) + , (lookup + (\i -> iData i) + unBData + (addInteger 10 n) + nt) + , (lookup + (\i -> iData i) + unBData + (addInteger 20 n) + nt) + , (lookup + (\i -> iData i) + unBData + cse + nt) ]) + (\`$dToData` + `$dUnsafeFromData` + ds + ds -> + force + (case + ((\k -> + fix1 + (\go + xs -> + force + (force + chooseList) + xs + (\ds -> + constr 1 []) + (\ds -> + (\hd -> + force + (force + ifThenElse + (equalsData + k (force - tailList - xs))))) - (force headList - xs)) - (constr 0 [])) - ds) - (`$dToData` ds)) - [ (\a -> - delay - (constr 0 - [ (`$dUnsafeFromData` - a) ])) - , (delay (constr 1 [])) ]))) - (fix1 - (\go xs -> - matchList - xs - [] - (\hd tl -> - (\k' -> - force - (force ifThenElse - (equalsData - (iData cse) - k') - (delay tl) - (delay - (force mkCons - hd - (go tl))))) - (force (force fstPair) hd))) - nt)) - (addInteger 5 n)) - ((\z -> - (\go eta -> - go eta) - (fix1 - (\go - ds -> - force - (case - ds - [ (delay z) - , (\y - ys -> - delay - ((\ds -> - (\ds - ds -> - (\k -> - (\a -> - fix1 - (\go - xs -> - (\cse -> + (force + fstPair) + hd)) + (delay + ((\ds -> + constr 0 + [ (force + (force + sndPair) + hd) ]) + (force + tailList + xs))) + (delay + (go + (force + tailList + xs))))) + (force + headList + xs)) + (constr 0 [])) + ds) + (`$dToData` ds)) + [ (\a -> + delay + (constr 0 + [ (`$dUnsafeFromData` + a) ])) + , (delay (constr 1 [])) ]))) + (delete' (iData cse) nt)) + (addInteger 5 n)) + ((\z -> + (\go eta -> + go eta) + (fix1 + (\go + ds -> + force + (case + ds + [ (delay z) + , (\y + ys -> + delay + ((\ds -> + (\ds + ds -> + (\k -> + (\a -> + fix1 + (\go + xs -> (\cse -> - matchList - xs - (cse - [ ]) - (\hd - tl -> - force - (force - ifThenElse - (equalsData - k - (force + (\cse -> + matchList + xs + (cse + [ ]) + (\hd + tl -> + force + (force + ifThenElse + (equalsData + k (force - fstPair) - hd)) - (delay - (cse - tl)) - (delay - (force - mkCons - hd - (go - tl)))))) - (force - mkCons - cse)) - (mkPairData - k - a)) - ds) - (bData ds)) - (iData ds)) - (encodeUtf8 - (concatBuiltinStrings - (`$fShowBuiltinByteString_$cshowsPrec` - 0 - y - (constr 0 - [ ]))))) - (addInteger n y) - (go ys))) ])))) - (force mkCons - (mkPairData (iData n) (B #30)) - []) - (`$fEnumBool_$cenumFromTo` 1 10))) + (force + fstPair) + hd)) + (delay + (cse + tl)) + (delay + (force + mkCons + hd + (go + tl)))))) + (force + mkCons + cse)) + (mkPairData + k + a)) + ds) + (bData + ds)) + (iData ds)) + (encodeUtf8 + (concatBuiltinStrings + (`$fShowBuiltinByteString_$cshowsPrec` + 0 + y + (constr 0 + [ ]))))) + (addInteger n y) + (go ys))) ])))) + (force mkCons + (mkPairData (iData n) (B #30)) + []) + (`$fEnumBool_$cenumFromTo` 1 10))) + (fix1 + (\delete' k m -> + matchList + m + [] + (\hd tl -> + force + (force ifThenElse + (equalsData + k + (force (force fstPair) hd)) + (delay tl) + (delay + (force mkCons + hd + (delete' k tl)))))))) (\l nilCase consCase -> force (force chooseList) l diff --git a/plutus-tx/src/PlutusTx/Data/AssocMap.hs b/plutus-tx/src/PlutusTx/Data/AssocMap.hs index 60bd704dc62..97d5124da5b 100644 --- a/plutus-tx/src/PlutusTx/Data/AssocMap.hs +++ b/plutus-tx/src/PlutusTx/Data/AssocMap.hs @@ -143,7 +143,13 @@ insert' k a m = go m -- If the `Map` is not well-defined, it deletes the pair associated with the -- left-most occurrence of the key in the list. delete :: forall k a. (P.ToData k) => k -> Map k a -> Map k a -delete (P.toBuiltinData -> k) (Map m) = Map $ go m +delete (P.toBuiltinData -> k) (Map m) = Map $ delete' k m + +delete' :: + BuiltinData -> + BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> + BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) +delete' k m = go m where go :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> @@ -156,7 +162,7 @@ delete (P.toBuiltinData -> k) (Map m) = Map $ go m let k' = BI.fst hd in if P.equalsData k k' then tl - else BI.mkCons hd (go tl) + else BI.mkCons hd (delete' k tl) ) {-# INLINEABLE singleton #-} From 7d96dc408a07fa4c37d03b5ba733d5918fbd6e65 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Wed, 8 May 2024 17:09:51 +0300 Subject: [PATCH 17/41] Add union test Signed-off-by: Ana Pantilie --- plutus-tx-plugin/test/AssocMap/Spec.hs | 32 +- .../test/Budget/9.6/map3-budget.budget.golden | 2 + .../test/Budget/9.6/map3.eval.golden | 27 ++ .../test/Budget/9.6/map3.pir.golden | 340 ++++++++++++++++++ .../test/Budget/9.6/map3.uplc.golden | 272 ++++++++++++++ 5 files changed, 672 insertions(+), 1 deletion(-) create mode 100644 plutus-tx-plugin/test/Budget/9.6/map3-budget.budget.golden create mode 100644 plutus-tx-plugin/test/Budget/9.6/map3.eval.golden create mode 100644 plutus-tx-plugin/test/Budget/9.6/map3.pir.golden create mode 100644 plutus-tx-plugin/test/Budget/9.6/map3.uplc.golden diff --git a/plutus-tx-plugin/test/AssocMap/Spec.hs b/plutus-tx-plugin/test/AssocMap/Spec.hs index 385fbda6e36..ea768a0e858 100644 --- a/plutus-tx-plugin/test/AssocMap/Spec.hs +++ b/plutus-tx-plugin/test/AssocMap/Spec.hs @@ -32,7 +32,7 @@ import PlutusTx.Prelude qualified as PlutusTx import PlutusTx.Show qualified as PlutusTx import PlutusTx.Test import PlutusTx.TH (compile) -import PlutusTx.These (These (..)) +import PlutusTx.These (These (..), these) import Test.Tasty (TestTree, testGroup) import Test.Tasty.Hedgehog (testProperty) @@ -48,6 +48,10 @@ goldenTests = , goldenUPlcReadable "map2" map2 , goldenEvalCekCatch "map2" $ [map2 `unsafeApplyCode` (liftCodeDef 100)] , goldenBudget "map2-budget" $ map2 `unsafeApplyCode` (liftCodeDef 100) + , goldenPirReadable "map3" map2 + , goldenUPlcReadable "map3" map2 + , goldenEvalCekCatch "map3" $ [map2 `unsafeApplyCode` (liftCodeDef 100)] + , goldenBudget "map3-budget" $ map2 `unsafeApplyCode` (liftCodeDef 100) ] propertyTests :: TestTree @@ -127,6 +131,32 @@ map2 = ||] ) +map3 :: CompiledCode (Integer -> [(Integer, PlutusTx.BuiltinString)]) +map3 = + $$( compile + [|| + \n -> + let m1 = + Data.AssocMap.unsafeFromList + [ (n PlutusTx.+ 1, "one") + , (n PlutusTx.+ 2, "two") + , (n PlutusTx.+ 3, "three") + , (n PlutusTx.+ 4, "four") + , (n PlutusTx.+ 5, "five") + ] + m2 = + Data.AssocMap.unsafeFromList + [ (n PlutusTx.+ 3, "THREE") + , (n PlutusTx.+ 4, "FOUR") + , (n PlutusTx.+ 6, "SIX") + , (n PlutusTx.+ 7, "SEVEN") + ] + m = Data.AssocMap.union m1 m2 + f = these id id PlutusTx.appendByteString + in PlutusTx.fmap (\(k, v) -> (k, PlutusTx.decodeUtf8 (f v))) (Data.AssocMap.toList m) + ||] + ) + -- | The semantics of PlutusTx maps and their operations. -- The 'PlutusTx' implementations maps ('Data.AssocMap.Map' and 'AssocMap.Map') -- are checked against the semantics to ensure correctness. diff --git a/plutus-tx-plugin/test/Budget/9.6/map3-budget.budget.golden b/plutus-tx-plugin/test/Budget/9.6/map3-budget.budget.golden new file mode 100644 index 00000000000..102157ec94e --- /dev/null +++ b/plutus-tx-plugin/test/Budget/9.6/map3-budget.budget.golden @@ -0,0 +1,2 @@ +({cpu: 160633417 +| mem: 416622}) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Budget/9.6/map3.eval.golden b/plutus-tx-plugin/test/Budget/9.6/map3.eval.golden new file mode 100644 index 00000000000..e8e3b12565c --- /dev/null +++ b/plutus-tx-plugin/test/Budget/9.6/map3.eval.golden @@ -0,0 +1,27 @@ +(constr + 1 + (constr 0 (con integer 105) (con string "five")) + (constr + 1 + (constr 0 (con integer 104) (con string "fourFOUR")) + (constr + 1 + (constr 0 (con integer 103) (con string "threeTHREE")) + (constr + 1 + (constr 0 (con integer 102) (con string "two")) + (constr + 1 + (constr 0 (con integer 101) (con string "one")) + (constr + 1 + (constr 0 (con integer 106) (con string "SIX")) + (constr + 1 (constr 0 (con integer 107) (con string "SEVEN")) (constr 0) + ) + ) + ) + ) + ) + ) +) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Budget/9.6/map3.pir.golden b/plutus-tx-plugin/test/Budget/9.6/map3.pir.golden new file mode 100644 index 00000000000..8289ed83adf --- /dev/null +++ b/plutus-tx-plugin/test/Budget/9.6/map3.pir.golden @@ -0,0 +1,340 @@ +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 integer bytestring) + = \(xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> List (Tuple2 integer bytestring)} + xs + (\(ds : Unit) -> Nil {Tuple2 integer bytestring}) + (\(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 integer bytestring} + (Tuple2 + {integer} + {bytestring} + (unIData (fstPair {data} {data} hd)) + (unBData (sndPair {data} {data} hd))) + (go tl)) + Unit +in +letrec + !go : list (pair data data) -> list (pair data data) -> list (pair data data) + = \(acc : list (pair data data)) (xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> list (pair data data)} + xs + (\(ds : Unit) -> acc) + (\(ds : Unit) -> + go + (mkCons {pair data data} (headList {pair data data} xs) acc) + (tailList {pair data data} xs)) + Unit +in +let + data (Maybe :: * -> *) a | Maybe_match where + Just : a -> Maybe a + Nothing : Maybe a + !matchList : all a r. list a -> r -> (a -> list a -> r) -> r + = /\a r -> + \(l : list a) (nilCase : r) (consCase : a -> list a -> r) -> + chooseList + {a} + {Unit -> r} + l + (\(ds : Unit) -> nilCase) + (\(ds : Unit) -> consCase (headList {a} l) (tailList {a} l)) + Unit + data Bool | Bool_match where + True : Bool + False : Bool +in +letrec + !`$fToBuiltinListBuiltinList_$ctoBuiltin` : + List (Tuple2 data data) -> list (pair data data) + = \(ds : List (Tuple2 data data)) -> + List_match + {Tuple2 data data} + ds + {all dead. list (pair data data)} + (/\dead -> []) + (\(d : Tuple2 data data) (ds : List (Tuple2 data data)) -> + /\dead -> + mkCons + {pair data data} + (Tuple2_match + {data} + {data} + d + {pair data data} + (\(d : data) (d : data) -> mkPairData d d)) + (`$fToBuiltinListBuiltinList_$ctoBuiltin` ds)) + {all dead. dead} +in +let + !unsafeFromList : + all k a. + (\a -> a -> data) k -> + (\a -> a -> data) a -> + List (Tuple2 k a) -> + (\k a -> list (pair data data)) k a + = /\k a -> + \(`$dToData` : (\a -> a -> data) k) + (`$dToData` : (\a -> a -> data) a) -> + letrec + !go : List (Tuple2 k a) -> List (Tuple2 data data) + = \(ds : List (Tuple2 k a)) -> + List_match + {Tuple2 k a} + ds + {all dead. List (Tuple2 data data)} + (/\dead -> Nil {Tuple2 data data}) + (\(x : Tuple2 k a) (xs : List (Tuple2 k a)) -> + /\dead -> + Cons + {Tuple2 data data} + (Tuple2_match + {k} + {a} + x + {Tuple2 data data} + (\(k : k) (a : a) -> + Tuple2 + {data} + {data} + (`$dToData` k) + (`$dToData` a))) + (go xs)) + {all dead. dead} + in + \(eta : List (Tuple2 k a)) -> + `$fToBuiltinListBuiltinList_$ctoBuiltin` (go eta) +in +\(n : integer) -> + let + !nt : list (pair data data) + = unsafeFromList + {integer} + {bytestring} + (\(i : integer) -> iData i) + bData + ((let + a = Tuple2 integer bytestring + 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 integer bytestring -> a -> a) (n : a) -> + c + (Tuple2 {integer} {bytestring} (addInteger 3 n) #5448524545) + (c + (Tuple2 + {integer} + {bytestring} + (addInteger 4 n) + #464f5552) + (c + (Tuple2 + {integer} + {bytestring} + (addInteger 6 n) + #534958) + (c + (Tuple2 + {integer} + {bytestring} + (addInteger 7 n) + #534556454e) + n))))) + in + letrec + !go : list (pair data data) -> list (pair data data) + = \(xs : list (pair data data)) -> + matchList + {pair data data} + {list (pair data data)} + xs + [] + (\(hd : pair data data) (tl : list (pair data data)) -> + let + !v' : data = sndPair {data} {data} hd + !k' : data = fstPair {data} {data} hd + 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 + Maybe_match + {data} + (go nt) + {all dead. list (pair data data)} + (\(r : data) -> + /\dead -> + mkCons + {pair data data} + (mkPairData + k' + (bData (appendByteString (unBData v') (unBData r)))) + (go tl)) + (/\dead -> mkCons {pair data data} (mkPairData k' v') (go tl)) + {all dead. dead}) + in + let + !nt : list (pair data data) + = unsafeFromList + {integer} + {bytestring} + (\(i : integer) -> iData i) + bData + ((let + a = Tuple2 integer bytestring + 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 integer bytestring -> a -> a) (n : a) -> + c + (Tuple2 {integer} {bytestring} (addInteger 1 n) #6f6e65) + (c + (Tuple2 {integer} {bytestring} (addInteger 2 n) #74776f) + (c + (Tuple2 + {integer} + {bytestring} + (addInteger 3 n) + #7468726565) + (c + (Tuple2 + {integer} + {bytestring} + (addInteger 4 n) + #666f7572) + (c + (Tuple2 + {integer} + {bytestring} + (addInteger 5 n) + #66697665) + n)))))) + in + letrec + !go : list (pair data data) -> list (pair data data) + = \(xs : list (pair data data)) -> + matchList + {pair data data} + {list (pair data data)} + xs + [] + (\(hd : pair data data) (tl : list (pair data data)) -> + let + !tl' : list (pair data data) = go tl + in + Bool_match + (let + !k : data = fstPair {data} {data} hd + in + letrec + !go : list (pair data data) -> Bool + = \(xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> Bool} + xs + (\(ds : Unit) -> False) + (\(ds : Unit) -> + ifThenElse + {all dead. Bool} + (equalsData + k + (fstPair + {data} + {data} + (headList {pair data data} xs))) + (/\dead -> + let + !ds : list (pair data data) + = tailList {pair data data} xs + in + True) + (/\dead -> go (tailList {pair data data} xs)) + {all dead. dead}) + Unit + in + go nt) + {all dead. list (pair data data)} + (/\dead -> tl') + (/\dead -> mkCons {pair data data} hd tl') + {all dead. dead}) + in + let + !nt : list (pair data data) + = let + !rs' : list (pair data data) = go nt + !ls' : list (pair data data) = go nt + in + go rs' ls' + in + (let + a = Tuple2 integer bytestring + in + /\b -> + \(f : a -> b) -> + letrec + !go : List a -> List b + = \(ds : List a) -> + List_match + {a} + ds + {all dead. List b} + (/\dead -> Nil {b}) + (\(x : a) (xs : List a) -> /\dead -> Cons {b} (f x) (go xs)) + {all dead. dead} + in + \(eta : List a) -> go eta) + {Tuple2 integer string} + (\(ds : Tuple2 integer bytestring) -> + Tuple2_match + {integer} + {bytestring} + ds + {Tuple2 integer string} + (\(k : integer) (v : bytestring) -> + Tuple2 {integer} {string} k (decodeUtf8 v))) + (go nt) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Budget/9.6/map3.uplc.golden b/plutus-tx-plugin/test/Budget/9.6/map3.uplc.golden new file mode 100644 index 00000000000..c3b5c686f66 --- /dev/null +++ b/plutus-tx-plugin/test/Budget/9.6/map3.uplc.golden @@ -0,0 +1,272 @@ +program + 1.1.0 + ((\fix1 -> + (\go -> + (\go -> + (\matchList -> + (\`$fToBuiltinListBuiltinList_$ctoBuiltin` + n -> + (\unsafeFromList -> + (\cse -> + (\cse -> + (\nt -> + (\go -> + (\nt -> + (\nt -> + fix1 + (\go + ds -> + force + (case + ds + [ (delay (constr 0 [])) + , (\x + xs -> + delay + (constr 1 + [ (case + x + [ (\k + v -> + constr 0 + [ k + , (decodeUtf8 + v) ]) ]) + , (go xs) ])) ])) + (go nt)) + ((\rs' -> + (\ls' -> go rs' ls') (go nt)) + (fix1 + (\go + xs -> + matchList + xs + [] + (\hd + tl -> + (\tl' -> + force + (case + ((\k -> + fix1 + (\go + xs -> + force + (force + chooseList) + xs + (\ds -> + constr 1 + []) + (\ds -> + force + (force + ifThenElse + (equalsData + k + (force + (force + fstPair) + (force + headList + xs))) + (delay + ((\ds -> + constr 0 + [ ]) + (force + tailList + xs))) + (delay + (go + (force + tailList + xs))))) + (constr 0 + [])) + nt) + (force + (force + fstPair) + hd)) + [ (delay tl') + , (delay + (force mkCons + hd + tl')) ])) + (go tl))) + nt))) + (unsafeFromList + (\i -> iData i) + bData + (constr 1 + [ (constr 0 + [(addInteger 1 n), #6f6e65]) + , (constr 1 + [ (constr 0 + [(addInteger 2 n), #74776f]) + , (constr 1 + [ (constr 0 + [cse, #7468726565]) + , (constr 1 + [ (constr 0 + [cse, #666f7572]) + , (constr 1 + [ (constr 0 + [ (addInteger + 5 + n) + , #66697665 ]) + , (constr 0 + [ ]) ]) ]) ]) ]) ]))) + (fix1 + (\go + xs -> + matchList + xs + [] + (\hd + tl -> + (\v' -> + (\k' -> + force + (case + (fix1 + (\go + xs -> + force + (force chooseList) + xs + (\ds -> + constr 1 []) + (\ds -> + (\hd -> + force + (force + ifThenElse + (equalsData + k' + (force + (force + fstPair) + hd)) + (delay + ((\ds -> + constr 0 + [ (force + (force + sndPair) + hd) ]) + (force + tailList + xs))) + (delay + (go + (force + tailList + xs))))) + (force + headList + xs)) + (constr 0 [])) + nt) + [ (\r -> + delay + (force + mkCons + (mkPairData + k' + (bData + (appendByteString + (unBData + v') + (unBData + r)))) + (go tl))) + , (delay + (force mkCons + (mkPairData k' v') + (go tl))) ])) + (force (force fstPair) hd)) + (force (force sndPair) hd))))) + (unsafeFromList + (\i -> iData i) + bData + (constr 1 + [ (constr 0 [cse, #5448524545]) + , (constr 1 + [ (constr 0 [cse, #464f5552]) + , (constr 1 + [ (constr 0 + [(addInteger 6 n), #534958]) + , (constr 1 + [ (constr 0 + [ (addInteger 7 n) + , #534556454e ]) + , (constr 0 []) ]) ]) ]) ]))) + (addInteger 4 n)) + (addInteger 3 n)) + (\`$dToData` `$dToData` -> + (\go eta -> + `$fToBuiltinListBuiltinList_$ctoBuiltin` (go eta)) + (fix1 + (\go ds -> + force + (case + ds + [ (delay (constr 0 [])) + , (\x xs -> + delay + (constr 1 + [ (case + x + [ (\k a -> + constr 0 + [ (`$dToData` k) + , (`$dToData` a) ]) ]) + , (go xs) ])) ]))))) + (fix1 + (\`$fToBuiltinListBuiltinList_$ctoBuiltin` ds -> + force + (case + ds + [ (delay []) + , (\d ds -> + delay + (force mkCons + (case d [(\d d -> mkPairData d d)]) + (`$fToBuiltinListBuiltinList_$ctoBuiltin` + ds))) ])))) + (\l nilCase consCase -> + force (force chooseList) + l + (\ds -> nilCase) + (\ds -> consCase (force headList l) (force tailList l)) + (constr 0 []))) + (fix1 + (\go acc xs -> + force (force chooseList) + xs + (\ds -> acc) + (\ds -> + go + (force mkCons (force headList xs) acc) + (force tailList xs)) + (constr 0 [])))) + (fix1 + (\go xs -> + force (force chooseList) + xs + (\ds -> constr 0 []) + (\ds -> + (\hd -> + (\tl -> + constr 1 + [ (constr 0 + [ (unIData (force (force fstPair) hd)) + , (unBData (force (force sndPair) hd)) ]) + , (go tl) ]) + (force tailList xs)) + (force headList xs)) + (constr 0 [])))) + (\f -> (\s -> s s) (\s x -> f (s s) x))) \ No newline at end of file From 2862dec1a8b0b5e9bb95bd9c374066e1da6a40bf Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Wed, 8 May 2024 17:28:45 +0300 Subject: [PATCH 18/41] Add docs to integration tests Signed-off-by: Ana Pantilie --- plutus-tx-plugin/test/AssocMap/Spec.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/plutus-tx-plugin/test/AssocMap/Spec.hs b/plutus-tx-plugin/test/AssocMap/Spec.hs index ea768a0e858..dc4ea865948 100644 --- a/plutus-tx-plugin/test/AssocMap/Spec.hs +++ b/plutus-tx-plugin/test/AssocMap/Spec.hs @@ -72,6 +72,7 @@ propertyTests = , testProperty "builtinDataEncoding" builtinDataEncodingSpec ] +-- | Test the performance and interaction between 'insert', 'delete' and 'lookup'. map1 :: CompiledCode ( Integer -> @@ -106,6 +107,9 @@ map1 = ||] ) +-- | Test that 'unionWith' is implemented correctly. Due to the nature of 'Map k v', +-- some type errors are only caught when running the PlutusTx compiler on code which uses +-- 'unionWith'. map2 :: CompiledCode (Integer -> [(Integer, PlutusTx.BuiltinString)]) map2 = $$( compile @@ -131,6 +135,8 @@ map2 = ||] ) +-- | Similar to map2, but uses 'union' instead of 'unionWith'. Evaluating 'map3' and 'map2' +-- should yield the same result. map3 :: CompiledCode (Integer -> [(Integer, PlutusTx.BuiltinString)]) map3 = $$( compile From 1f7f6340f32061e71ad6106ad05cb91d4466f196 Mon Sep 17 00:00:00 2001 From: effectfully Date: Fri, 10 May 2024 01:51:05 +0200 Subject: [PATCH 19/41] Try naive type families --- .../StrictLetRec/strictLetRec.uplc.golden | 1 + plutus-tx/plutus-tx.cabal | 2 + plutus-tx/src/PlutusTx/Builtins.hs | 74 +-- plutus-tx/src/PlutusTx/Builtins/Class.hs | 457 +++++++++--------- plutus-tx/src/PlutusTx/Builtins/Internal.hs | 14 + plutus-tx/src/PlutusTx/Builtins/IsBuiltin.hs | 164 +++++++ plutus-tx/src/PlutusTx/Builtins/IsOpaque.hs | 128 +++++ plutus-tx/src/PlutusTx/IsData/Class.hs | 4 +- plutus-tx/src/PlutusTx/Lift/Class.hs | 8 +- 9 files changed, 585 insertions(+), 267 deletions(-) create mode 100644 plutus-core/plutus-ir/test/PlutusIR/Transform/StrictLetRec/strictLetRec.uplc.golden create mode 100644 plutus-tx/src/PlutusTx/Builtins/IsBuiltin.hs create mode 100644 plutus-tx/src/PlutusTx/Builtins/IsOpaque.hs diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/StrictLetRec/strictLetRec.uplc.golden b/plutus-core/plutus-ir/test/PlutusIR/Transform/StrictLetRec/strictLetRec.uplc.golden new file mode 100644 index 00000000000..7d06755f761 --- /dev/null +++ b/plutus-core/plutus-ir/test/PlutusIR/Transform/StrictLetRec/strictLetRec.uplc.golden @@ -0,0 +1 @@ +(\xxx -> 1) ((\s -> s s) (\s -> force trace "hello" (\z -> s s z))) \ No newline at end of file diff --git a/plutus-tx/plutus-tx.cabal b/plutus-tx/plutus-tx.cabal index 5f2977d26dc..424d094c795 100644 --- a/plutus-tx/plutus-tx.cabal +++ b/plutus-tx/plutus-tx.cabal @@ -72,6 +72,8 @@ library PlutusTx.Builtins PlutusTx.Builtins.Class PlutusTx.Builtins.Internal + PlutusTx.Builtins.IsBuiltin + PlutusTx.Builtins.IsOpaque PlutusTx.Code PlutusTx.Coverage PlutusTx.Either diff --git a/plutus-tx/src/PlutusTx/Builtins.hs b/plutus-tx/src/PlutusTx/Builtins.hs index 775d24c9bfc..7f9474ab617 100644 --- a/plutus-tx/src/PlutusTx/Builtins.hs +++ b/plutus-tx/src/PlutusTx/Builtins.hs @@ -102,6 +102,8 @@ module PlutusTx.Builtins ( , bls12_381_mulMlResult , bls12_381_finalVerify -- * Conversions + , fromOpaque + , toOpaque , fromBuiltin , toBuiltin , integerToByteString @@ -111,11 +113,12 @@ module PlutusTx.Builtins ( import Data.Maybe import PlutusTx.Base (const, uncurry) import PlutusTx.Bool (Bool (..)) -import PlutusTx.Builtins.Class import PlutusTx.Builtins.Internal (BuiltinBLS12_381_G1_Element (..), BuiltinBLS12_381_G2_Element (..), BuiltinBLS12_381_MlResult (..), BuiltinByteString (..), BuiltinData, BuiltinString) import PlutusTx.Builtins.Internal qualified as BI +import PlutusTx.Builtins.IsBuiltin +import PlutusTx.Builtins.IsOpaque import PlutusTx.Integer (Integer) import GHC.ByteOrder (ByteOrder (BigEndian, LittleEndian)) @@ -128,12 +131,12 @@ appendByteString = BI.appendByteString {-# INLINABLE consByteString #-} -- | Adds a byte to the front of a 'ByteString'. consByteString :: Integer -> BuiltinByteString -> BuiltinByteString -consByteString n bs = BI.consByteString (toBuiltin n) bs +consByteString n bs = BI.consByteString (toOpaque n) bs {-# INLINABLE sliceByteString #-} -- | Returns the substring of a 'ByteString' from index 'start' of length 'n'. sliceByteString :: Integer -> Integer -> BuiltinByteString -> BuiltinByteString -sliceByteString start n bs = BI.sliceByteString (toBuiltin start) (toBuiltin n) bs +sliceByteString start n bs = BI.sliceByteString (toOpaque start) (toOpaque n) bs {-# INLINABLE lengthOfByteString #-} -- | Returns the length of a 'ByteString'. @@ -143,7 +146,7 @@ lengthOfByteString = BI.lengthOfByteString {-# INLINABLE indexByteString #-} -- | Returns the byte of a 'ByteString' at index. indexByteString :: BuiltinByteString -> Integer -> Integer -indexByteString b n = BI.indexByteString b (toBuiltin n) +indexByteString b n = BI.indexByteString b (toOpaque n) {-# INLINABLE emptyByteString #-} -- | An empty 'ByteString'. @@ -184,22 +187,23 @@ verifyEd25519Signature -> BuiltinByteString -- ^ Message (arbirtary length) -> BuiltinByteString -- ^ Signature (64 bytes) -> Bool -verifyEd25519Signature pubKey message signature = fromBuiltin (BI.verifyEd25519Signature pubKey message signature) +verifyEd25519Signature pubKey message signature = + fromOpaque (BI.verifyEd25519Signature pubKey message signature) {-# INLINABLE equalsByteString #-} -- | Check if two 'ByteString's are equal. equalsByteString :: BuiltinByteString -> BuiltinByteString -> Bool -equalsByteString x y = fromBuiltin (BI.equalsByteString x y) +equalsByteString x y = fromOpaque (BI.equalsByteString x y) {-# INLINABLE lessThanByteString #-} -- | Check if one 'ByteString' is less than another. lessThanByteString :: BuiltinByteString -> BuiltinByteString -> Bool -lessThanByteString x y = fromBuiltin (BI.lessThanByteString x y) +lessThanByteString x y = fromOpaque (BI.lessThanByteString x y) {-# INLINABLE lessThanEqualsByteString #-} -- | Check if one 'ByteString' is less than or equal to another. lessThanEqualsByteString :: BuiltinByteString -> BuiltinByteString -> Bool -lessThanEqualsByteString x y = fromBuiltin (BI.lessThanEqualsByteString x y) +lessThanEqualsByteString x y = fromOpaque (BI.lessThanEqualsByteString x y) {-# INLINABLE greaterThanByteString #-} -- | Check if one 'ByteString' is greater than another. @@ -257,7 +261,7 @@ verifyEcdsaSecp256k1Signature -> BuiltinByteString -- ^ Signature (64 bytes) -> Bool verifyEcdsaSecp256k1Signature vk msg sig = - fromBuiltin (BI.verifyEcdsaSecp256k1Signature vk msg sig) + fromOpaque (BI.verifyEcdsaSecp256k1Signature vk msg sig) {-# INLINEABLE verifySchnorrSecp256k1Signature #-} -- | Given a Schnorr SECP256k1 verification key, a Schnorr SECP256k1 signature, @@ -291,42 +295,42 @@ verifySchnorrSecp256k1Signature -> BuiltinByteString -- ^ Signature (64 bytes) -> Bool verifySchnorrSecp256k1Signature vk msg sig = - fromBuiltin (BI.verifySchnorrSecp256k1Signature vk msg sig) + fromOpaque (BI.verifySchnorrSecp256k1Signature vk msg sig) {-# INLINABLE addInteger #-} -- | Add two 'Integer's. addInteger :: Integer -> Integer -> Integer -addInteger x y = fromBuiltin (BI.addInteger (toBuiltin x) (toBuiltin y)) +addInteger x y = fromOpaque (BI.addInteger (toOpaque x) (toOpaque y)) {-# INLINABLE subtractInteger #-} -- | Subtract two 'Integer's. subtractInteger :: Integer -> Integer -> Integer -subtractInteger x y = fromBuiltin (BI.subtractInteger (toBuiltin x) (toBuiltin y)) +subtractInteger x y = fromOpaque (BI.subtractInteger (toOpaque x) (toOpaque y)) {-# INLINABLE multiplyInteger #-} -- | Multiply two 'Integer's. multiplyInteger :: Integer -> Integer -> Integer -multiplyInteger x y = fromBuiltin (BI.multiplyInteger (toBuiltin x) (toBuiltin y)) +multiplyInteger x y = fromOpaque (BI.multiplyInteger (toOpaque x) (toOpaque y)) {-# INLINABLE divideInteger #-} -- | Divide two integers. divideInteger :: Integer -> Integer -> Integer -divideInteger x y = fromBuiltin (BI.divideInteger (toBuiltin x) (toBuiltin y)) +divideInteger x y = fromOpaque (BI.divideInteger (toOpaque x) (toOpaque y)) {-# INLINABLE modInteger #-} -- | Integer modulo operation. modInteger :: Integer -> Integer -> Integer -modInteger x y = fromBuiltin (BI.modInteger (toBuiltin x) (toBuiltin y)) +modInteger x y = fromOpaque (BI.modInteger (toOpaque x) (toOpaque y)) {-# INLINABLE quotientInteger #-} -- | Quotient of two integers. quotientInteger :: Integer -> Integer -> Integer -quotientInteger x y = fromBuiltin (BI.quotientInteger (toBuiltin x) (toBuiltin y)) +quotientInteger x y = fromOpaque (BI.quotientInteger (toOpaque x) (toOpaque y)) {-# INLINABLE remainderInteger #-} -- | Take the remainder of dividing two 'Integer's. remainderInteger :: Integer -> Integer -> Integer -remainderInteger x y = fromBuiltin (BI.remainderInteger (toBuiltin x) (toBuiltin y)) +remainderInteger x y = fromOpaque (BI.remainderInteger (toOpaque x) (toOpaque y)) {-# INLINABLE greaterThanInteger #-} -- | Check whether one 'Integer' is greater than another. @@ -341,22 +345,22 @@ greaterThanEqualsInteger x y = BI.ifThenElse (BI.lessThanInteger x y) False True {-# INLINABLE lessThanInteger #-} -- | Check whether one 'Integer' is less than another. lessThanInteger :: Integer -> Integer -> Bool -lessThanInteger x y = fromBuiltin (BI.lessThanInteger (toBuiltin x) (toBuiltin y)) +lessThanInteger x y = fromOpaque (BI.lessThanInteger (toOpaque x) (toOpaque y)) {-# INLINABLE lessThanEqualsInteger #-} -- | Check whether one 'Integer' is less than or equal to another. lessThanEqualsInteger :: Integer -> Integer -> Bool -lessThanEqualsInteger x y = fromBuiltin (BI.lessThanEqualsInteger (toBuiltin x) (toBuiltin y)) +lessThanEqualsInteger x y = fromOpaque (BI.lessThanEqualsInteger (toOpaque x) (toOpaque y)) {-# INLINABLE equalsInteger #-} -- | Check if two 'Integer's are equal. equalsInteger :: Integer -> Integer -> Bool -equalsInteger x y = fromBuiltin (BI.equalsInteger (toBuiltin x) (toBuiltin y)) +equalsInteger x y = fromOpaque (BI.equalsInteger (toOpaque x) (toOpaque y)) {-# INLINABLE error #-} -- | Aborts evaluation with an error. error :: () -> a -error x = BI.error (toBuiltin x) +error x = BI.error (toOpaque x) {-# INLINABLE appendString #-} -- | Append two 'String's. @@ -371,7 +375,7 @@ emptyString = BI.emptyString {-# INLINABLE equalsString #-} -- | Check if two strings are equal equalsString :: BuiltinString -> BuiltinString -> Bool -equalsString x y = fromBuiltin (BI.equalsString x y) +equalsString x y = fromOpaque (BI.equalsString x y) {-# INLINABLE trace #-} -- | Emit the given string as a trace message before evaluating the argument. @@ -420,17 +424,17 @@ serialiseData = BI.serialiseData {-# INLINABLE mkConstr #-} -- | Constructs a 'BuiltinData' value with the @Constr@ constructor. mkConstr :: Integer -> [BuiltinData] -> BuiltinData -mkConstr i args = BI.mkConstr (toBuiltin i) (toBuiltin args) +mkConstr i args = BI.mkConstr (toOpaque i) (toOpaque args) {-# INLINABLE mkMap #-} -- | Constructs a 'BuiltinData' value with the @Map@ constructor. mkMap :: [(BuiltinData, BuiltinData)] -> BuiltinData -mkMap es = BI.mkMap (toBuiltin es) +mkMap es = BI.mkMap (toOpaque es) {-# INLINABLE mkList #-} -- | Constructs a 'BuiltinData' value with the @List@ constructor. mkList :: [BuiltinData] -> BuiltinData -mkList l = BI.mkList (toBuiltin l) +mkList l = BI.mkList (toOpaque l) {-# INLINABLE mkI #-} -- | Constructs a 'BuiltinData' value with the @I@ constructor. @@ -445,22 +449,22 @@ mkB = BI.mkB {-# INLINABLE unsafeDataAsConstr #-} -- | Deconstructs a 'BuiltinData' as a @Constr@, or fails if it is not one. unsafeDataAsConstr :: BuiltinData -> (Integer, [BuiltinData]) -unsafeDataAsConstr d = fromBuiltin (BI.unsafeDataAsConstr d) +unsafeDataAsConstr d = fromOpaque (BI.unsafeDataAsConstr d) {-# INLINABLE unsafeDataAsMap #-} -- | Deconstructs a 'BuiltinData' as a @Map@, or fails if it is not one. unsafeDataAsMap :: BuiltinData -> [(BuiltinData, BuiltinData)] -unsafeDataAsMap d = fromBuiltin (BI.unsafeDataAsMap d) +unsafeDataAsMap d = fromOpaque (BI.unsafeDataAsMap d) {-# INLINABLE unsafeDataAsList #-} -- | Deconstructs a 'BuiltinData' as a @List@, or fails if it is not one. unsafeDataAsList :: BuiltinData -> [BuiltinData] -unsafeDataAsList d = fromBuiltin (BI.unsafeDataAsList d) +unsafeDataAsList d = fromOpaque (BI.unsafeDataAsList d) {-# INLINABLE unsafeDataAsI #-} -- | Deconstructs a 'BuiltinData' as an @I@, or fails if it is not one. unsafeDataAsI :: BuiltinData -> Integer -unsafeDataAsI d = fromBuiltin (BI.unsafeDataAsI d) +unsafeDataAsI d = fromOpaque (BI.unsafeDataAsI d) {-# INLINABLE unsafeDataAsB #-} -- | Deconstructs a 'BuiltinData' as a @B@, or fails if it is not one. @@ -470,7 +474,7 @@ unsafeDataAsB = BI.unsafeDataAsB {-# INLINABLE equalsData #-} -- | Check if two 'BuiltinData's are equal. equalsData :: BuiltinData -> BuiltinData -> Bool -equalsData d1 d2 = fromBuiltin (BI.equalsData d1 d2) +equalsData d1 d2 = fromOpaque (BI.equalsData d1 d2) {-# INLINABLE matchData #-} -- | Given a 'BuiltinData' value and matching functions for the five constructors, @@ -517,7 +521,7 @@ matchData' d constrCase mapCase listCase iCase bCase = -- G1 -- {-# INLINABLE bls12_381_G1_equals #-} bls12_381_G1_equals :: BuiltinBLS12_381_G1_Element -> BuiltinBLS12_381_G1_Element -> Bool -bls12_381_G1_equals a b = fromBuiltin (BI.bls12_381_G1_equals a b) +bls12_381_G1_equals a b = fromOpaque (BI.bls12_381_G1_equals a b) {-# INLINABLE bls12_381_G1_add #-} bls12_381_G1_add :: BuiltinBLS12_381_G1_Element -> BuiltinBLS12_381_G1_Element -> BuiltinBLS12_381_G1_Element @@ -554,7 +558,7 @@ bls12_381_G1_compressed_generator = BI.bls12_381_G1_compressed_generator -- G2 -- {-# INLINABLE bls12_381_G2_equals #-} bls12_381_G2_equals :: BuiltinBLS12_381_G2_Element -> BuiltinBLS12_381_G2_Element -> Bool -bls12_381_G2_equals a b = fromBuiltin (BI.bls12_381_G2_equals a b) +bls12_381_G2_equals a b = fromOpaque (BI.bls12_381_G2_equals a b) {-# INLINABLE bls12_381_G2_add #-} bls12_381_G2_add :: BuiltinBLS12_381_G2_Element -> BuiltinBLS12_381_G2_Element -> BuiltinBLS12_381_G2_Element @@ -599,7 +603,7 @@ bls12_381_mulMlResult = BI.bls12_381_mulMlResult {-# INLINABLE bls12_381_finalVerify #-} bls12_381_finalVerify :: BuiltinBLS12_381_MlResult -> BuiltinBLS12_381_MlResult -> Bool -bls12_381_finalVerify a b = fromBuiltin (BI.bls12_381_finalVerify a b) +bls12_381_finalVerify a b = fromOpaque (BI.bls12_381_finalVerify a b) -- Bitwise conversions @@ -626,7 +630,7 @@ byteOrderToBool LittleEndian = False -- fit into a bytestring of length 8192. {-# INLINABLE integerToByteString #-} integerToByteString :: ByteOrder -> Integer -> Integer -> BuiltinByteString -integerToByteString endianness = BI.integerToByteString (toBuiltin (byteOrderToBool endianness)) +integerToByteString endianness = BI.integerToByteString (toOpaque (byteOrderToBool endianness)) -- | Convert a 'BuiltinByteString' to a 'BuiltinInteger', as described in -- [CIP-0087](https://github.com/mlabs-haskell/CIPs/tree/koz/to-from-bytestring/CIP-XXXX). @@ -636,4 +640,4 @@ integerToByteString endianness = BI.integerToByteString (toBuiltin (byteOrderToB {-# INLINABLE byteStringToInteger #-} byteStringToInteger :: ByteOrder -> BuiltinByteString -> Integer byteStringToInteger endianness = - BI.byteStringToInteger (toBuiltin (byteOrderToBool endianness)) + BI.byteStringToInteger (toOpaque (byteOrderToBool endianness)) diff --git a/plutus-tx/src/PlutusTx/Builtins/Class.hs b/plutus-tx/src/PlutusTx/Builtins/Class.hs index a6de8b9223a..94eba15fbf7 100644 --- a/plutus-tx/src/PlutusTx/Builtins/Class.hs +++ b/plutus-tx/src/PlutusTx/Builtins/Class.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} -- editorconfig-checker-disable-file {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} @@ -8,243 +11,245 @@ {-# OPTIONS_GHC -fno-specialise #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} -module PlutusTx.Builtins.Class where +module PlutusTx.Builtins.Class (module Export) where + +import PlutusTx.Builtins.IsBuiltin as Export + +import Prelude qualified as Haskell (String) import Data.ByteString (ByteString) import PlutusTx.Builtins.Internal import Data.String (IsString (..)) import Data.Text (Text, pack) - import GHC.Magic qualified as Magic + import PlutusCore.Crypto.BLS12_381.G1 qualified as BLS12_381.G1 (Element) import PlutusCore.Crypto.BLS12_381.G2 qualified as BLS12_381.G2 (Element) import PlutusCore.Crypto.BLS12_381.Pairing qualified as BLS12_381.Pairing (MlResult) +import PlutusCore.Default qualified as PLC import PlutusTx.Base (const, id, ($)) import PlutusTx.Bool (Bool (..)) import PlutusTx.Integer (Integer) -import Prelude qualified as Haskell (String) --- See Note [Builtin types and their Haskell versions] -{-| -A class witnessing the ability to convert from the builtin representation to the Haskell representation. --} -class FromBuiltin arep a | arep -> a where - fromBuiltin :: arep -> a - --- See Note [Builtin types and their Haskell versions] -{-| -A class witnessing the ability to convert from the Haskell representation to the builtin representation. --} -class ToBuiltin a arep | a -> arep where - toBuiltin :: a -> arep - -instance FromBuiltin BuiltinInteger Integer where - {-# INLINABLE fromBuiltin #-} - fromBuiltin = id -instance ToBuiltin Integer BuiltinInteger where - {-# INLINABLE toBuiltin #-} - toBuiltin = id - -instance FromBuiltin BuiltinBool Bool where - {-# INLINABLE fromBuiltin #-} - fromBuiltin b = ifThenElse b True False -instance ToBuiltin Bool BuiltinBool where - {-# INLINABLE toBuiltin #-} - toBuiltin b = if b then true else false - -instance FromBuiltin BuiltinUnit () where - -- See Note [Strict conversions to/from unit] - {-# INLINABLE fromBuiltin #-} - fromBuiltin u = chooseUnit u () -instance ToBuiltin () BuiltinUnit where - -- See Note [Strict conversions to/from unit] - {-# INLINABLE toBuiltin #-} - toBuiltin x = case x of () -> unitval - -instance FromBuiltin BuiltinByteString ByteString where - {-# INLINABLE fromBuiltin #-} - fromBuiltin (BuiltinByteString b) = b -instance ToBuiltin ByteString BuiltinByteString where - {-# INLINABLE toBuiltin #-} - toBuiltin = BuiltinByteString - --- We can't put this in `Builtins.hs`, since that force `O0` deliberately, which prevents --- the unfoldings from going in. So we just stick it here. Fiddly. -instance IsString BuiltinString where - -- Try and make sure the dictionary selector goes away, it's simpler to match on - -- the application of 'stringToBuiltinString' - {-# INLINE fromString #-} - -- See Note [noinline hack] - fromString = Magic.noinline stringToBuiltinString - -{-# INLINABLE stringToBuiltinString #-} -stringToBuiltinString :: Haskell.String -> BuiltinString --- To explain why the obfuscatedId is here --- See Note [noinline hack] -stringToBuiltinString str = obfuscatedId (BuiltinString $ pack str) - -{-# NOINLINE obfuscatedId #-} -obfuscatedId :: a -> a -obfuscatedId a = a - -instance FromBuiltin BuiltinString Text where - {-# INLINABLE fromBuiltin #-} - fromBuiltin (BuiltinString t) = t -instance ToBuiltin Text BuiltinString where - {-# INLINABLE toBuiltin #-} - toBuiltin = BuiltinString - -{- Same noinline hack as with `String` type. -} -instance IsString BuiltinByteString where - -- Try and make sure the dictionary selector goes away, it's simpler to match on - -- the application of 'stringToBuiltinByteString' - {-# INLINE fromString #-} - -- See Note [noinline hack] - fromString = Magic.noinline stringToBuiltinByteString - -{-# INLINABLE stringToBuiltinByteString #-} -stringToBuiltinByteString :: Haskell.String -> BuiltinByteString -stringToBuiltinByteString str = encodeUtf8 $ stringToBuiltinString str - -instance (FromBuiltin arep a, FromBuiltin brep b) => FromBuiltin (BuiltinPair arep brep) (a,b) where - {-# INLINABLE fromBuiltin #-} - fromBuiltin p = (fromBuiltin $ fst p, fromBuiltin $ snd p) -instance ToBuiltin (BuiltinData, BuiltinData) (BuiltinPair BuiltinData BuiltinData) where - {-# INLINABLE toBuiltin #-} - toBuiltin (d1, d2) = mkPairData d1 d2 - -instance FromBuiltin arep a => FromBuiltin (BuiltinList arep) [a] where - {-# INLINABLE fromBuiltin #-} - fromBuiltin = go - where - -- The combination of both INLINABLE and a type signature seems to stop this getting lifted to the top - -- level, which means it gets a proper unfolding, which means that specialization can work, which can - -- actually help quite a bit here. - {-# INLINABLE go #-} - go :: BuiltinList arep -> [a] - -- Note that we are using builtin chooseList here so this is *strict* application! So we need to do - -- the manual laziness ourselves. - go l = chooseList l (const []) (\_ -> fromBuiltin (head l):go (tail l)) unitval - -instance ToBuiltin [BuiltinData] (BuiltinList BuiltinData) where - {-# INLINABLE toBuiltin #-} - toBuiltin [] = mkNilData unitval - toBuiltin (d:ds) = mkCons d (toBuiltin ds) - -instance ToBuiltin [(BuiltinData, BuiltinData)] (BuiltinList (BuiltinPair BuiltinData BuiltinData)) where - {-# INLINABLE toBuiltin #-} - toBuiltin [] = mkNilPairData unitval - toBuiltin (d:ds) = mkCons (toBuiltin d) (toBuiltin ds) - -instance FromBuiltin BuiltinData BuiltinData where - {-# INLINABLE fromBuiltin #-} - fromBuiltin = id -instance ToBuiltin BuiltinData BuiltinData where - {-# INLINABLE toBuiltin #-} - toBuiltin = id - -instance FromBuiltin BuiltinBLS12_381_G1_Element BLS12_381.G1.Element where - {-# INLINABLE fromBuiltin #-} - fromBuiltin (BuiltinBLS12_381_G1_Element a) = a -instance ToBuiltin BLS12_381.G1.Element BuiltinBLS12_381_G1_Element where - {-# INLINABLE toBuiltin #-} - toBuiltin = BuiltinBLS12_381_G1_Element - -instance FromBuiltin BuiltinBLS12_381_G2_Element BLS12_381.G2.Element where - {-# INLINABLE fromBuiltin #-} - fromBuiltin (BuiltinBLS12_381_G2_Element a) = a -instance ToBuiltin BLS12_381.G2.Element BuiltinBLS12_381_G2_Element where - {-# INLINABLE toBuiltin #-} - toBuiltin = BuiltinBLS12_381_G2_Element - -instance FromBuiltin BuiltinBLS12_381_MlResult BLS12_381.Pairing.MlResult where - {-# INLINABLE fromBuiltin #-} - fromBuiltin (BuiltinBLS12_381_MlResult a) = a -instance ToBuiltin BLS12_381.Pairing.MlResult BuiltinBLS12_381_MlResult where - {-# INLINABLE toBuiltin #-} - toBuiltin = BuiltinBLS12_381_MlResult - -{- Note [Builtin types and their Haskell versions] -Consider the builtin pair type. In Plutus Tx, we have an (opaque) type for -this. It's opaque because you can't actually pattern match on it, instead you can -only in fact use the specific functions that are available as builtins. - -We _also_ have the normal Haskell pair type. This is very different: you can -pattern match on it, and you can use whatever user-defined functions you like on it. - -Users would really like to use the latter, and not the former. So we often want -to _wrap_ our builtin functions with little adapters that convert between the -"opaque builtin" "version" of a type and the "normal Haskell" "version" of a type. - -This is what the ToBuiltin and FromBuiltin classes do. They let us write wrappers -for builtins relatively consistently by just calling toBuiltin on their arguments -and fromBuiltin on the result. They shouldn't really be used otherwise. - -Ideally, we would not have instances for types which don't have a different -Haskell representation type, such as Integer. Integer in Plutus Tx user code _is_ the -opaque builtin type, we don't expose a different one. So there's no conversion to -do. However, this interacts badly with the instances for polymorphic builtin types, which -also convert the type _inside_ them. (This is necessary to avoid doing multiple -traversals of the type, e.g. we don't want to turn a builtin list into a Haskell -list, and then traverse it again to conver the contents). Then we _need_ instances -for all builtin types, even if they don't quite make sense. - -Possibly this indicates that these type classes are a bit too 'ad-hoc' and we should -get rid of them. --} - -{- Note [Fundeps versus type families in To/FromBuiltin] -We could use a type family here to get the builtin representation of a type. After all, it's -entirely determined by the Haskell type. - -However, this is harder for the plugin to deal with. It's okay to have a type variable -for the representation type that needs to be instantiated later, but it's *not* okay to -have an irreducible type application on a type variable. So fundeps are much nicer here. --} - -{- Note [Strict conversions to/from unit] -Converting to/from unit *should* be straightforward: just `const ()`. -*But* GHC is very good at optimizing this, and we sometimes use unit -where side effects matter, e.g. as the result of `trace`. So GHC will -tend to turn `fromBuiltin (trace s)` into `()`, which is wrong. - -So we want our conversions to/from unit to be strict in Haskell. This -means we need to case pointlessly on the argument, which means we need -case on unit (`chooseUnit`) as a builtin. But then it all works okay. --} - -{- Note [noinline hack] -For some functions we have two conflicting desires: -- We want to have the unfolding available for the plugin. -- We don't want the function to *actually* get inlined before the plugin runs, since we rely -on being able to see the original function for some reason. - -'INLINABLE' achieves the first, but may cause the function to be inlined too soon. - -We can solve this at specific call sites by using the 'noinline' magic function from -GHC. This stops GHC from inlining it. As a bonus, it also won't be inlined if -that function is compiled later into the body of another function. - -We do therefore need to handle 'noinline' in the plugin, as it itself does not have -an unfolding. - -Another annoying quirk: even if you have 'noinline'd a function call, if the body is -a single variable, it will still inline! This is the case for the obvious definition -of 'stringToBuiltinString' (since the newtype constructor vanishes), so we have to add -some obfuscation to the body to prevent it inlining. --} - -{- Note [From/ToBuiltin instances for polymorphic builtin types] -For various technical reasons -(see Note [Representable built-in functions over polymorphic built-in types]) -it's not always easy to provide polymorphic constructors for builtin types, but -we can usually provide destructors. - -What this means in practice is that we can write a generic FromBuiltin instance -for pairs that makes use of polymorphic fst/snd builtins, but we can't write -a polymorphic ToBuiltin instance because we'd need a polymorphic version of (,). - -Instead we write monomorphic instances corresponding to monomorphic constructor -builtins that we add for specific purposes. --} +-- -- See Note [Builtin types and their Haskell versions] +-- {-| +-- A class witnessing the ability to convert from the builtin representation to the Haskell representation. +-- -} +-- class FromBuiltin arep a | arep -> a where +-- fromBuiltin :: arep -> a + +-- -- See Note [Builtin types and their Haskell versions] +-- {-| +-- A class witnessing the ability to convert from the Haskell representation to the builtin representation. +-- -} +-- class ToBuiltin a arep | a -> arep where +-- toBuiltin :: a -> arep + +-- instance FromBuiltin BuiltinInteger Integer where +-- {-# INLINABLE fromBuiltin #-} +-- fromBuiltin = id +-- instance ToBuiltin Integer BuiltinInteger where +-- {-# INLINABLE toBuiltin #-} +-- toBuiltin = id + +-- instance FromBuiltin BuiltinBool Bool where +-- {-# INLINABLE fromBuiltin #-} +-- fromBuiltin b = ifThenElse b True False +-- instance ToBuiltin Bool BuiltinBool where +-- {-# INLINABLE toBuiltin #-} +-- toBuiltin b = if b then true else false + +-- instance FromBuiltin BuiltinUnit () where +-- -- See Note [Strict conversions to/from unit] +-- {-# INLINABLE fromBuiltin #-} +-- fromBuiltin u = chooseUnit u () +-- instance ToBuiltin () BuiltinUnit where +-- -- See Note [Strict conversions to/from unit] +-- {-# INLINABLE toBuiltin #-} +-- toBuiltin x = case x of () -> unitval + +-- instance FromBuiltin BuiltinByteString ByteString where +-- {-# INLINABLE fromBuiltin #-} +-- fromBuiltin (BuiltinByteString b) = b +-- instance ToBuiltin ByteString BuiltinByteString where +-- {-# INLINABLE toBuiltin #-} +-- toBuiltin = BuiltinByteString + +-- -- We can't put this in `Builtins.hs`, since that force `O0` deliberately, which prevents +-- -- the unfoldings from going in. So we just stick it here. Fiddly. +-- instance IsString BuiltinString where +-- -- Try and make sure the dictionary selector goes away, it's simpler to match on +-- -- the application of 'stringToBuiltinString' +-- {-# INLINE fromString #-} +-- -- See Note [noinline hack] +-- fromString = Magic.noinline stringToBuiltinString + +-- {-# INLINABLE stringToBuiltinString #-} +-- stringToBuiltinString :: Haskell.String -> BuiltinString +-- -- To explain why the obfuscatedId is here +-- -- See Note [noinline hack] +-- stringToBuiltinString str = obfuscatedId (BuiltinString $ pack str) + +-- {-# NOINLINE obfuscatedId #-} +-- obfuscatedId :: a -> a +-- obfuscatedId a = a + +-- instance FromBuiltin BuiltinString Text where +-- {-# INLINABLE fromBuiltin #-} +-- fromBuiltin (BuiltinString t) = t +-- instance ToBuiltin Text BuiltinString where +-- {-# INLINABLE toBuiltin #-} +-- toBuiltin = BuiltinString + +-- {- Same noinline hack as with `String` type. -} +-- instance IsString BuiltinByteString where +-- -- Try and make sure the dictionary selector goes away, it's simpler to match on +-- -- the application of 'stringToBuiltinByteString' +-- {-# INLINE fromString #-} +-- -- See Note [noinline hack] +-- fromString = Magic.noinline stringToBuiltinByteString + +-- {-# INLINABLE stringToBuiltinByteString #-} +-- stringToBuiltinByteString :: Haskell.String -> BuiltinByteString +-- stringToBuiltinByteString str = encodeUtf8 $ stringToBuiltinString str + +-- instance (FromBuiltin arep a, FromBuiltin brep b) => FromBuiltin (BuiltinPair arep brep) (a,b) where +-- {-# INLINABLE fromBuiltin #-} +-- fromBuiltin p = (fromBuiltin $ fst p, fromBuiltin $ snd p) +-- instance ToBuiltin (BuiltinData, BuiltinData) (BuiltinPair BuiltinData BuiltinData) where +-- {-# INLINABLE toBuiltin #-} +-- toBuiltin (d1, d2) = mkPairData d1 d2 + +-- instance FromBuiltin arep a => FromBuiltin (BuiltinList arep) [a] where +-- {-# INLINABLE fromBuiltin #-} +-- fromBuiltin = go +-- where +-- -- The combination of both INLINABLE and a type signature seems to stop this getting lifted to the top +-- -- level, which means it gets a proper unfolding, which means that specialization can work, which can +-- -- actually help quite a bit here. +-- {-# INLINABLE go #-} +-- go :: BuiltinList arep -> [a] +-- -- Note that we are using builtin chooseList here so this is *strict* application! So we need to do +-- -- the manual laziness ourselves. +-- go l = chooseList l (const []) (\_ -> fromBuiltin (head l):go (tail l)) unitval + +-- instance (PLC.DefaultUni `PLC.Contains` a, ToBuiltin a arep) => +-- ToBuiltin [a] (BuiltinList arep) where +-- {-# INLINE toBuiltin #-} +-- toBuiltin = goList where +-- goList :: [a] -> BuiltinList arep +-- goList [] = mkNil @a PLC.knownUni +-- goList (d:ds) = mkCons (toBuiltin d) (goList ds) + +-- instance FromBuiltin BuiltinData BuiltinData where +-- {-# INLINABLE fromBuiltin #-} +-- fromBuiltin = id +-- instance ToBuiltin BuiltinData BuiltinData where +-- {-# INLINABLE toBuiltin #-} +-- toBuiltin = id + +-- instance FromBuiltin BuiltinBLS12_381_G1_Element BLS12_381.G1.Element where +-- {-# INLINABLE fromBuiltin #-} +-- fromBuiltin (BuiltinBLS12_381_G1_Element a) = a +-- instance ToBuiltin BLS12_381.G1.Element BuiltinBLS12_381_G1_Element where +-- {-# INLINABLE toBuiltin #-} +-- toBuiltin = BuiltinBLS12_381_G1_Element + +-- instance FromBuiltin BuiltinBLS12_381_G2_Element BLS12_381.G2.Element where +-- {-# INLINABLE fromBuiltin #-} +-- fromBuiltin (BuiltinBLS12_381_G2_Element a) = a +-- instance ToBuiltin BLS12_381.G2.Element BuiltinBLS12_381_G2_Element where +-- {-# INLINABLE toBuiltin #-} +-- toBuiltin = BuiltinBLS12_381_G2_Element + +-- instance FromBuiltin BuiltinBLS12_381_MlResult BLS12_381.Pairing.MlResult where +-- {-# INLINABLE fromBuiltin #-} +-- fromBuiltin (BuiltinBLS12_381_MlResult a) = a +-- instance ToBuiltin BLS12_381.Pairing.MlResult BuiltinBLS12_381_MlResult where +-- {-# INLINABLE toBuiltin #-} +-- toBuiltin = BuiltinBLS12_381_MlResult + +-- {- Note [Builtin types and their Haskell versions] +-- Consider the builtin pair type. In Plutus Tx, we have an (opaque) type for +-- this. It's opaque because you can't actually pattern match on it, instead you can +-- only in fact use the specific functions that are available as builtins. + +-- We _also_ have the normal Haskell pair type. This is very different: you can +-- pattern match on it, and you can use whatever user-defined functions you like on it. + +-- Users would really like to use the latter, and not the former. So we often want +-- to _wrap_ our builtin functions with little adapters that convert between the +-- "opaque builtin" "version" of a type and the "normal Haskell" "version" of a type. + +-- This is what the ToBuiltin and FromBuiltin classes do. They let us write wrappers +-- for builtins relatively consistently by just calling toBuiltin on their arguments +-- and fromBuiltin on the result. They shouldn't really be used otherwise. + +-- Ideally, we would not have instances for types which don't have a different +-- Haskell representation type, such as Integer. Integer in Plutus Tx user code _is_ the +-- opaque builtin type, we don't expose a different one. So there's no conversion to +-- do. However, this interacts badly with the instances for polymorphic builtin types, which +-- also convert the type _inside_ them. (This is necessary to avoid doing multiple +-- traversals of the type, e.g. we don't want to turn a builtin list into a Haskell +-- list, and then traverse it again to conver the contents). Then we _need_ instances +-- for all builtin types, even if they don't quite make sense. + +-- Possibly this indicates that these type classes are a bit too 'ad-hoc' and we should +-- get rid of them. +-- -} + +-- {- Note [Fundeps versus type families in To/FromBuiltin] +-- We could use a type family here to get the builtin representation of a type. After all, it's +-- entirely determined by the Haskell type. + +-- However, this is harder for the plugin to deal with. It's okay to have a type variable +-- for the representation type that needs to be instantiated later, but it's *not* okay to +-- have an irreducible type application on a type variable. So fundeps are much nicer here. +-- -} + +-- {- Note [Strict conversions to/from unit] +-- Converting to/from unit *should* be straightforward: just `const ()`. +-- *But* GHC is very good at optimizing this, and we sometimes use unit +-- where side effects matter, e.g. as the result of `trace`. So GHC will +-- tend to turn `fromBuiltin (trace s)` into `()`, which is wrong. + +-- So we want our conversions to/from unit to be strict in Haskell. This +-- means we need to case pointlessly on the argument, which means we need +-- case on unit (`chooseUnit`) as a builtin. But then it all works okay. +-- -} + +-- {- Note [noinline hack] +-- For some functions we have two conflicting desires: +-- - We want to have the unfolding available for the plugin. +-- - We don't want the function to *actually* get inlined before the plugin runs, since we rely +-- on being able to see the original function for some reason. + +-- 'INLINABLE' achieves the first, but may cause the function to be inlined too soon. + +-- We can solve this at specific call sites by using the 'noinline' magic function from +-- GHC. This stops GHC from inlining it. As a bonus, it also won't be inlined if +-- that function is compiled later into the body of another function. + +-- We do therefore need to handle 'noinline' in the plugin, as it itself does not have +-- an unfolding. + +-- Another annoying quirk: even if you have 'noinline'd a function call, if the body is +-- a single variable, it will still inline! This is the case for the obvious definition +-- of 'stringToBuiltinString' (since the newtype constructor vanishes), so we have to add +-- some obfuscation to the body to prevent it inlining. +-- -} + +-- {- Note [From/ToBuiltin instances for polymorphic builtin types] +-- For various technical reasons +-- (see Note [Representable built-in functions over polymorphic built-in types]) +-- it's not always easy to provide polymorphic constructors for builtin types, but +-- we can usually provide destructors. + +-- What this means in practice is that we can write a generic FromBuiltin instance +-- for pairs that makes use of polymorphic fst/snd builtins, but we can't write +-- a polymorphic ToBuiltin instance because we'd need a polymorphic version of (,). + +-- Instead we write monomorphic instances corresponding to monomorphic constructor +-- builtins that we add for specific purposes. +-- -} diff --git a/plutus-tx/src/PlutusTx/Builtins/Internal.hs b/plutus-tx/src/PlutusTx/Builtins/Internal.hs index 843b63ccc4c..ef24fedf208 100644 --- a/plutus-tx/src/PlutusTx/Builtins/Internal.hs +++ b/plutus-tx/src/PlutusTx/Builtins/Internal.hs @@ -41,6 +41,7 @@ import PlutusCore.Crypto.Ed25519 qualified import PlutusCore.Crypto.Hash qualified as Hash import PlutusCore.Crypto.Secp256k1 qualified import PlutusCore.Data qualified as PLC +import PlutusCore.Default qualified as PLC import PlutusCore.Pretty (Pretty (..), display) import Prettyprinter (viaShow) @@ -365,6 +366,15 @@ fst (BuiltinPair (a, _)) = a snd :: BuiltinPair a b -> b snd (BuiltinPair (_, b)) = b +{-# NOINLINE mkPair #-} +mkPair + :: PLC.DefaultUni (PLC.Esc a) + -> PLC.DefaultUni (PLC.Esc b) + -> aAsBuiltin + -> bAsBuiltin + -> BuiltinPair aAsBuiltin bAsBuiltin +mkPair _ _ x y = BuiltinPair (x, y) + {-# NOINLINE mkPairData #-} mkPairData :: BuiltinData -> BuiltinData -> BuiltinPair BuiltinData BuiltinData mkPairData d1 d2 = BuiltinPair (d1, d2) @@ -403,6 +413,10 @@ chooseList :: BuiltinList a -> b -> b -> b chooseList (BuiltinList []) b1 _ = b1 chooseList (BuiltinList (_:_)) _ b2 = b2 +{-# NOINLINE mkNil #-} +mkNil :: PLC.DefaultUni (PLC.Esc a) -> BuiltinList aAsBuiltin +mkNil _ = BuiltinList [] + {-# NOINLINE mkNilData #-} mkNilData :: BuiltinUnit -> BuiltinList BuiltinData mkNilData _ = BuiltinList [] diff --git a/plutus-tx/src/PlutusTx/Builtins/IsBuiltin.hs b/plutus-tx/src/PlutusTx/Builtins/IsBuiltin.hs new file mode 100644 index 00000000000..ddb070c38e7 --- /dev/null +++ b/plutus-tx/src/PlutusTx/Builtins/IsBuiltin.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} + +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -fno-specialise #-} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} + +module PlutusTx.Builtins.IsBuiltin where + +import PlutusCore qualified as PLC +import PlutusCore.Crypto.BLS12_381.G1 qualified as BLS12_381.G1 (Element) +import PlutusCore.Crypto.BLS12_381.G2 qualified as BLS12_381.G2 (Element) +import PlutusCore.Crypto.BLS12_381.Pairing qualified as BLS12_381.Pairing (MlResult) +import PlutusCore.Data (Data) +import PlutusTx.Base (id, ($)) +import PlutusTx.Bool (Bool (..)) +import PlutusTx.Builtins.Internal +import PlutusTx.Integer (Integer) + +import Data.ByteString (ByteString) +import Data.Kind qualified as GHC +import Data.String (IsString (..)) +import Data.Text (Text, pack) +import GHC.Magic qualified as Magic +import Prelude qualified as Haskell (String) + +{-# NOINLINE obfuscatedId #-} +obfuscatedId :: a -> a +obfuscatedId a = a + +{-# INLINABLE stringToBuiltinByteString #-} +stringToBuiltinByteString :: Haskell.String -> BuiltinByteString +stringToBuiltinByteString str = encodeUtf8 $ stringToBuiltinString str + +{-# INLINABLE stringToBuiltinString #-} +stringToBuiltinString :: Haskell.String -> BuiltinString +-- To explain why the obfuscatedId is here +-- See Note [noinline hack] +stringToBuiltinString str = obfuscatedId (BuiltinString $ pack str) + +{- Same noinline hack as with `String` type. -} +instance IsString BuiltinByteString where + -- Try and make sure the dictionary selector goes away, it's simpler to match on + -- the application of 'stringToBuiltinByteString' + {-# INLINE fromString #-} + -- See Note [noinline hack] + fromString = Magic.noinline stringToBuiltinByteString + +-- We can't put this in `Builtins.hs`, since that force `O0` deliberately, which prevents +-- the unfoldings from going in. So we just stick it here. Fiddly. +instance IsString BuiltinString where + -- Try and make sure the dictionary selector goes away, it's simpler to match on + -- the application of 'stringToBuiltinString' + {-# INLINE fromString #-} + -- See Note [noinline hack] + fromString = Magic.noinline stringToBuiltinString + +type IsBuiltin :: GHC.Type -> GHC.Constraint +class PLC.DefaultUni `PLC.Contains` (FromBuiltin a) => IsBuiltin a where + type FromBuiltin a + fromBuiltin :: a -> FromBuiltin a + toBuiltin :: FromBuiltin a -> a + +instance IsBuiltin BuiltinInteger where + type FromBuiltin BuiltinInteger = Integer + {-# INLINABLE fromBuiltin #-} + fromBuiltin = id + {-# INLINABLE toBuiltin #-} + toBuiltin = id + +instance IsBuiltin BuiltinByteString where + type FromBuiltin BuiltinByteString = ByteString + {-# INLINABLE fromBuiltin #-} + fromBuiltin (BuiltinByteString b) = b + {-# INLINABLE toBuiltin #-} + toBuiltin = BuiltinByteString + +instance IsBuiltin BuiltinString where + type FromBuiltin BuiltinString = Text + {-# INLINABLE fromBuiltin #-} + fromBuiltin (BuiltinString t) = t + {-# INLINABLE toBuiltin #-} + toBuiltin = BuiltinString + +instance IsBuiltin BuiltinUnit where + type FromBuiltin BuiltinUnit = () + {-# INLINABLE fromBuiltin #-} + fromBuiltin u = chooseUnit u () + {-# INLINABLE toBuiltin #-} + toBuiltin x = case x of () -> unitval + +instance IsBuiltin BuiltinBool where + type FromBuiltin BuiltinBool = Bool + {-# INLINABLE fromBuiltin #-} + fromBuiltin b = ifThenElse b True False + {-# INLINABLE toBuiltin #-} + toBuiltin b = if b then true else false + +instance IsBuiltin a => IsBuiltin (BuiltinList a) where + type FromBuiltin (BuiltinList a) = [FromBuiltin a] + + {-# INLINABLE fromBuiltin #-} + fromBuiltin = go + where + -- The combination of both INLINABLE and a type signature seems to stop this getting + -- lifted to the top level, which means it gets a proper unfolding, which means that + -- specialization can work, which can actually help quite a bit here. + {-# INLINABLE go #-} + go :: BuiltinList a -> [FromBuiltin a] + -- Note that we are using builtin chooseList here so this is *strict* application! So we + -- need to do the manual laziness ourselves. + go l = chooseList l (\_ -> []) (\_ -> fromBuiltin (head l) : go (tail l)) unitval + + {-# INLINE toBuiltin #-} + toBuiltin = goList where + goList :: [FromBuiltin a] -> BuiltinList a + goList [] = mkNil @(FromBuiltin a) (Magic.inline PLC.knownUni) + goList (d:ds) = mkCons (toBuiltin d) (goList ds) + +instance (IsBuiltin a, IsBuiltin b) => IsBuiltin (BuiltinPair a b) where + type FromBuiltin (BuiltinPair a b) = (FromBuiltin a, FromBuiltin b) + {-# INLINABLE fromBuiltin #-} + fromBuiltin p = (fromBuiltin $ fst p, fromBuiltin $ snd p) + {-# INLINABLE toBuiltin #-} + toBuiltin (d1, d2) = + mkPair + @(FromBuiltin a) + @(FromBuiltin b) + (Magic.inline PLC.knownUni) + (Magic.inline PLC.knownUni) + (toBuiltin d1) + (toBuiltin d2) + +instance IsBuiltin BuiltinData where + type FromBuiltin BuiltinData = Data + {-# INLINABLE fromBuiltin #-} + fromBuiltin (BuiltinData t) = t + {-# INLINABLE toBuiltin #-} + toBuiltin = BuiltinData + +instance IsBuiltin BuiltinBLS12_381_G1_Element where + type FromBuiltin BuiltinBLS12_381_G1_Element = BLS12_381.G1.Element + {-# INLINABLE fromBuiltin #-} + fromBuiltin (BuiltinBLS12_381_G1_Element a) = a + {-# INLINABLE toBuiltin #-} + toBuiltin = BuiltinBLS12_381_G1_Element + +instance IsBuiltin BuiltinBLS12_381_G2_Element where + type FromBuiltin BuiltinBLS12_381_G2_Element = BLS12_381.G2.Element + {-# INLINABLE fromBuiltin #-} + fromBuiltin (BuiltinBLS12_381_G2_Element a) = a + {-# INLINABLE toBuiltin #-} + toBuiltin = BuiltinBLS12_381_G2_Element + +instance IsBuiltin BuiltinBLS12_381_MlResult where + type FromBuiltin BuiltinBLS12_381_MlResult = BLS12_381.Pairing.MlResult + {-# INLINABLE fromBuiltin #-} + fromBuiltin (BuiltinBLS12_381_MlResult a) = a + {-# INLINABLE toBuiltin #-} + toBuiltin = BuiltinBLS12_381_MlResult diff --git a/plutus-tx/src/PlutusTx/Builtins/IsOpaque.hs b/plutus-tx/src/PlutusTx/Builtins/IsOpaque.hs new file mode 100644 index 00000000000..7ccd2f71edd --- /dev/null +++ b/plutus-tx/src/PlutusTx/Builtins/IsOpaque.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} + +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -fno-specialise #-} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} + +module PlutusTx.Builtins.IsOpaque where + +import PlutusCore qualified as PLC +import PlutusCore.Crypto.BLS12_381.G1 qualified as BLS12_381.G1 (Element) +import PlutusCore.Crypto.BLS12_381.G2 qualified as BLS12_381.G2 (Element) +import PlutusCore.Crypto.BLS12_381.Pairing qualified as BLS12_381.Pairing (MlResult) +import PlutusTx.Base (id, ($)) +import PlutusTx.Bool (Bool (..)) +import PlutusTx.Builtins.Internal +import PlutusTx.Builtins.IsBuiltin (FromBuiltin) + +import Data.Kind qualified as GHC +import GHC.Magic qualified as Magic + +type IsOpaque :: GHC.Type -> GHC.Constraint +class PLC.DefaultUni `PLC.Contains` FromBuiltin a => IsOpaque a where + type FromOpaque a + fromOpaque :: a -> FromOpaque a + toOpaque :: FromOpaque a -> a + +instance IsOpaque BuiltinInteger where + type FromOpaque BuiltinInteger = BuiltinInteger + {-# INLINABLE fromOpaque #-} + fromOpaque = id + {-# INLINABLE toOpaque #-} + toOpaque = id + +instance IsOpaque BuiltinByteString where + type FromOpaque BuiltinByteString = BuiltinByteString + {-# INLINABLE fromOpaque #-} + fromOpaque = id + {-# INLINABLE toOpaque #-} + toOpaque = id + +instance IsOpaque BuiltinString where + type FromOpaque BuiltinString = BuiltinString + {-# INLINABLE fromOpaque #-} + fromOpaque = id + {-# INLINABLE toOpaque #-} + toOpaque = id + +instance IsOpaque BuiltinUnit where + type FromOpaque BuiltinUnit = () + {-# INLINABLE fromOpaque #-} + fromOpaque u = chooseUnit u () + {-# INLINABLE toOpaque #-} + toOpaque x = case x of () -> unitval + +instance IsOpaque BuiltinBool where + type FromOpaque BuiltinBool = Bool + {-# INLINABLE fromOpaque #-} + fromOpaque b = ifThenElse b True False + {-# INLINABLE toOpaque #-} + toOpaque b = if b then true else false + +instance IsOpaque a => IsOpaque (BuiltinList a) where + type FromOpaque (BuiltinList a) = [FromOpaque a] + + {-# INLINABLE fromOpaque #-} + fromOpaque = go + where + -- The combination of both INLINABLE and a type signature seems to stop this getting + -- lifted to the top level, which means it gets a proper unfolding, which means that + -- specialization can work, which can actually help quite a bit here. + {-# INLINABLE go #-} + go :: BuiltinList a -> [FromOpaque a] + -- Note that we are using builtin chooseList here so this is *strict* application! So we + -- need to do the manual laziness ourselves. + go l = chooseList l (\_ -> []) (\_ -> fromOpaque (head l) : go (tail l)) unitval + + {-# INLINE toOpaque #-} + toOpaque = goList where + goList :: [FromOpaque a] -> BuiltinList a + goList [] = mkNil @(FromBuiltin a) (Magic.inline PLC.knownUni) + goList (d:ds) = mkCons (toOpaque d) (goList ds) + +instance (IsOpaque a, IsOpaque b) => IsOpaque (BuiltinPair a b) where + type FromOpaque (BuiltinPair a b) = (FromOpaque a, FromOpaque b) + {-# INLINABLE fromOpaque #-} + fromOpaque p = (fromOpaque $ fst p, fromOpaque $ snd p) + {-# INLINABLE toOpaque #-} + toOpaque (d1, d2) = + mkPair + @(FromBuiltin a) + @(FromBuiltin b) + (Magic.inline PLC.knownUni) + (Magic.inline PLC.knownUni) + (toOpaque d1) + (toOpaque d2) + +instance IsOpaque BuiltinData where + type FromOpaque BuiltinData = BuiltinData + {-# INLINABLE fromOpaque #-} + fromOpaque = id + {-# INLINABLE toOpaque #-} + toOpaque = id + +instance IsOpaque BuiltinBLS12_381_G1_Element where + type FromOpaque BuiltinBLS12_381_G1_Element = BLS12_381.G1.Element + {-# INLINABLE fromOpaque #-} + fromOpaque (BuiltinBLS12_381_G1_Element a) = a + {-# INLINABLE toOpaque #-} + toOpaque = BuiltinBLS12_381_G1_Element + +instance IsOpaque BuiltinBLS12_381_G2_Element where + type FromOpaque BuiltinBLS12_381_G2_Element = BLS12_381.G2.Element + {-# INLINABLE fromOpaque #-} + fromOpaque (BuiltinBLS12_381_G2_Element a) = a + {-# INLINABLE toOpaque #-} + toOpaque = BuiltinBLS12_381_G2_Element + +instance IsOpaque BuiltinBLS12_381_MlResult where + type FromOpaque BuiltinBLS12_381_MlResult = BLS12_381.Pairing.MlResult + {-# INLINABLE fromOpaque #-} + fromOpaque (BuiltinBLS12_381_MlResult a) = a + {-# INLINABLE toOpaque #-} + toOpaque = BuiltinBLS12_381_MlResult diff --git a/plutus-tx/src/PlutusTx/IsData/Class.hs b/plutus-tx/src/PlutusTx/IsData/Class.hs index 19c5f0d5827..7f751420c38 100644 --- a/plutus-tx/src/PlutusTx/IsData/Class.hs +++ b/plutus-tx/src/PlutusTx/IsData/Class.hs @@ -162,7 +162,7 @@ instance FromData Builtins.BuiltinBLS12_381_G1_Element where Just (BI.BuiltinByteString bs) -> case BLS12_381.G1.uncompress bs of Haskell.Left _ -> Nothing - Haskell.Right g -> Just $ toBuiltin g + Haskell.Right g -> Just $ toOpaque g instance UnsafeFromData Builtins.BuiltinBLS12_381_G1_Element where {-# INLINABLE unsafeFromBuiltinData #-} unsafeFromBuiltinData = Builtins.bls12_381_G1_uncompress . unsafeFromBuiltinData @@ -178,7 +178,7 @@ instance FromData Builtins.BuiltinBLS12_381_G2_Element where Just (BI.BuiltinByteString bs) -> case BLS12_381.G2.uncompress bs of Haskell.Left _ -> Nothing - Haskell.Right g -> Just $ toBuiltin g + Haskell.Right g -> Just $ toOpaque g instance UnsafeFromData Builtins.BuiltinBLS12_381_G2_Element where {-# INLINABLE unsafeFromBuiltinData #-} unsafeFromBuiltinData = Builtins.bls12_381_G2_uncompress . unsafeFromBuiltinData diff --git a/plutus-tx/src/PlutusTx/Lift/Class.hs b/plutus-tx/src/PlutusTx/Lift/Class.hs index 240ce9efc54..4ffc6a9ce29 100644 --- a/plutus-tx/src/PlutusTx/Lift/Class.hs +++ b/plutus-tx/src/PlutusTx/Lift/Class.hs @@ -30,8 +30,8 @@ import PlutusCore.Data import PlutusCore.Quote import PlutusIR.MkPir import PlutusTx.Builtins -import PlutusTx.Builtins.Class (FromBuiltin) import PlutusTx.Builtins.Internal (BuiltinBool, BuiltinList, BuiltinPair, BuiltinUnit) +import PlutusTx.Builtins.IsBuiltin (FromBuiltin, IsBuiltin) import Language.Haskell.TH qualified as TH hiding (newName) @@ -188,14 +188,14 @@ instance uni `PLC.HasTypeLevel` [] => Typeable uni BuiltinList where typeRep _proxyBuiltinList = typeRepBuiltin (Proxy @[]) -- See Note [Lift and Typeable instances for builtins] -instance (FromBuiltin arep a, uni `PLC.HasTermLevel` [a]) => Lift uni (BuiltinList arep) where +instance (IsBuiltin a, uni `PLC.HasTermLevel` [FromBuiltin a]) => Lift uni (BuiltinList a) where lift = liftBuiltin . fromBuiltin instance uni `PLC.HasTypeLevel` (,) => Typeable uni BuiltinPair where typeRep _proxyBuiltinPair = typeRepBuiltin (Proxy @(,)) -instance (FromBuiltin arep a, FromBuiltin brep b, uni `PLC.HasTermLevel` (a, b)) => - Lift uni (BuiltinPair arep brep) where +instance (IsBuiltin a, IsBuiltin b, uni `PLC.HasTermLevel` (FromBuiltin a, FromBuiltin b)) => + Lift uni (BuiltinPair a b) where lift = liftBuiltin . fromBuiltin -- See Note [Lift and Typeable instances for builtins] From 94ff0ff38e4a5f65a82525c52ce788992da0badd Mon Sep 17 00:00:00 2001 From: effectfully Date: Fri, 10 May 2024 03:53:02 +0200 Subject: [PATCH 20/41] Split 'Has*' into 'From*' and 'To*' again --- plutus-tx/src/PlutusTx/Builtins/Internal.hs | 14 ----- plutus-tx/src/PlutusTx/Builtins/IsBuiltin.hs | 64 ++++++++++++-------- plutus-tx/src/PlutusTx/Builtins/IsOpaque.hs | 64 +++++++++++--------- plutus-tx/src/PlutusTx/Lift/Class.hs | 11 ++-- 4 files changed, 83 insertions(+), 70 deletions(-) diff --git a/plutus-tx/src/PlutusTx/Builtins/Internal.hs b/plutus-tx/src/PlutusTx/Builtins/Internal.hs index ef24fedf208..843b63ccc4c 100644 --- a/plutus-tx/src/PlutusTx/Builtins/Internal.hs +++ b/plutus-tx/src/PlutusTx/Builtins/Internal.hs @@ -41,7 +41,6 @@ import PlutusCore.Crypto.Ed25519 qualified import PlutusCore.Crypto.Hash qualified as Hash import PlutusCore.Crypto.Secp256k1 qualified import PlutusCore.Data qualified as PLC -import PlutusCore.Default qualified as PLC import PlutusCore.Pretty (Pretty (..), display) import Prettyprinter (viaShow) @@ -366,15 +365,6 @@ fst (BuiltinPair (a, _)) = a snd :: BuiltinPair a b -> b snd (BuiltinPair (_, b)) = b -{-# NOINLINE mkPair #-} -mkPair - :: PLC.DefaultUni (PLC.Esc a) - -> PLC.DefaultUni (PLC.Esc b) - -> aAsBuiltin - -> bAsBuiltin - -> BuiltinPair aAsBuiltin bAsBuiltin -mkPair _ _ x y = BuiltinPair (x, y) - {-# NOINLINE mkPairData #-} mkPairData :: BuiltinData -> BuiltinData -> BuiltinPair BuiltinData BuiltinData mkPairData d1 d2 = BuiltinPair (d1, d2) @@ -413,10 +403,6 @@ chooseList :: BuiltinList a -> b -> b -> b chooseList (BuiltinList []) b1 _ = b1 chooseList (BuiltinList (_:_)) _ b2 = b2 -{-# NOINLINE mkNil #-} -mkNil :: PLC.DefaultUni (PLC.Esc a) -> BuiltinList aAsBuiltin -mkNil _ = BuiltinList [] - {-# NOINLINE mkNilData #-} mkNilData :: BuiltinUnit -> BuiltinList BuiltinData mkNilData _ = BuiltinList [] diff --git a/plutus-tx/src/PlutusTx/Builtins/IsBuiltin.hs b/plutus-tx/src/PlutusTx/Builtins/IsBuiltin.hs index ddb070c38e7..a9eff666b08 100644 --- a/plutus-tx/src/PlutusTx/Builtins/IsBuiltin.hs +++ b/plutus-tx/src/PlutusTx/Builtins/IsBuiltin.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -11,7 +12,6 @@ module PlutusTx.Builtins.IsBuiltin where -import PlutusCore qualified as PLC import PlutusCore.Crypto.BLS12_381.G1 qualified as BLS12_381.G1 (Element) import PlutusCore.Crypto.BLS12_381.G2 qualified as BLS12_381.G2 (Element) import PlutusCore.Crypto.BLS12_381.Pairing qualified as BLS12_381.Pairing (MlResult) @@ -59,48 +59,56 @@ instance IsString BuiltinString where -- See Note [noinline hack] fromString = Magic.noinline stringToBuiltinString -type IsBuiltin :: GHC.Type -> GHC.Constraint -class PLC.DefaultUni `PLC.Contains` (FromBuiltin a) => IsBuiltin a where +type HasFromBuiltin :: GHC.Type -> GHC.Constraint +class HasFromBuiltin a where type FromBuiltin a fromBuiltin :: a -> FromBuiltin a + +type HasToBuiltin :: GHC.Type -> GHC.Constraint +class HasToBuiltin a where toBuiltin :: FromBuiltin a -> a -instance IsBuiltin BuiltinInteger where +instance HasFromBuiltin BuiltinInteger where type FromBuiltin BuiltinInteger = Integer {-# INLINABLE fromBuiltin #-} fromBuiltin = id +instance HasToBuiltin BuiltinInteger where {-# INLINABLE toBuiltin #-} toBuiltin = id -instance IsBuiltin BuiltinByteString where +instance HasFromBuiltin BuiltinByteString where type FromBuiltin BuiltinByteString = ByteString {-# INLINABLE fromBuiltin #-} fromBuiltin (BuiltinByteString b) = b +instance HasToBuiltin BuiltinByteString where {-# INLINABLE toBuiltin #-} toBuiltin = BuiltinByteString -instance IsBuiltin BuiltinString where +instance HasFromBuiltin BuiltinString where type FromBuiltin BuiltinString = Text {-# INLINABLE fromBuiltin #-} fromBuiltin (BuiltinString t) = t +instance HasToBuiltin BuiltinString where {-# INLINABLE toBuiltin #-} toBuiltin = BuiltinString -instance IsBuiltin BuiltinUnit where +instance HasFromBuiltin BuiltinUnit where type FromBuiltin BuiltinUnit = () {-# INLINABLE fromBuiltin #-} fromBuiltin u = chooseUnit u () +instance HasToBuiltin BuiltinUnit where {-# INLINABLE toBuiltin #-} toBuiltin x = case x of () -> unitval -instance IsBuiltin BuiltinBool where +instance HasFromBuiltin BuiltinBool where type FromBuiltin BuiltinBool = Bool {-# INLINABLE fromBuiltin #-} fromBuiltin b = ifThenElse b True False +instance HasToBuiltin BuiltinBool where {-# INLINABLE toBuiltin #-} toBuiltin b = if b then true else false -instance IsBuiltin a => IsBuiltin (BuiltinList a) where +instance HasFromBuiltin a => HasFromBuiltin (BuiltinList a) where type FromBuiltin (BuiltinList a) = [FromBuiltin a] {-# INLINABLE fromBuiltin #-} @@ -115,50 +123,56 @@ instance IsBuiltin a => IsBuiltin (BuiltinList a) where -- need to do the manual laziness ourselves. go l = chooseList l (\_ -> []) (\_ -> fromBuiltin (head l) : go (tail l)) unitval +instance HasToBuiltin (BuiltinList BuiltinData) where + {-# INLINE toBuiltin #-} + toBuiltin = goList where + goList :: [Data] -> BuiltinList BuiltinData + goList [] = mkNilData unitval + goList (d:ds) = mkCons (toBuiltin d) (goList ds) + +instance HasToBuiltin (BuiltinList (BuiltinPair BuiltinData BuiltinData)) where {-# INLINE toBuiltin #-} toBuiltin = goList where - goList :: [FromBuiltin a] -> BuiltinList a - goList [] = mkNil @(FromBuiltin a) (Magic.inline PLC.knownUni) + goList :: [(Data, Data)] -> BuiltinList (BuiltinPair BuiltinData BuiltinData) + goList [] = mkNilPairData unitval goList (d:ds) = mkCons (toBuiltin d) (goList ds) -instance (IsBuiltin a, IsBuiltin b) => IsBuiltin (BuiltinPair a b) where +instance (HasFromBuiltin a, HasFromBuiltin b) => HasFromBuiltin (BuiltinPair a b) where type FromBuiltin (BuiltinPair a b) = (FromBuiltin a, FromBuiltin b) {-# INLINABLE fromBuiltin #-} fromBuiltin p = (fromBuiltin $ fst p, fromBuiltin $ snd p) +instance HasToBuiltin (BuiltinPair BuiltinData BuiltinData) where {-# INLINABLE toBuiltin #-} - toBuiltin (d1, d2) = - mkPair - @(FromBuiltin a) - @(FromBuiltin b) - (Magic.inline PLC.knownUni) - (Magic.inline PLC.knownUni) - (toBuiltin d1) - (toBuiltin d2) - -instance IsBuiltin BuiltinData where + toBuiltin (d1, d2) = mkPairData (toBuiltin d1) (toBuiltin d2) + +instance HasFromBuiltin BuiltinData where type FromBuiltin BuiltinData = Data {-# INLINABLE fromBuiltin #-} fromBuiltin (BuiltinData t) = t +instance HasToBuiltin BuiltinData where {-# INLINABLE toBuiltin #-} toBuiltin = BuiltinData -instance IsBuiltin BuiltinBLS12_381_G1_Element where +instance HasFromBuiltin BuiltinBLS12_381_G1_Element where type FromBuiltin BuiltinBLS12_381_G1_Element = BLS12_381.G1.Element {-# INLINABLE fromBuiltin #-} fromBuiltin (BuiltinBLS12_381_G1_Element a) = a +instance HasToBuiltin BuiltinBLS12_381_G1_Element where {-# INLINABLE toBuiltin #-} toBuiltin = BuiltinBLS12_381_G1_Element -instance IsBuiltin BuiltinBLS12_381_G2_Element where +instance HasFromBuiltin BuiltinBLS12_381_G2_Element where type FromBuiltin BuiltinBLS12_381_G2_Element = BLS12_381.G2.Element {-# INLINABLE fromBuiltin #-} fromBuiltin (BuiltinBLS12_381_G2_Element a) = a +instance HasToBuiltin BuiltinBLS12_381_G2_Element where {-# INLINABLE toBuiltin #-} toBuiltin = BuiltinBLS12_381_G2_Element -instance IsBuiltin BuiltinBLS12_381_MlResult where +instance HasFromBuiltin BuiltinBLS12_381_MlResult where type FromBuiltin BuiltinBLS12_381_MlResult = BLS12_381.Pairing.MlResult {-# INLINABLE fromBuiltin #-} fromBuiltin (BuiltinBLS12_381_MlResult a) = a +instance HasToBuiltin BuiltinBLS12_381_MlResult where {-# INLINABLE toBuiltin #-} toBuiltin = BuiltinBLS12_381_MlResult diff --git a/plutus-tx/src/PlutusTx/Builtins/IsOpaque.hs b/plutus-tx/src/PlutusTx/Builtins/IsOpaque.hs index 7ccd2f71edd..d23cbd1937a 100644 --- a/plutus-tx/src/PlutusTx/Builtins/IsOpaque.hs +++ b/plutus-tx/src/PlutusTx/Builtins/IsOpaque.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -11,60 +12,63 @@ module PlutusTx.Builtins.IsOpaque where -import PlutusCore qualified as PLC import PlutusCore.Crypto.BLS12_381.G1 qualified as BLS12_381.G1 (Element) import PlutusCore.Crypto.BLS12_381.G2 qualified as BLS12_381.G2 (Element) import PlutusCore.Crypto.BLS12_381.Pairing qualified as BLS12_381.Pairing (MlResult) import PlutusTx.Base (id, ($)) import PlutusTx.Bool (Bool (..)) import PlutusTx.Builtins.Internal -import PlutusTx.Builtins.IsBuiltin (FromBuiltin) import Data.Kind qualified as GHC -import GHC.Magic qualified as Magic -type IsOpaque :: GHC.Type -> GHC.Constraint -class PLC.DefaultUni `PLC.Contains` FromBuiltin a => IsOpaque a where +type HasFromOpaque :: GHC.Type -> GHC.Constraint +class HasFromOpaque a where type FromOpaque a fromOpaque :: a -> FromOpaque a +class HasToOpaque a where toOpaque :: FromOpaque a -> a -instance IsOpaque BuiltinInteger where +instance HasFromOpaque BuiltinInteger where type FromOpaque BuiltinInteger = BuiltinInteger {-# INLINABLE fromOpaque #-} fromOpaque = id +instance HasToOpaque BuiltinInteger where {-# INLINABLE toOpaque #-} toOpaque = id -instance IsOpaque BuiltinByteString where +instance HasFromOpaque BuiltinByteString where type FromOpaque BuiltinByteString = BuiltinByteString {-# INLINABLE fromOpaque #-} fromOpaque = id +instance HasToOpaque BuiltinByteString where {-# INLINABLE toOpaque #-} toOpaque = id -instance IsOpaque BuiltinString where +instance HasFromOpaque BuiltinString where type FromOpaque BuiltinString = BuiltinString {-# INLINABLE fromOpaque #-} fromOpaque = id +instance HasToOpaque BuiltinString where {-# INLINABLE toOpaque #-} toOpaque = id -instance IsOpaque BuiltinUnit where +instance HasFromOpaque BuiltinUnit where type FromOpaque BuiltinUnit = () {-# INLINABLE fromOpaque #-} fromOpaque u = chooseUnit u () +instance HasToOpaque BuiltinUnit where {-# INLINABLE toOpaque #-} toOpaque x = case x of () -> unitval -instance IsOpaque BuiltinBool where +instance HasFromOpaque BuiltinBool where type FromOpaque BuiltinBool = Bool {-# INLINABLE fromOpaque #-} fromOpaque b = ifThenElse b True False +instance HasToOpaque BuiltinBool where {-# INLINABLE toOpaque #-} toOpaque b = if b then true else false -instance IsOpaque a => IsOpaque (BuiltinList a) where +instance HasFromOpaque a => HasFromOpaque (BuiltinList a) where type FromOpaque (BuiltinList a) = [FromOpaque a] {-# INLINABLE fromOpaque #-} @@ -79,50 +83,56 @@ instance IsOpaque a => IsOpaque (BuiltinList a) where -- need to do the manual laziness ourselves. go l = chooseList l (\_ -> []) (\_ -> fromOpaque (head l) : go (tail l)) unitval +instance HasToOpaque (BuiltinList BuiltinData) where {-# INLINE toOpaque #-} toOpaque = goList where - goList :: [FromOpaque a] -> BuiltinList a - goList [] = mkNil @(FromBuiltin a) (Magic.inline PLC.knownUni) + goList :: [BuiltinData] -> BuiltinList BuiltinData + goList [] = mkNilData unitval goList (d:ds) = mkCons (toOpaque d) (goList ds) -instance (IsOpaque a, IsOpaque b) => IsOpaque (BuiltinPair a b) where +instance HasToOpaque (BuiltinList (BuiltinPair BuiltinData BuiltinData)) where + {-# INLINE toOpaque #-} + toOpaque = goList where + goList :: [(BuiltinData, BuiltinData)] -> BuiltinList (BuiltinPair BuiltinData BuiltinData) + goList [] = mkNilPairData unitval + goList (d:ds) = mkCons (toOpaque d) (goList ds) + +instance (HasFromOpaque a, HasFromOpaque b) => HasFromOpaque (BuiltinPair a b) where type FromOpaque (BuiltinPair a b) = (FromOpaque a, FromOpaque b) {-# INLINABLE fromOpaque #-} fromOpaque p = (fromOpaque $ fst p, fromOpaque $ snd p) +instance HasToOpaque (BuiltinPair BuiltinData BuiltinData) where {-# INLINABLE toOpaque #-} - toOpaque (d1, d2) = - mkPair - @(FromBuiltin a) - @(FromBuiltin b) - (Magic.inline PLC.knownUni) - (Magic.inline PLC.knownUni) - (toOpaque d1) - (toOpaque d2) - -instance IsOpaque BuiltinData where + toOpaque (d1, d2) = mkPairData d1 d2 + +instance HasFromOpaque BuiltinData where type FromOpaque BuiltinData = BuiltinData {-# INLINABLE fromOpaque #-} fromOpaque = id +instance HasToOpaque BuiltinData where {-# INLINABLE toOpaque #-} toOpaque = id -instance IsOpaque BuiltinBLS12_381_G1_Element where +instance HasFromOpaque BuiltinBLS12_381_G1_Element where type FromOpaque BuiltinBLS12_381_G1_Element = BLS12_381.G1.Element {-# INLINABLE fromOpaque #-} fromOpaque (BuiltinBLS12_381_G1_Element a) = a +instance HasToOpaque BuiltinBLS12_381_G1_Element where {-# INLINABLE toOpaque #-} toOpaque = BuiltinBLS12_381_G1_Element -instance IsOpaque BuiltinBLS12_381_G2_Element where +instance HasFromOpaque BuiltinBLS12_381_G2_Element where type FromOpaque BuiltinBLS12_381_G2_Element = BLS12_381.G2.Element {-# INLINABLE fromOpaque #-} fromOpaque (BuiltinBLS12_381_G2_Element a) = a +instance HasToOpaque BuiltinBLS12_381_G2_Element where {-# INLINABLE toOpaque #-} toOpaque = BuiltinBLS12_381_G2_Element -instance IsOpaque BuiltinBLS12_381_MlResult where +instance HasFromOpaque BuiltinBLS12_381_MlResult where type FromOpaque BuiltinBLS12_381_MlResult = BLS12_381.Pairing.MlResult {-# INLINABLE fromOpaque #-} fromOpaque (BuiltinBLS12_381_MlResult a) = a +instance HasToOpaque BuiltinBLS12_381_MlResult where {-# INLINABLE toOpaque #-} toOpaque = BuiltinBLS12_381_MlResult diff --git a/plutus-tx/src/PlutusTx/Lift/Class.hs b/plutus-tx/src/PlutusTx/Lift/Class.hs index 4ffc6a9ce29..8d7597ff818 100644 --- a/plutus-tx/src/PlutusTx/Lift/Class.hs +++ b/plutus-tx/src/PlutusTx/Lift/Class.hs @@ -31,7 +31,7 @@ import PlutusCore.Quote import PlutusIR.MkPir import PlutusTx.Builtins import PlutusTx.Builtins.Internal (BuiltinBool, BuiltinList, BuiltinPair, BuiltinUnit) -import PlutusTx.Builtins.IsBuiltin (FromBuiltin, IsBuiltin) +import PlutusTx.Builtins.IsBuiltin (FromBuiltin, HasFromBuiltin) import Language.Haskell.TH qualified as TH hiding (newName) @@ -188,14 +188,17 @@ instance uni `PLC.HasTypeLevel` [] => Typeable uni BuiltinList where typeRep _proxyBuiltinList = typeRepBuiltin (Proxy @[]) -- See Note [Lift and Typeable instances for builtins] -instance (IsBuiltin a, uni `PLC.HasTermLevel` [FromBuiltin a]) => Lift uni (BuiltinList a) where +instance (HasFromBuiltin a, uni `PLC.HasTermLevel` [FromBuiltin a]) => + Lift uni (BuiltinList a) where lift = liftBuiltin . fromBuiltin instance uni `PLC.HasTypeLevel` (,) => Typeable uni BuiltinPair where typeRep _proxyBuiltinPair = typeRepBuiltin (Proxy @(,)) -instance (IsBuiltin a, IsBuiltin b, uni `PLC.HasTermLevel` (FromBuiltin a, FromBuiltin b)) => - Lift uni (BuiltinPair a b) where +instance + ( HasFromBuiltin a, HasFromBuiltin b + , uni `PLC.HasTermLevel` (FromBuiltin a, FromBuiltin b) + ) => Lift uni (BuiltinPair a b) where lift = liftBuiltin . fromBuiltin -- See Note [Lift and Typeable instances for builtins] From 1f0d1479569526020e7cfa59aa3bf36e66dc647a Mon Sep 17 00:00:00 2001 From: effectfully Date: Fri, 10 May 2024 05:58:45 +0200 Subject: [PATCH 21/41] Remove type families from '*Opaque' --- .../src/PlutusTx/Compiler/Builtins.hs | 2 +- .../src/PlutusTx/Compiler/Expr.hs | 2 +- .../9.6/deconstructorData2.pir.golden | 23 +- plutus-tx/plutus-tx.cabal | 1 - plutus-tx/src/PlutusTx/Builtins/Class.hs | 255 ------------------ plutus-tx/src/PlutusTx/Builtins/IsBuiltin.hs | 85 +++--- plutus-tx/src/PlutusTx/Builtins/IsOpaque.hs | 209 ++++++++------ plutus-tx/src/PlutusTx/IsData/Class.hs | 4 +- 8 files changed, 187 insertions(+), 394 deletions(-) delete mode 100644 plutus-tx/src/PlutusTx/Builtins/Class.hs diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs index 077f99932eb..48a80e88001 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs @@ -18,8 +18,8 @@ module PlutusTx.Compiler.Builtins ( , lookupBuiltinType , errorFunc) where -import PlutusTx.Builtins.Class qualified as Builtins import PlutusTx.Builtins.Internal qualified as Builtins +import PlutusTx.Builtins.IsBuiltin qualified as Builtins import PlutusTx.Compiler.Error import PlutusTx.Compiler.Names diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs index 32ab0827668..519febe83aa 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs @@ -49,7 +49,7 @@ import PlutusTx.PIRTypes import PlutusTx.PLCTypes (PLCType, PLCVar) -- I feel like we shouldn't need this, we only need it to spot the special String type, which is annoying -import PlutusTx.Builtins.Class qualified as Builtins +import PlutusTx.Builtins.IsBuiltin qualified as Builtins import PlutusTx.Trace import PlutusIR qualified as PIR diff --git a/plutus-tx-plugin/test/Plugin/Primitives/9.6/deconstructorData2.pir.golden b/plutus-tx-plugin/test/Plugin/Primitives/9.6/deconstructorData2.pir.golden index b40f8b55eb0..2919c2b1560 100644 --- a/plutus-tx-plugin/test/Plugin/Primitives/9.6/deconstructorData2.pir.golden +++ b/plutus-tx-plugin/test/Plugin/Primitives/9.6/deconstructorData2.pir.golden @@ -247,6 +247,14 @@ ) ) ) + (termbind + (nonstrict) + (vardecl + `$fHasFromOpaqueBuiltinDataBuiltinData_$cfromOpaque` + (fun (con data) (con data)) + ) + (lam eta (con data) eta) + ) (termbind (strict) (vardecl @@ -271,7 +279,7 @@ (termbind (nonstrict) (vardecl - `$fFromBuiltinBuiltinListList_$cfromBuiltin` + `$fHasFromOpaqueBuiltinListList_$cfromOpaque` (all arep (type) @@ -292,7 +300,7 @@ a (type) (lam - `$dFromBuiltin` + `$dHasFromOpaque` [ [ (lam arep (type) (lam a (type) (fun arep a))) arep ] a ] (let (rec) @@ -323,7 +331,7 @@ [ [ { Cons a } - [ `$dFromBuiltin` [ { head arep } l ] ] + [ `$dHasFromOpaque` [ { head arep } l ] ] ] [ go [ { tail arep } l ] ] ] @@ -347,11 +355,6 @@ ) (builtin fstPair) ) - (termbind - (nonstrict) - (vardecl id (all a (type) (fun a a))) - (abs a (type) (lam x a x)) - ) (termbind (strict) (vardecl @@ -405,12 +408,12 @@ [ { { - `$fFromBuiltinBuiltinListList_$cfromBuiltin` + `$fHasFromOpaqueBuiltinListList_$cfromOpaque` (con data) } (con data) } - { id (con data) } + `$fHasFromOpaqueBuiltinDataBuiltinData_$cfromOpaque` ] a ] diff --git a/plutus-tx/plutus-tx.cabal b/plutus-tx/plutus-tx.cabal index 424d094c795..40faf55800b 100644 --- a/plutus-tx/plutus-tx.cabal +++ b/plutus-tx/plutus-tx.cabal @@ -70,7 +70,6 @@ library PlutusTx.Blueprint.Write PlutusTx.Bool PlutusTx.Builtins - PlutusTx.Builtins.Class PlutusTx.Builtins.Internal PlutusTx.Builtins.IsBuiltin PlutusTx.Builtins.IsOpaque diff --git a/plutus-tx/src/PlutusTx/Builtins/Class.hs b/plutus-tx/src/PlutusTx/Builtins/Class.hs deleted file mode 100644 index 94eba15fbf7..00000000000 --- a/plutus-tx/src/PlutusTx/Builtins/Class.hs +++ /dev/null @@ -1,255 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} --- editorconfig-checker-disable-file -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -fno-specialise #-} -{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} - -module PlutusTx.Builtins.Class (module Export) where - -import PlutusTx.Builtins.IsBuiltin as Export - -import Prelude qualified as Haskell (String) - -import Data.ByteString (ByteString) -import PlutusTx.Builtins.Internal - -import Data.String (IsString (..)) -import Data.Text (Text, pack) -import GHC.Magic qualified as Magic - -import PlutusCore.Crypto.BLS12_381.G1 qualified as BLS12_381.G1 (Element) -import PlutusCore.Crypto.BLS12_381.G2 qualified as BLS12_381.G2 (Element) -import PlutusCore.Crypto.BLS12_381.Pairing qualified as BLS12_381.Pairing (MlResult) -import PlutusCore.Default qualified as PLC -import PlutusTx.Base (const, id, ($)) -import PlutusTx.Bool (Bool (..)) -import PlutusTx.Integer (Integer) - --- -- See Note [Builtin types and their Haskell versions] --- {-| --- A class witnessing the ability to convert from the builtin representation to the Haskell representation. --- -} --- class FromBuiltin arep a | arep -> a where --- fromBuiltin :: arep -> a - --- -- See Note [Builtin types and their Haskell versions] --- {-| --- A class witnessing the ability to convert from the Haskell representation to the builtin representation. --- -} --- class ToBuiltin a arep | a -> arep where --- toBuiltin :: a -> arep - --- instance FromBuiltin BuiltinInteger Integer where --- {-# INLINABLE fromBuiltin #-} --- fromBuiltin = id --- instance ToBuiltin Integer BuiltinInteger where --- {-# INLINABLE toBuiltin #-} --- toBuiltin = id - --- instance FromBuiltin BuiltinBool Bool where --- {-# INLINABLE fromBuiltin #-} --- fromBuiltin b = ifThenElse b True False --- instance ToBuiltin Bool BuiltinBool where --- {-# INLINABLE toBuiltin #-} --- toBuiltin b = if b then true else false - --- instance FromBuiltin BuiltinUnit () where --- -- See Note [Strict conversions to/from unit] --- {-# INLINABLE fromBuiltin #-} --- fromBuiltin u = chooseUnit u () --- instance ToBuiltin () BuiltinUnit where --- -- See Note [Strict conversions to/from unit] --- {-# INLINABLE toBuiltin #-} --- toBuiltin x = case x of () -> unitval - --- instance FromBuiltin BuiltinByteString ByteString where --- {-# INLINABLE fromBuiltin #-} --- fromBuiltin (BuiltinByteString b) = b --- instance ToBuiltin ByteString BuiltinByteString where --- {-# INLINABLE toBuiltin #-} --- toBuiltin = BuiltinByteString - --- -- We can't put this in `Builtins.hs`, since that force `O0` deliberately, which prevents --- -- the unfoldings from going in. So we just stick it here. Fiddly. --- instance IsString BuiltinString where --- -- Try and make sure the dictionary selector goes away, it's simpler to match on --- -- the application of 'stringToBuiltinString' --- {-# INLINE fromString #-} --- -- See Note [noinline hack] --- fromString = Magic.noinline stringToBuiltinString - --- {-# INLINABLE stringToBuiltinString #-} --- stringToBuiltinString :: Haskell.String -> BuiltinString --- -- To explain why the obfuscatedId is here --- -- See Note [noinline hack] --- stringToBuiltinString str = obfuscatedId (BuiltinString $ pack str) - --- {-# NOINLINE obfuscatedId #-} --- obfuscatedId :: a -> a --- obfuscatedId a = a - --- instance FromBuiltin BuiltinString Text where --- {-# INLINABLE fromBuiltin #-} --- fromBuiltin (BuiltinString t) = t --- instance ToBuiltin Text BuiltinString where --- {-# INLINABLE toBuiltin #-} --- toBuiltin = BuiltinString - --- {- Same noinline hack as with `String` type. -} --- instance IsString BuiltinByteString where --- -- Try and make sure the dictionary selector goes away, it's simpler to match on --- -- the application of 'stringToBuiltinByteString' --- {-# INLINE fromString #-} --- -- See Note [noinline hack] --- fromString = Magic.noinline stringToBuiltinByteString - --- {-# INLINABLE stringToBuiltinByteString #-} --- stringToBuiltinByteString :: Haskell.String -> BuiltinByteString --- stringToBuiltinByteString str = encodeUtf8 $ stringToBuiltinString str - --- instance (FromBuiltin arep a, FromBuiltin brep b) => FromBuiltin (BuiltinPair arep brep) (a,b) where --- {-# INLINABLE fromBuiltin #-} --- fromBuiltin p = (fromBuiltin $ fst p, fromBuiltin $ snd p) --- instance ToBuiltin (BuiltinData, BuiltinData) (BuiltinPair BuiltinData BuiltinData) where --- {-# INLINABLE toBuiltin #-} --- toBuiltin (d1, d2) = mkPairData d1 d2 - --- instance FromBuiltin arep a => FromBuiltin (BuiltinList arep) [a] where --- {-# INLINABLE fromBuiltin #-} --- fromBuiltin = go --- where --- -- The combination of both INLINABLE and a type signature seems to stop this getting lifted to the top --- -- level, which means it gets a proper unfolding, which means that specialization can work, which can --- -- actually help quite a bit here. --- {-# INLINABLE go #-} --- go :: BuiltinList arep -> [a] --- -- Note that we are using builtin chooseList here so this is *strict* application! So we need to do --- -- the manual laziness ourselves. --- go l = chooseList l (const []) (\_ -> fromBuiltin (head l):go (tail l)) unitval - --- instance (PLC.DefaultUni `PLC.Contains` a, ToBuiltin a arep) => --- ToBuiltin [a] (BuiltinList arep) where --- {-# INLINE toBuiltin #-} --- toBuiltin = goList where --- goList :: [a] -> BuiltinList arep --- goList [] = mkNil @a PLC.knownUni --- goList (d:ds) = mkCons (toBuiltin d) (goList ds) - --- instance FromBuiltin BuiltinData BuiltinData where --- {-# INLINABLE fromBuiltin #-} --- fromBuiltin = id --- instance ToBuiltin BuiltinData BuiltinData where --- {-# INLINABLE toBuiltin #-} --- toBuiltin = id - --- instance FromBuiltin BuiltinBLS12_381_G1_Element BLS12_381.G1.Element where --- {-# INLINABLE fromBuiltin #-} --- fromBuiltin (BuiltinBLS12_381_G1_Element a) = a --- instance ToBuiltin BLS12_381.G1.Element BuiltinBLS12_381_G1_Element where --- {-# INLINABLE toBuiltin #-} --- toBuiltin = BuiltinBLS12_381_G1_Element - --- instance FromBuiltin BuiltinBLS12_381_G2_Element BLS12_381.G2.Element where --- {-# INLINABLE fromBuiltin #-} --- fromBuiltin (BuiltinBLS12_381_G2_Element a) = a --- instance ToBuiltin BLS12_381.G2.Element BuiltinBLS12_381_G2_Element where --- {-# INLINABLE toBuiltin #-} --- toBuiltin = BuiltinBLS12_381_G2_Element - --- instance FromBuiltin BuiltinBLS12_381_MlResult BLS12_381.Pairing.MlResult where --- {-# INLINABLE fromBuiltin #-} --- fromBuiltin (BuiltinBLS12_381_MlResult a) = a --- instance ToBuiltin BLS12_381.Pairing.MlResult BuiltinBLS12_381_MlResult where --- {-# INLINABLE toBuiltin #-} --- toBuiltin = BuiltinBLS12_381_MlResult - --- {- Note [Builtin types and their Haskell versions] --- Consider the builtin pair type. In Plutus Tx, we have an (opaque) type for --- this. It's opaque because you can't actually pattern match on it, instead you can --- only in fact use the specific functions that are available as builtins. - --- We _also_ have the normal Haskell pair type. This is very different: you can --- pattern match on it, and you can use whatever user-defined functions you like on it. - --- Users would really like to use the latter, and not the former. So we often want --- to _wrap_ our builtin functions with little adapters that convert between the --- "opaque builtin" "version" of a type and the "normal Haskell" "version" of a type. - --- This is what the ToBuiltin and FromBuiltin classes do. They let us write wrappers --- for builtins relatively consistently by just calling toBuiltin on their arguments --- and fromBuiltin on the result. They shouldn't really be used otherwise. - --- Ideally, we would not have instances for types which don't have a different --- Haskell representation type, such as Integer. Integer in Plutus Tx user code _is_ the --- opaque builtin type, we don't expose a different one. So there's no conversion to --- do. However, this interacts badly with the instances for polymorphic builtin types, which --- also convert the type _inside_ them. (This is necessary to avoid doing multiple --- traversals of the type, e.g. we don't want to turn a builtin list into a Haskell --- list, and then traverse it again to conver the contents). Then we _need_ instances --- for all builtin types, even if they don't quite make sense. - --- Possibly this indicates that these type classes are a bit too 'ad-hoc' and we should --- get rid of them. --- -} - --- {- Note [Fundeps versus type families in To/FromBuiltin] --- We could use a type family here to get the builtin representation of a type. After all, it's --- entirely determined by the Haskell type. - --- However, this is harder for the plugin to deal with. It's okay to have a type variable --- for the representation type that needs to be instantiated later, but it's *not* okay to --- have an irreducible type application on a type variable. So fundeps are much nicer here. --- -} - --- {- Note [Strict conversions to/from unit] --- Converting to/from unit *should* be straightforward: just `const ()`. --- *But* GHC is very good at optimizing this, and we sometimes use unit --- where side effects matter, e.g. as the result of `trace`. So GHC will --- tend to turn `fromBuiltin (trace s)` into `()`, which is wrong. - --- So we want our conversions to/from unit to be strict in Haskell. This --- means we need to case pointlessly on the argument, which means we need --- case on unit (`chooseUnit`) as a builtin. But then it all works okay. --- -} - --- {- Note [noinline hack] --- For some functions we have two conflicting desires: --- - We want to have the unfolding available for the plugin. --- - We don't want the function to *actually* get inlined before the plugin runs, since we rely --- on being able to see the original function for some reason. - --- 'INLINABLE' achieves the first, but may cause the function to be inlined too soon. - --- We can solve this at specific call sites by using the 'noinline' magic function from --- GHC. This stops GHC from inlining it. As a bonus, it also won't be inlined if --- that function is compiled later into the body of another function. - --- We do therefore need to handle 'noinline' in the plugin, as it itself does not have --- an unfolding. - --- Another annoying quirk: even if you have 'noinline'd a function call, if the body is --- a single variable, it will still inline! This is the case for the obvious definition --- of 'stringToBuiltinString' (since the newtype constructor vanishes), so we have to add --- some obfuscation to the body to prevent it inlining. --- -} - --- {- Note [From/ToBuiltin instances for polymorphic builtin types] --- For various technical reasons --- (see Note [Representable built-in functions over polymorphic built-in types]) --- it's not always easy to provide polymorphic constructors for builtin types, but --- we can usually provide destructors. - --- What this means in practice is that we can write a generic FromBuiltin instance --- for pairs that makes use of polymorphic fst/snd builtins, but we can't write --- a polymorphic ToBuiltin instance because we'd need a polymorphic version of (,). - --- Instead we write monomorphic instances corresponding to monomorphic constructor --- builtins that we add for specific purposes. --- -} diff --git a/plutus-tx/src/PlutusTx/Builtins/IsBuiltin.hs b/plutus-tx/src/PlutusTx/Builtins/IsBuiltin.hs index a9eff666b08..0bd661e83c4 100644 --- a/plutus-tx/src/PlutusTx/Builtins/IsBuiltin.hs +++ b/plutus-tx/src/PlutusTx/Builtins/IsBuiltin.hs @@ -1,14 +1,8 @@ -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -fno-specialise #-} -{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} module PlutusTx.Builtins.IsBuiltin where @@ -28,26 +22,26 @@ import Data.Text (Text, pack) import GHC.Magic qualified as Magic import Prelude qualified as Haskell (String) -{-# NOINLINE obfuscatedId #-} obfuscatedId :: a -> a obfuscatedId a = a +{-# NOINLINE obfuscatedId #-} -{-# INLINABLE stringToBuiltinByteString #-} stringToBuiltinByteString :: Haskell.String -> BuiltinByteString stringToBuiltinByteString str = encodeUtf8 $ stringToBuiltinString str +{-# INLINABLE stringToBuiltinByteString #-} -{-# INLINABLE stringToBuiltinString #-} stringToBuiltinString :: Haskell.String -> BuiltinString -- To explain why the obfuscatedId is here -- See Note [noinline hack] stringToBuiltinString str = obfuscatedId (BuiltinString $ pack str) +{-# INLINABLE stringToBuiltinString #-} {- Same noinline hack as with `String` type. -} instance IsString BuiltinByteString where -- Try and make sure the dictionary selector goes away, it's simpler to match on -- the application of 'stringToBuiltinByteString' - {-# INLINE fromString #-} -- See Note [noinline hack] + {-# INLINE fromString #-} fromString = Magic.noinline stringToBuiltinByteString -- We can't put this in `Builtins.hs`, since that force `O0` deliberately, which prevents @@ -55,8 +49,8 @@ instance IsString BuiltinByteString where instance IsString BuiltinString where -- Try and make sure the dictionary selector goes away, it's simpler to match on -- the application of 'stringToBuiltinString' - {-# INLINE fromString #-} -- See Note [noinline hack] + {-# INLINE fromString #-} fromString = Magic.noinline stringToBuiltinString type HasFromBuiltin :: GHC.Type -> GHC.Constraint @@ -70,109 +64,130 @@ class HasToBuiltin a where instance HasFromBuiltin BuiltinInteger where type FromBuiltin BuiltinInteger = Integer - {-# INLINABLE fromBuiltin #-} fromBuiltin = id + {-# INLINABLE fromBuiltin #-} instance HasToBuiltin BuiltinInteger where - {-# INLINABLE toBuiltin #-} toBuiltin = id + {-# INLINABLE toBuiltin #-} instance HasFromBuiltin BuiltinByteString where type FromBuiltin BuiltinByteString = ByteString - {-# INLINABLE fromBuiltin #-} fromBuiltin (BuiltinByteString b) = b + {-# INLINABLE fromBuiltin #-} instance HasToBuiltin BuiltinByteString where - {-# INLINABLE toBuiltin #-} toBuiltin = BuiltinByteString + {-# INLINABLE toBuiltin #-} instance HasFromBuiltin BuiltinString where type FromBuiltin BuiltinString = Text - {-# INLINABLE fromBuiltin #-} fromBuiltin (BuiltinString t) = t + {-# INLINABLE fromBuiltin #-} instance HasToBuiltin BuiltinString where - {-# INLINABLE toBuiltin #-} toBuiltin = BuiltinString + {-# INLINABLE toBuiltin #-} instance HasFromBuiltin BuiltinUnit where type FromBuiltin BuiltinUnit = () - {-# INLINABLE fromBuiltin #-} fromBuiltin u = chooseUnit u () + {-# INLINABLE fromBuiltin #-} instance HasToBuiltin BuiltinUnit where - {-# INLINABLE toBuiltin #-} toBuiltin x = case x of () -> unitval + {-# INLINABLE toBuiltin #-} instance HasFromBuiltin BuiltinBool where type FromBuiltin BuiltinBool = Bool - {-# INLINABLE fromBuiltin #-} fromBuiltin b = ifThenElse b True False + {-# INLINABLE fromBuiltin #-} instance HasToBuiltin BuiltinBool where - {-# INLINABLE toBuiltin #-} toBuiltin b = if b then true else false + {-# INLINABLE toBuiltin #-} instance HasFromBuiltin a => HasFromBuiltin (BuiltinList a) where type FromBuiltin (BuiltinList a) = [FromBuiltin a] - {-# INLINABLE fromBuiltin #-} fromBuiltin = go where -- The combination of both INLINABLE and a type signature seems to stop this getting -- lifted to the top level, which means it gets a proper unfolding, which means that -- specialization can work, which can actually help quite a bit here. - {-# INLINABLE go #-} go :: BuiltinList a -> [FromBuiltin a] -- Note that we are using builtin chooseList here so this is *strict* application! So we -- need to do the manual laziness ourselves. go l = chooseList l (\_ -> []) (\_ -> fromBuiltin (head l) : go (tail l)) unitval + {-# INLINABLE go #-} + {-# INLINABLE fromBuiltin #-} instance HasToBuiltin (BuiltinList BuiltinData) where - {-# INLINE toBuiltin #-} toBuiltin = goList where goList :: [Data] -> BuiltinList BuiltinData goList [] = mkNilData unitval goList (d:ds) = mkCons (toBuiltin d) (goList ds) + {-# INLINE toBuiltin #-} instance HasToBuiltin (BuiltinList (BuiltinPair BuiltinData BuiltinData)) where - {-# INLINE toBuiltin #-} toBuiltin = goList where goList :: [(Data, Data)] -> BuiltinList (BuiltinPair BuiltinData BuiltinData) goList [] = mkNilPairData unitval goList (d:ds) = mkCons (toBuiltin d) (goList ds) + {-# INLINE toBuiltin #-} instance (HasFromBuiltin a, HasFromBuiltin b) => HasFromBuiltin (BuiltinPair a b) where type FromBuiltin (BuiltinPair a b) = (FromBuiltin a, FromBuiltin b) - {-# INLINABLE fromBuiltin #-} fromBuiltin p = (fromBuiltin $ fst p, fromBuiltin $ snd p) + {-# INLINABLE fromBuiltin #-} instance HasToBuiltin (BuiltinPair BuiltinData BuiltinData) where - {-# INLINABLE toBuiltin #-} toBuiltin (d1, d2) = mkPairData (toBuiltin d1) (toBuiltin d2) + {-# INLINABLE toBuiltin #-} instance HasFromBuiltin BuiltinData where type FromBuiltin BuiltinData = Data - {-# INLINABLE fromBuiltin #-} fromBuiltin (BuiltinData t) = t + {-# INLINABLE fromBuiltin #-} instance HasToBuiltin BuiltinData where - {-# INLINABLE toBuiltin #-} toBuiltin = BuiltinData + {-# INLINABLE toBuiltin #-} instance HasFromBuiltin BuiltinBLS12_381_G1_Element where type FromBuiltin BuiltinBLS12_381_G1_Element = BLS12_381.G1.Element - {-# INLINABLE fromBuiltin #-} fromBuiltin (BuiltinBLS12_381_G1_Element a) = a + {-# INLINABLE fromBuiltin #-} instance HasToBuiltin BuiltinBLS12_381_G1_Element where - {-# INLINABLE toBuiltin #-} toBuiltin = BuiltinBLS12_381_G1_Element + {-# INLINABLE toBuiltin #-} instance HasFromBuiltin BuiltinBLS12_381_G2_Element where type FromBuiltin BuiltinBLS12_381_G2_Element = BLS12_381.G2.Element - {-# INLINABLE fromBuiltin #-} fromBuiltin (BuiltinBLS12_381_G2_Element a) = a + {-# INLINABLE fromBuiltin #-} instance HasToBuiltin BuiltinBLS12_381_G2_Element where - {-# INLINABLE toBuiltin #-} toBuiltin = BuiltinBLS12_381_G2_Element + {-# INLINABLE toBuiltin #-} instance HasFromBuiltin BuiltinBLS12_381_MlResult where type FromBuiltin BuiltinBLS12_381_MlResult = BLS12_381.Pairing.MlResult - {-# INLINABLE fromBuiltin #-} fromBuiltin (BuiltinBLS12_381_MlResult a) = a + {-# INLINABLE fromBuiltin #-} instance HasToBuiltin BuiltinBLS12_381_MlResult where - {-# INLINABLE toBuiltin #-} toBuiltin = BuiltinBLS12_381_MlResult + {-# INLINABLE toBuiltin #-} + +{- Note [noinline hack] +For some functions we have two conflicting desires: +- We want to have the unfolding available for the plugin. +- We don't want the function to *actually* get inlined before the plugin runs, since we rely +on being able to see the original function for some reason. + +'INLINABLE' achieves the first, but may cause the function to be inlined too soon. + +We can solve this at specific call sites by using the 'noinline' magic function from +GHC. This stops GHC from inlining it. As a bonus, it also won't be inlined if +that function is compiled later into the body of another function. + +We do therefore need to handle 'noinline' in the plugin, as it itself does not have +an unfolding. + +Another annoying quirk: even if you have 'noinline'd a function call, if the body is +a single variable, it will still inline! This is the case for the obvious definition +of 'stringToBuiltinString' (since the newtype constructor vanishes), so we have to add +some obfuscation to the body to prevent it inlining. +-} diff --git a/plutus-tx/src/PlutusTx/Builtins/IsOpaque.hs b/plutus-tx/src/PlutusTx/Builtins/IsOpaque.hs index d23cbd1937a..626c1abe40c 100644 --- a/plutus-tx/src/PlutusTx/Builtins/IsOpaque.hs +++ b/plutus-tx/src/PlutusTx/Builtins/IsOpaque.hs @@ -1,138 +1,169 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -fno-specialise #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} module PlutusTx.Builtins.IsOpaque where -import PlutusCore.Crypto.BLS12_381.G1 qualified as BLS12_381.G1 (Element) -import PlutusCore.Crypto.BLS12_381.G2 qualified as BLS12_381.G2 (Element) -import PlutusCore.Crypto.BLS12_381.Pairing qualified as BLS12_381.Pairing (MlResult) import PlutusTx.Base (id, ($)) import PlutusTx.Bool (Bool (..)) import PlutusTx.Builtins.Internal import Data.Kind qualified as GHC -type HasFromOpaque :: GHC.Type -> GHC.Constraint -class HasFromOpaque a where - type FromOpaque a - fromOpaque :: a -> FromOpaque a -class HasToOpaque a where - toOpaque :: FromOpaque a -> a - -instance HasFromOpaque BuiltinInteger where - type FromOpaque BuiltinInteger = BuiltinInteger - {-# INLINABLE fromOpaque #-} +type HasFromOpaque :: GHC.Type -> GHC.Type -> GHC.Constraint +class HasFromOpaque arep a | arep -> a where + fromOpaque :: arep -> a + default fromOpaque :: a ~ arep => arep -> a fromOpaque = id -instance HasToOpaque BuiltinInteger where - {-# INLINABLE toOpaque #-} - toOpaque = id - -instance HasFromOpaque BuiltinByteString where - type FromOpaque BuiltinByteString = BuiltinByteString {-# INLINABLE fromOpaque #-} - fromOpaque = id -instance HasToOpaque BuiltinByteString where - {-# INLINABLE toOpaque #-} - toOpaque = id -instance HasFromOpaque BuiltinString where - type FromOpaque BuiltinString = BuiltinString - {-# INLINABLE fromOpaque #-} - fromOpaque = id -instance HasToOpaque BuiltinString where - {-# INLINABLE toOpaque #-} +type HasToOpaque :: GHC.Type -> GHC.Type -> GHC.Constraint +class HasToOpaque a arep | a -> arep where + toOpaque :: a -> arep + default toOpaque :: a ~ arep => a -> arep toOpaque = id + {-# INLINABLE toOpaque #-} -instance HasFromOpaque BuiltinUnit where - type FromOpaque BuiltinUnit = () - {-# INLINABLE fromOpaque #-} +instance HasFromOpaque BuiltinInteger BuiltinInteger +instance HasToOpaque BuiltinInteger BuiltinInteger + +instance HasFromOpaque BuiltinByteString BuiltinByteString +instance HasToOpaque BuiltinByteString BuiltinByteString + +instance HasFromOpaque BuiltinString BuiltinString +instance HasToOpaque BuiltinString BuiltinString + +instance HasFromOpaque BuiltinUnit () where fromOpaque u = chooseUnit u () -instance HasToOpaque BuiltinUnit where - {-# INLINABLE toOpaque #-} + {-# INLINABLE fromOpaque #-} +instance HasToOpaque () BuiltinUnit where toOpaque x = case x of () -> unitval + {-# INLINABLE toOpaque #-} -instance HasFromOpaque BuiltinBool where - type FromOpaque BuiltinBool = Bool - {-# INLINABLE fromOpaque #-} +instance HasFromOpaque BuiltinBool Bool where fromOpaque b = ifThenElse b True False -instance HasToOpaque BuiltinBool where - {-# INLINABLE toOpaque #-} + {-# INLINABLE fromOpaque #-} +instance HasToOpaque Bool BuiltinBool where toOpaque b = if b then true else false + {-# INLINABLE toOpaque #-} -instance HasFromOpaque a => HasFromOpaque (BuiltinList a) where - type FromOpaque (BuiltinList a) = [FromOpaque a] - - {-# INLINABLE fromOpaque #-} +instance HasFromOpaque arep a => HasFromOpaque (BuiltinList arep) [a] where fromOpaque = go where -- The combination of both INLINABLE and a type signature seems to stop this getting -- lifted to the top level, which means it gets a proper unfolding, which means that -- specialization can work, which can actually help quite a bit here. - {-# INLINABLE go #-} - go :: BuiltinList a -> [FromOpaque a] + go :: BuiltinList arep -> [a] -- Note that we are using builtin chooseList here so this is *strict* application! So we -- need to do the manual laziness ourselves. go l = chooseList l (\_ -> []) (\_ -> fromOpaque (head l) : go (tail l)) unitval - -instance HasToOpaque (BuiltinList BuiltinData) where - {-# INLINE toOpaque #-} + {-# INLINABLE go #-} + {-# INLINABLE fromOpaque #-} +instance HasToOpaque [BuiltinData] (BuiltinList BuiltinData) where toOpaque = goList where goList :: [BuiltinData] -> BuiltinList BuiltinData goList [] = mkNilData unitval goList (d:ds) = mkCons (toOpaque d) (goList ds) - -instance HasToOpaque (BuiltinList (BuiltinPair BuiltinData BuiltinData)) where {-# INLINE toOpaque #-} +instance + HasToOpaque + [(BuiltinData, BuiltinData)] + (BuiltinList (BuiltinPair BuiltinData BuiltinData)) where toOpaque = goList where goList :: [(BuiltinData, BuiltinData)] -> BuiltinList (BuiltinPair BuiltinData BuiltinData) goList [] = mkNilPairData unitval goList (d:ds) = mkCons (toOpaque d) (goList ds) + {-# INLINE toOpaque #-} -instance (HasFromOpaque a, HasFromOpaque b) => HasFromOpaque (BuiltinPair a b) where - type FromOpaque (BuiltinPair a b) = (FromOpaque a, FromOpaque b) - {-# INLINABLE fromOpaque #-} +instance (HasFromOpaque arep a, HasFromOpaque brep b) => + HasFromOpaque (BuiltinPair arep brep) (a, b) where fromOpaque p = (fromOpaque $ fst p, fromOpaque $ snd p) -instance HasToOpaque (BuiltinPair BuiltinData BuiltinData) where - {-# INLINABLE toOpaque #-} - toOpaque (d1, d2) = mkPairData d1 d2 - -instance HasFromOpaque BuiltinData where - type FromOpaque BuiltinData = BuiltinData - {-# INLINABLE fromOpaque #-} - fromOpaque = id -instance HasToOpaque BuiltinData where - {-# INLINABLE toOpaque #-} - toOpaque = id - -instance HasFromOpaque BuiltinBLS12_381_G1_Element where - type FromOpaque BuiltinBLS12_381_G1_Element = BLS12_381.G1.Element {-# INLINABLE fromOpaque #-} - fromOpaque (BuiltinBLS12_381_G1_Element a) = a -instance HasToOpaque BuiltinBLS12_381_G1_Element where +instance HasToOpaque (BuiltinData, BuiltinData) (BuiltinPair BuiltinData BuiltinData) where + toOpaque (d1, d2) = mkPairData (toOpaque d1) (toOpaque d2) {-# INLINABLE toOpaque #-} - toOpaque = BuiltinBLS12_381_G1_Element -instance HasFromOpaque BuiltinBLS12_381_G2_Element where - type FromOpaque BuiltinBLS12_381_G2_Element = BLS12_381.G2.Element - {-# INLINABLE fromOpaque #-} - fromOpaque (BuiltinBLS12_381_G2_Element a) = a -instance HasToOpaque BuiltinBLS12_381_G2_Element where - {-# INLINABLE toOpaque #-} - toOpaque = BuiltinBLS12_381_G2_Element - -instance HasFromOpaque BuiltinBLS12_381_MlResult where - type FromOpaque BuiltinBLS12_381_MlResult = BLS12_381.Pairing.MlResult - {-# INLINABLE fromOpaque #-} - fromOpaque (BuiltinBLS12_381_MlResult a) = a -instance HasToOpaque BuiltinBLS12_381_MlResult where - {-# INLINABLE toOpaque #-} - toOpaque = BuiltinBLS12_381_MlResult +instance HasFromOpaque BuiltinData BuiltinData +instance HasToOpaque BuiltinData BuiltinData + +instance HasFromOpaque BuiltinBLS12_381_G1_Element BuiltinBLS12_381_G1_Element +instance HasToOpaque BuiltinBLS12_381_G1_Element BuiltinBLS12_381_G1_Element + +instance HasFromOpaque BuiltinBLS12_381_G2_Element BuiltinBLS12_381_G2_Element +instance HasToOpaque BuiltinBLS12_381_G2_Element BuiltinBLS12_381_G2_Element + +instance HasFromOpaque BuiltinBLS12_381_MlResult BuiltinBLS12_381_MlResult +instance HasToOpaque BuiltinBLS12_381_MlResult BuiltinBLS12_381_MlResult + +-- TODO: FIX THE NOTES + +{- Note [Builtin types and their Haskell versions] +Consider the builtin pair type. In Plutus Tx, we have an (opaque) type for +this. It's opaque because you can't actually pattern match on it, instead you can +only in fact use the specific functions that are available as builtins. + +We _also_ have the normal Haskell pair type. This is very different: you can +pattern match on it, and you can use whatever user-defined functions you like on it. + +Users would really like to use the latter, and not the former. So we often want +to _wrap_ our builtin functions with little adapters that convert between the +"opaque builtin" "version" of a type and the "normal Haskell" "version" of a type. + +This is what the ToBuiltin and FromBuiltin classes do. They let us write wrappers +for builtins relatively consistently by just calling toBuiltin on their arguments +and fromBuiltin on the result. They shouldn't really be used otherwise. + +Ideally, we would not have instances for types which don't have a different +Haskell representation type, such as Integer. Integer in Plutus Tx user code _is_ the +opaque builtin type, we don't expose a different one. So there's no conversion to +do. However, this interacts badly with the instances for polymorphic builtin types, which +also convert the type _inside_ them. (This is necessary to avoid doing multiple +traversals of the type, e.g. we don't want to turn a builtin list into a Haskell +list, and then traverse it again to conver the contents). Then we _need_ instances +for all builtin types, even if they don't quite make sense. + +Possibly this indicates that these type classes are a bit too 'ad-hoc' and we should +get rid of them. +-} + +{- Note [From/ToBuiltin instances for polymorphic builtin types] +For various technical reasons +(see Note [Representable built-in functions over polymorphic built-in types]) +it's not always easy to provide polymorphic constructors for builtin types, but +we can usually provide destructors. + +What this means in practice is that we can write a generic FromBuiltin instance +for pairs that makes use of polymorphic fst/snd builtins, but we can't write +a polymorphic ToBuiltin instance because we'd need a polymorphic version of (,). + +Instead we write monomorphic instances corresponding to monomorphic constructor +builtins that we add for specific purposes. +-} + +{- Note [Fundeps versus type families in To/FromBuiltin] +We could use a type family here to get the builtin representation of a type. After all, it's +entirely determined by the Haskell type. + +However, this is harder for the plugin to deal with. It's okay to have a type variable +for the representation type that needs to be instantiated later, but it's *not* okay to +have an irreducible type application on a type variable. So fundeps are much nicer here. +-} + +{- Note [Strict conversions to/from unit] +Converting to/from unit *should* be straightforward: just `const ()`. +*But* GHC is very good at optimizing this, and we sometimes use unit +where side effects matter, e.g. as the result of `trace`. So GHC will +tend to turn `fromBuiltin (trace s)` into `()`, which is wrong. + +So we want our conversions to/from unit to be strict in Haskell. This +means we need to case pointlessly on the argument, which means we need +case on unit (`chooseUnit`) as a builtin. But then it all works okay. +-} diff --git a/plutus-tx/src/PlutusTx/IsData/Class.hs b/plutus-tx/src/PlutusTx/IsData/Class.hs index 7f751420c38..19c5f0d5827 100644 --- a/plutus-tx/src/PlutusTx/IsData/Class.hs +++ b/plutus-tx/src/PlutusTx/IsData/Class.hs @@ -162,7 +162,7 @@ instance FromData Builtins.BuiltinBLS12_381_G1_Element where Just (BI.BuiltinByteString bs) -> case BLS12_381.G1.uncompress bs of Haskell.Left _ -> Nothing - Haskell.Right g -> Just $ toOpaque g + Haskell.Right g -> Just $ toBuiltin g instance UnsafeFromData Builtins.BuiltinBLS12_381_G1_Element where {-# INLINABLE unsafeFromBuiltinData #-} unsafeFromBuiltinData = Builtins.bls12_381_G1_uncompress . unsafeFromBuiltinData @@ -178,7 +178,7 @@ instance FromData Builtins.BuiltinBLS12_381_G2_Element where Just (BI.BuiltinByteString bs) -> case BLS12_381.G2.uncompress bs of Haskell.Left _ -> Nothing - Haskell.Right g -> Just $ toOpaque g + Haskell.Right g -> Just $ toBuiltin g instance UnsafeFromData Builtins.BuiltinBLS12_381_G2_Element where {-# INLINABLE unsafeFromBuiltinData #-} unsafeFromBuiltinData = Builtins.bls12_381_G2_uncompress . unsafeFromBuiltinData From 8a02b6640f56bbd9f354ddb030d4ffa05a84b1b0 Mon Sep 17 00:00:00 2001 From: effectfully Date: Sat, 11 May 2024 03:10:22 +0200 Subject: [PATCH 22/41] Add 'ToBuiltin' --- plutus-ledger-api/test-plugin/Spec/Value.hs | 2 +- .../src/PlutusTx/Compiler/Builtins.hs | 2 +- .../src/PlutusTx/Compiler/Expr.hs | 2 +- plutus-tx/src/PlutusTx/Builtins/IsBuiltin.hs | 167 ++++++------------ plutus-tx/src/PlutusTx/Builtins/IsOpaque.hs | 36 ++++ plutus-tx/src/PlutusTx/Prelude.hs | 8 +- 6 files changed, 95 insertions(+), 122 deletions(-) diff --git a/plutus-ledger-api/test-plugin/Spec/Value.hs b/plutus-ledger-api/test-plugin/Spec/Value.hs index 87ad1c6ec24..45a66451fe9 100644 --- a/plutus-ledger-api/test-plugin/Spec/Value.hs +++ b/plutus-ledger-api/test-plugin/Spec/Value.hs @@ -157,7 +157,7 @@ valueToLists = ListTx.map (fmap AssocMap.toList) . AssocMap.toList . getValue eqValueCode :: CompiledCode Value -> CompiledCode Value -> (Bool, PLC.CountingSt) eqValueCode valueCode1 valueCode2 = (res, cost) where prog = - $$(compile [|| \value1 value2 -> toBuiltin ((value1 :: Value) == value2) ||]) + $$(compile [|| \value1 value2 -> toOpaque ((value1 :: Value) == value2) ||]) `unsafeApplyCode` valueCode1 `unsafeApplyCode` valueCode2 (errOrRes, cost) = PLC.runCekNoEmit PLC.defaultCekParameters PLC.counting diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs index 48a80e88001..8a8a01db9c8 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs @@ -19,7 +19,7 @@ module PlutusTx.Compiler.Builtins ( , errorFunc) where import PlutusTx.Builtins.Internal qualified as Builtins -import PlutusTx.Builtins.IsBuiltin qualified as Builtins +import PlutusTx.Builtins.IsOpaque qualified as Builtins import PlutusTx.Compiler.Error import PlutusTx.Compiler.Names diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs index 519febe83aa..3f2aecdcab3 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs @@ -49,7 +49,7 @@ import PlutusTx.PIRTypes import PlutusTx.PLCTypes (PLCType, PLCVar) -- I feel like we shouldn't need this, we only need it to spot the special String type, which is annoying -import PlutusTx.Builtins.IsBuiltin qualified as Builtins +import PlutusTx.Builtins.IsOpaque qualified as Builtins import PlutusTx.Trace import PlutusIR qualified as PIR diff --git a/plutus-tx/src/PlutusTx/Builtins/IsBuiltin.hs b/plutus-tx/src/PlutusTx/Builtins/IsBuiltin.hs index 0bd661e83c4..963f0fec4fd 100644 --- a/plutus-tx/src/PlutusTx/Builtins/IsBuiltin.hs +++ b/plutus-tx/src/PlutusTx/Builtins/IsBuiltin.hs @@ -1,175 +1,110 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeFamilies #-} - -{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE TypeOperators #-} module PlutusTx.Builtins.IsBuiltin where +import Prelude + import PlutusCore.Crypto.BLS12_381.G1 qualified as BLS12_381.G1 (Element) import PlutusCore.Crypto.BLS12_381.G2 qualified as BLS12_381.G2 (Element) import PlutusCore.Crypto.BLS12_381.Pairing qualified as BLS12_381.Pairing (MlResult) import PlutusCore.Data (Data) -import PlutusTx.Base (id, ($)) -import PlutusTx.Bool (Bool (..)) +import PlutusCore.Default qualified as PLC import PlutusTx.Builtins.Internal -import PlutusTx.Integer (Integer) import Data.ByteString (ByteString) import Data.Kind qualified as GHC -import Data.String (IsString (..)) -import Data.Text (Text, pack) -import GHC.Magic qualified as Magic -import Prelude qualified as Haskell (String) - -obfuscatedId :: a -> a -obfuscatedId a = a -{-# NOINLINE obfuscatedId #-} - -stringToBuiltinByteString :: Haskell.String -> BuiltinByteString -stringToBuiltinByteString str = encodeUtf8 $ stringToBuiltinString str -{-# INLINABLE stringToBuiltinByteString #-} - -stringToBuiltinString :: Haskell.String -> BuiltinString --- To explain why the obfuscatedId is here --- See Note [noinline hack] -stringToBuiltinString str = obfuscatedId (BuiltinString $ pack str) -{-# INLINABLE stringToBuiltinString #-} - -{- Same noinline hack as with `String` type. -} -instance IsString BuiltinByteString where - -- Try and make sure the dictionary selector goes away, it's simpler to match on - -- the application of 'stringToBuiltinByteString' - -- See Note [noinline hack] - {-# INLINE fromString #-} - fromString = Magic.noinline stringToBuiltinByteString - --- We can't put this in `Builtins.hs`, since that force `O0` deliberately, which prevents --- the unfoldings from going in. So we just stick it here. Fiddly. -instance IsString BuiltinString where - -- Try and make sure the dictionary selector goes away, it's simpler to match on - -- the application of 'stringToBuiltinString' - -- See Note [noinline hack] - {-# INLINE fromString #-} - fromString = Magic.noinline stringToBuiltinString - -type HasFromBuiltin :: GHC.Type -> GHC.Constraint -class HasFromBuiltin a where - type FromBuiltin a - fromBuiltin :: a -> FromBuiltin a +import Data.Text (Text) type HasToBuiltin :: GHC.Type -> GHC.Constraint -class HasToBuiltin a where - toBuiltin :: FromBuiltin a -> a +class PLC.DefaultUni `PLC.Contains` a => HasToBuiltin a where + type ToBuiltin a + toBuiltin :: a -> ToBuiltin a + +type HasFromBuiltin :: GHC.Type -> GHC.Constraint +class HasToBuiltin (FromBuiltin arep) => HasFromBuiltin arep where + type FromBuiltin arep + fromBuiltin :: arep -> FromBuiltin arep +instance HasToBuiltin Integer where + type ToBuiltin Integer = BuiltinInteger + toBuiltin = id instance HasFromBuiltin BuiltinInteger where type FromBuiltin BuiltinInteger = Integer fromBuiltin = id - {-# INLINABLE fromBuiltin #-} -instance HasToBuiltin BuiltinInteger where - toBuiltin = id - {-# INLINABLE toBuiltin #-} +instance HasToBuiltin ByteString where + type ToBuiltin ByteString = BuiltinByteString + toBuiltin = BuiltinByteString instance HasFromBuiltin BuiltinByteString where type FromBuiltin BuiltinByteString = ByteString fromBuiltin (BuiltinByteString b) = b - {-# INLINABLE fromBuiltin #-} -instance HasToBuiltin BuiltinByteString where - toBuiltin = BuiltinByteString - {-# INLINABLE toBuiltin #-} +instance HasToBuiltin Text where + type ToBuiltin Text = BuiltinString + toBuiltin = BuiltinString instance HasFromBuiltin BuiltinString where type FromBuiltin BuiltinString = Text fromBuiltin (BuiltinString t) = t - {-# INLINABLE fromBuiltin #-} -instance HasToBuiltin BuiltinString where - toBuiltin = BuiltinString - {-# INLINABLE toBuiltin #-} +instance HasToBuiltin () where + type ToBuiltin () = BuiltinUnit + toBuiltin = BuiltinUnit instance HasFromBuiltin BuiltinUnit where type FromBuiltin BuiltinUnit = () - fromBuiltin u = chooseUnit u () - {-# INLINABLE fromBuiltin #-} -instance HasToBuiltin BuiltinUnit where - toBuiltin x = case x of () -> unitval - {-# INLINABLE toBuiltin #-} + fromBuiltin (BuiltinUnit u) = u +instance HasToBuiltin Bool where + type ToBuiltin Bool = BuiltinBool + toBuiltin = BuiltinBool instance HasFromBuiltin BuiltinBool where type FromBuiltin BuiltinBool = Bool - fromBuiltin b = ifThenElse b True False - {-# INLINABLE fromBuiltin #-} -instance HasToBuiltin BuiltinBool where - toBuiltin b = if b then true else false - {-# INLINABLE toBuiltin #-} + fromBuiltin (BuiltinBool b) = b +instance HasToBuiltin a => HasToBuiltin [a] where + type ToBuiltin [a] = BuiltinList (ToBuiltin a) + toBuiltin = BuiltinList . map toBuiltin instance HasFromBuiltin a => HasFromBuiltin (BuiltinList a) where type FromBuiltin (BuiltinList a) = [FromBuiltin a] + fromBuiltin (BuiltinList xs) = map fromBuiltin xs - fromBuiltin = go - where - -- The combination of both INLINABLE and a type signature seems to stop this getting - -- lifted to the top level, which means it gets a proper unfolding, which means that - -- specialization can work, which can actually help quite a bit here. - go :: BuiltinList a -> [FromBuiltin a] - -- Note that we are using builtin chooseList here so this is *strict* application! So we - -- need to do the manual laziness ourselves. - go l = chooseList l (\_ -> []) (\_ -> fromBuiltin (head l) : go (tail l)) unitval - {-# INLINABLE go #-} - {-# INLINABLE fromBuiltin #-} - -instance HasToBuiltin (BuiltinList BuiltinData) where - toBuiltin = goList where - goList :: [Data] -> BuiltinList BuiltinData - goList [] = mkNilData unitval - goList (d:ds) = mkCons (toBuiltin d) (goList ds) - {-# INLINE toBuiltin #-} - -instance HasToBuiltin (BuiltinList (BuiltinPair BuiltinData BuiltinData)) where - toBuiltin = goList where - goList :: [(Data, Data)] -> BuiltinList (BuiltinPair BuiltinData BuiltinData) - goList [] = mkNilPairData unitval - goList (d:ds) = mkCons (toBuiltin d) (goList ds) - {-# INLINE toBuiltin #-} - +instance (HasToBuiltin a, HasToBuiltin b) => HasToBuiltin (a, b) where + type ToBuiltin (a, b) = BuiltinPair (ToBuiltin a) (ToBuiltin b) + toBuiltin (x, y) = BuiltinPair (toBuiltin x, toBuiltin y) instance (HasFromBuiltin a, HasFromBuiltin b) => HasFromBuiltin (BuiltinPair a b) where type FromBuiltin (BuiltinPair a b) = (FromBuiltin a, FromBuiltin b) - fromBuiltin p = (fromBuiltin $ fst p, fromBuiltin $ snd p) - {-# INLINABLE fromBuiltin #-} -instance HasToBuiltin (BuiltinPair BuiltinData BuiltinData) where - toBuiltin (d1, d2) = mkPairData (toBuiltin d1) (toBuiltin d2) - {-# INLINABLE toBuiltin #-} + fromBuiltin (BuiltinPair (x, y)) = (fromBuiltin x, fromBuiltin y) +instance HasToBuiltin Data where + type ToBuiltin Data = BuiltinData + toBuiltin = BuiltinData instance HasFromBuiltin BuiltinData where type FromBuiltin BuiltinData = Data fromBuiltin (BuiltinData t) = t - {-# INLINABLE fromBuiltin #-} -instance HasToBuiltin BuiltinData where - toBuiltin = BuiltinData - {-# INLINABLE toBuiltin #-} +instance HasToBuiltin BLS12_381.G1.Element where + type ToBuiltin BLS12_381.G1.Element = BuiltinBLS12_381_G1_Element + toBuiltin = BuiltinBLS12_381_G1_Element instance HasFromBuiltin BuiltinBLS12_381_G1_Element where type FromBuiltin BuiltinBLS12_381_G1_Element = BLS12_381.G1.Element fromBuiltin (BuiltinBLS12_381_G1_Element a) = a - {-# INLINABLE fromBuiltin #-} -instance HasToBuiltin BuiltinBLS12_381_G1_Element where - toBuiltin = BuiltinBLS12_381_G1_Element - {-# INLINABLE toBuiltin #-} +instance HasToBuiltin BLS12_381.G2.Element where + type ToBuiltin BLS12_381.G2.Element = BuiltinBLS12_381_G2_Element + toBuiltin = BuiltinBLS12_381_G2_Element instance HasFromBuiltin BuiltinBLS12_381_G2_Element where type FromBuiltin BuiltinBLS12_381_G2_Element = BLS12_381.G2.Element fromBuiltin (BuiltinBLS12_381_G2_Element a) = a - {-# INLINABLE fromBuiltin #-} -instance HasToBuiltin BuiltinBLS12_381_G2_Element where - toBuiltin = BuiltinBLS12_381_G2_Element - {-# INLINABLE toBuiltin #-} +instance HasToBuiltin BLS12_381.Pairing.MlResult where + type ToBuiltin BLS12_381.Pairing.MlResult = BuiltinBLS12_381_MlResult + toBuiltin = BuiltinBLS12_381_MlResult instance HasFromBuiltin BuiltinBLS12_381_MlResult where type FromBuiltin BuiltinBLS12_381_MlResult = BLS12_381.Pairing.MlResult fromBuiltin (BuiltinBLS12_381_MlResult a) = a - {-# INLINABLE fromBuiltin #-} -instance HasToBuiltin BuiltinBLS12_381_MlResult where - toBuiltin = BuiltinBLS12_381_MlResult - {-# INLINABLE toBuiltin #-} {- Note [noinline hack] For some functions we have two conflicting desires: diff --git a/plutus-tx/src/PlutusTx/Builtins/IsOpaque.hs b/plutus-tx/src/PlutusTx/Builtins/IsOpaque.hs index 626c1abe40c..9ed8928db36 100644 --- a/plutus-tx/src/PlutusTx/Builtins/IsOpaque.hs +++ b/plutus-tx/src/PlutusTx/Builtins/IsOpaque.hs @@ -9,6 +9,7 @@ {-# OPTIONS_GHC -fno-specialise #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} +{-# OPTIONS_GHC -Wno-orphans #-} module PlutusTx.Builtins.IsOpaque where @@ -17,6 +18,41 @@ import PlutusTx.Bool (Bool (..)) import PlutusTx.Builtins.Internal import Data.Kind qualified as GHC +import Data.String (IsString (..)) +import Data.Text qualified as Text +import GHC.Magic qualified as Magic +import Prelude qualified as Haskell (String) + +obfuscatedId :: a -> a +obfuscatedId a = a +{-# NOINLINE obfuscatedId #-} + +stringToBuiltinByteString :: Haskell.String -> BuiltinByteString +stringToBuiltinByteString str = encodeUtf8 $ stringToBuiltinString str +{-# INLINABLE stringToBuiltinByteString #-} + +stringToBuiltinString :: Haskell.String -> BuiltinString +-- To explain why the obfuscatedId is here +-- See Note [noinline hack] +stringToBuiltinString str = obfuscatedId (BuiltinString $ Text.pack str) +{-# INLINABLE stringToBuiltinString #-} + +{- Same noinline hack as with `String` type. -} +instance IsString BuiltinByteString where + -- Try and make sure the dictionary selector goes away, it's simpler to match on + -- the application of 'stringToBuiltinByteString' + -- See Note [noinline hack] + fromString = Magic.noinline stringToBuiltinByteString + {-# INLINE fromString #-} + +-- We can't put this in `Builtins.hs`, since that force `O0` deliberately, which prevents +-- the unfoldings from going in. So we just stick it here. Fiddly. +instance IsString BuiltinString where + -- Try and make sure the dictionary selector goes away, it's simpler to match on + -- the application of 'stringToBuiltinString' + -- See Note [noinline hack] + fromString = Magic.noinline stringToBuiltinString + {-# INLINE fromString #-} type HasFromOpaque :: GHC.Type -> GHC.Type -> GHC.Constraint class HasFromOpaque arep a | arep -> a where diff --git a/plutus-tx/src/PlutusTx/Prelude.hs b/plutus-tx/src/PlutusTx/Prelude.hs index 89ee23ea55d..7358089cc44 100644 --- a/plutus-tx/src/PlutusTx/Prelude.hs +++ b/plutus-tx/src/PlutusTx/Prelude.hs @@ -110,7 +110,9 @@ module PlutusTx.Prelude ( integerToByteString, -- * Conversions fromBuiltin, - toBuiltin + toBuiltin, + fromOpaque, + toOpaque ) where import Data.String (IsString (..)) @@ -131,9 +133,9 @@ import PlutusTx.Builtins (BuiltinBLS12_381_G1_Element, BuiltinBLS12_381_G2_Eleme bls12_381_G2_uncompress, bls12_381_finalVerify, bls12_381_millerLoop, bls12_381_mulMlResult, byteStringToInteger, consByteString, decodeUtf8, emptyByteString, emptyString, encodeUtf8, equalsByteString, equalsString, - error, fromBuiltin, greaterThanByteString, indexByteString, + error, fromBuiltin, fromOpaque, greaterThanByteString, indexByteString, integerToByteString, keccak_256, lengthOfByteString, lessThanByteString, - sha2_256, sha3_256, sliceByteString, toBuiltin, trace, + sha2_256, sha3_256, sliceByteString, toBuiltin, toOpaque, trace, verifyEcdsaSecp256k1Signature, verifyEd25519Signature, verifySchnorrSecp256k1Signature) From 669e25fcf4fc9d4c964a50cd43b57cbfef5c4cb3 Mon Sep 17 00:00:00 2001 From: effectfully Date: Sat, 11 May 2024 06:30:30 +0200 Subject: [PATCH 23/41] Add 'TestInstances' --- .../src/PlutusCore/Builtin/Polymorphism.hs | 4 +- plutus-tx/plutus-tx.cabal | 1 + plutus-tx/src/PlutusTx/Lift/Class.hs | 49 +++++++++---------- plutus-tx/src/PlutusTx/Lift/TestInstances.hs | 39 +++++++++++++++ 4 files changed, 66 insertions(+), 27 deletions(-) create mode 100644 plutus-tx/src/PlutusTx/Lift/TestInstances.hs diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/Polymorphism.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/Polymorphism.hs index 19bc3481043..7a0ffc5bb82 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Builtin/Polymorphism.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/Polymorphism.hs @@ -8,6 +8,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} module PlutusCore.Builtin.Polymorphism ( Opaque (..) @@ -214,7 +215,8 @@ type family AllElaboratedArgs constr x where -- built-in type. type AllBuiltinArgs :: forall a. (GHC.Type -> GHC.Type) -> (GHC.Type -> GHC.Constraint) -> a -> GHC.Constraint -type AllBuiltinArgs uni constr x = AllElaboratedArgs constr (ElaborateBuiltin uni x) +class AllElaboratedArgs constr (ElaborateBuiltin uni x) => AllBuiltinArgs uni constr x +instance AllElaboratedArgs constr (ElaborateBuiltin uni x) => AllBuiltinArgs uni constr x -- Custom type errors to guide the programmer adding a new built-in function. diff --git a/plutus-tx/plutus-tx.cabal b/plutus-tx/plutus-tx.cabal index 40faf55800b..c050c8ddadd 100644 --- a/plutus-tx/plutus-tx.cabal +++ b/plutus-tx/plutus-tx.cabal @@ -109,6 +109,7 @@ library PlutusTx.IsData.Instances PlutusTx.IsData.TH PlutusTx.Lift.Instances + PlutusTx.Lift.TestInstances PlutusTx.Lift.TH PlutusTx.Lift.THUtils diff --git a/plutus-tx/src/PlutusTx/Lift/Class.hs b/plutus-tx/src/PlutusTx/Lift/Class.hs index 8d7597ff818..28a89918e6f 100644 --- a/plutus-tx/src/PlutusTx/Lift/Class.hs +++ b/plutus-tx/src/PlutusTx/Lift/Class.hs @@ -30,7 +30,8 @@ import PlutusCore.Data import PlutusCore.Quote import PlutusIR.MkPir import PlutusTx.Builtins -import PlutusTx.Builtins.Internal (BuiltinBool, BuiltinList, BuiltinPair, BuiltinUnit) +import PlutusTx.Builtins.Internal (BuiltinBool, BuiltinInteger, BuiltinList, BuiltinPair, + BuiltinUnit) import PlutusTx.Builtins.IsBuiltin (FromBuiltin, HasFromBuiltin) import Language.Haskell.TH qualified as TH hiding (newName) @@ -132,28 +133,16 @@ instance (TypeError ('Text "Int is not supported, use Integer instead")) => Lift uni Int where lift = Haskell.error "unsupported" -instance uni `PLC.HasTypeLevel` Integer => Typeable uni Integer where +instance uni `PLC.HasTypeLevel` Integer => Typeable uni BuiltinInteger where typeRep = typeRepBuiltin -- See Note [Lift and Typeable instances for builtins] -instance uni `PLC.HasTermLevel` Integer => Lift uni Integer where +instance uni `PLC.HasTermLevel` Integer => Lift uni BuiltinInteger where lift = liftBuiltin --- See Note [Lift and Typeable instances for builtins] -instance uni `PLC.HasTypeLevel` BS.ByteString => Typeable uni BS.ByteString where - typeRep = typeRepBuiltin - --- See Note [Lift and Typeable instances for builtins] -instance uni `PLC.HasTypeLevel` Data => Typeable uni BuiltinData where - typeRep _ = typeRepBuiltin (Proxy @Data) - --- See Note [Lift and Typeable instances for builtins] -instance uni `PLC.HasTermLevel` Data => Lift uni BuiltinData where - lift = liftBuiltin . builtinDataToData - -- See Note [Lift and Typeable instances for builtins] instance uni `PLC.HasTypeLevel` BS.ByteString => Typeable uni BuiltinByteString where - typeRep _proxyByteString = typeRepBuiltin (Proxy @BS.ByteString) + typeRep _ = typeRepBuiltin (Proxy @BS.ByteString) -- See Note [Lift and Typeable instances for builtins] instance uni `PLC.HasTermLevel` BS.ByteString => Lift uni BuiltinByteString where @@ -161,7 +150,7 @@ instance uni `PLC.HasTermLevel` BS.ByteString => Lift uni BuiltinByteString wher -- See Note [Lift and Typeable instances for builtins] instance uni `PLC.HasTypeLevel` T.Text => Typeable uni BuiltinString where - typeRep _proxyByteString = typeRepBuiltin (Proxy @T.Text) + typeRep _ = typeRepBuiltin (Proxy @T.Text) -- See Note [Lift and Typeable instances for builtins] instance uni `PLC.HasTermLevel` T.Text => Lift uni BuiltinString where @@ -169,7 +158,7 @@ instance uni `PLC.HasTermLevel` T.Text => Lift uni BuiltinString where -- See Note [Lift and Typeable instances for builtins] instance uni `PLC.HasTypeLevel` () => Typeable uni BuiltinUnit where - typeRep _proxyUnit = typeRepBuiltin (Proxy @()) + typeRep _ = typeRepBuiltin (Proxy @()) -- See Note [Lift and Typeable instances for builtins] instance uni `PLC.HasTermLevel` () => Lift uni BuiltinUnit where @@ -177,7 +166,7 @@ instance uni `PLC.HasTermLevel` () => Lift uni BuiltinUnit where -- See Note [Lift and Typeable instances for builtins] instance uni `PLC.HasTypeLevel` Bool => Typeable uni BuiltinBool where - typeRep _proxyBool = typeRepBuiltin (Proxy @Bool) + typeRep _ = typeRepBuiltin (Proxy @Bool) -- See Note [Lift and Typeable instances for builtins] instance uni `PLC.HasTermLevel` Bool => Lift uni BuiltinBool where @@ -185,22 +174,30 @@ instance uni `PLC.HasTermLevel` Bool => Lift uni BuiltinBool where -- See Note [Lift and Typeable instances for builtins] instance uni `PLC.HasTypeLevel` [] => Typeable uni BuiltinList where - typeRep _proxyBuiltinList = typeRepBuiltin (Proxy @[]) + typeRep _ = typeRepBuiltin (Proxy @[]) -- See Note [Lift and Typeable instances for builtins] -instance (HasFromBuiltin a, uni `PLC.HasTermLevel` [FromBuiltin a]) => - Lift uni (BuiltinList a) where +instance (HasFromBuiltin arep, uni `PLC.HasTermLevel` [FromBuiltin arep]) => + Lift uni (BuiltinList arep) where lift = liftBuiltin . fromBuiltin instance uni `PLC.HasTypeLevel` (,) => Typeable uni BuiltinPair where - typeRep _proxyBuiltinPair = typeRepBuiltin (Proxy @(,)) + typeRep _ = typeRepBuiltin (Proxy @(,)) instance - ( HasFromBuiltin a, HasFromBuiltin b - , uni `PLC.HasTermLevel` (FromBuiltin a, FromBuiltin b) - ) => Lift uni (BuiltinPair a b) where + ( HasFromBuiltin arep, HasFromBuiltin brep + , uni `PLC.HasTermLevel` (FromBuiltin arep, FromBuiltin brep) + ) => Lift uni (BuiltinPair arep brep) where lift = liftBuiltin . fromBuiltin +-- See Note [Lift and Typeable instances for builtins] +instance uni `PLC.HasTypeLevel` Data => Typeable uni BuiltinData where + typeRep _ = typeRepBuiltin (Proxy @Data) + +-- See Note [Lift and Typeable instances for builtins] +instance uni `PLC.HasTermLevel` Data => Lift uni BuiltinData where + lift = liftBuiltin . builtinDataToData + -- See Note [Lift and Typeable instances for builtins] instance uni `PLC.HasTypeLevel` PlutusCore.Crypto.BLS12_381.G1.Element => Typeable uni BuiltinBLS12_381_G1_Element where diff --git a/plutus-tx/src/PlutusTx/Lift/TestInstances.hs b/plutus-tx/src/PlutusTx/Lift/TestInstances.hs new file mode 100644 index 00000000000..8427b3dc3ff --- /dev/null +++ b/plutus-tx/src/PlutusTx/Lift/TestInstances.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +module PlutusTx.Lift.TestInstances () where + +import PlutusCore qualified as PLC +import PlutusCore.Builtin qualified as PLC +import PlutusTx.Builtins.IsBuiltin +import PlutusTx.Lift.Class + +import Data.Kind qualified as GHC + +type BuiltinSatisfies + :: (GHC.Type -> GHC.Constraint) + -> (GHC.Type -> GHC.Constraint) + -> GHC.Type + -> GHC.Constraint +class (pre (ToBuiltin a) => post (ToBuiltin a)) => BuiltinSatisfies pre post a +instance (pre (ToBuiltin a) => post (ToBuiltin a)) => BuiltinSatisfies pre post a + +type AllBuiltinsSatisfy + :: (GHC.Type -> GHC.Constraint) + -> (GHC.Type -> GHC.Constraint) + -> GHC.Constraint +class PLC.DefaultUni `PLC.Everywhere` BuiltinSatisfies pre post => AllBuiltinsSatisfy pre post + +instance AllBuiltinsSatisfy + (PLC.AllBuiltinArgs PLC.DefaultUni (Typeable PLC.DefaultUni)) + (Typeable PLC.DefaultUni) +instance AllBuiltinsSatisfy + (PLC.AllBuiltinArgs PLC.DefaultUni HasFromBuiltin) + (Lift PLC.DefaultUni) From bb18d9840a9c718a9eb6ee66b5bf94960b5913cc Mon Sep 17 00:00:00 2001 From: effectfully Date: Sat, 11 May 2024 23:36:40 +0200 Subject: [PATCH 24/41] Make it work for GHC-8.10 --- plutus-tx/src/PlutusTx/Lift/TestInstances.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/plutus-tx/src/PlutusTx/Lift/TestInstances.hs b/plutus-tx/src/PlutusTx/Lift/TestInstances.hs index 8427b3dc3ff..7e7256a8b8b 100644 --- a/plutus-tx/src/PlutusTx/Lift/TestInstances.hs +++ b/plutus-tx/src/PlutusTx/Lift/TestInstances.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} @@ -17,13 +17,17 @@ import PlutusTx.Lift.Class import Data.Kind qualified as GHC +type OnBuiltin :: (GHC.Type -> GHC.Constraint) -> GHC.Type -> GHC.Constraint +class constr (ToBuiltin a) => OnBuiltin constr a +instance constr (ToBuiltin a) => OnBuiltin constr a + type BuiltinSatisfies :: (GHC.Type -> GHC.Constraint) -> (GHC.Type -> GHC.Constraint) -> GHC.Type -> GHC.Constraint -class (pre (ToBuiltin a) => post (ToBuiltin a)) => BuiltinSatisfies pre post a -instance (pre (ToBuiltin a) => post (ToBuiltin a)) => BuiltinSatisfies pre post a +class (OnBuiltin pre a => OnBuiltin post a) => BuiltinSatisfies pre post a +instance (OnBuiltin pre a => OnBuiltin post a) => BuiltinSatisfies pre post a type AllBuiltinsSatisfy :: (GHC.Type -> GHC.Constraint) From 0ec5c85d11b04e372f7baf749fc78172488dcc40 Mon Sep 17 00:00:00 2001 From: effectfully Date: Mon, 13 May 2024 01:25:58 +0200 Subject: [PATCH 25/41] Polishing --- .../src/PlutusTx/Compiler/Builtins.hs | 2 +- .../src/PlutusTx/Compiler/Expr.hs | 2 +- plutus-tx/plutus-tx.cabal | 4 +- plutus-tx/src/PlutusTx/Builtins.hs | 4 +- plutus-tx/src/PlutusTx/Builtins/Class.hs | 171 ++++++++++++++++++ .../Builtins/{IsBuiltin.hs => HasBuiltin.hs} | 2 +- .../Builtins/{IsOpaque.hs => HasOpaque.hs} | 2 +- plutus-tx/src/PlutusTx/Lift/Class.hs | 2 +- plutus-tx/src/PlutusTx/Lift/TestInstances.hs | 21 ++- 9 files changed, 196 insertions(+), 14 deletions(-) create mode 100644 plutus-tx/src/PlutusTx/Builtins/Class.hs rename plutus-tx/src/PlutusTx/Builtins/{IsBuiltin.hs => HasBuiltin.hs} (99%) rename plutus-tx/src/PlutusTx/Builtins/{IsOpaque.hs => HasOpaque.hs} (99%) diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs index 8a8a01db9c8..b0d8e6b15aa 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs @@ -18,8 +18,8 @@ module PlutusTx.Compiler.Builtins ( , lookupBuiltinType , errorFunc) where +import PlutusTx.Builtins.HasOpaque qualified as Builtins import PlutusTx.Builtins.Internal qualified as Builtins -import PlutusTx.Builtins.IsOpaque qualified as Builtins import PlutusTx.Compiler.Error import PlutusTx.Compiler.Names diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs index 3f2aecdcab3..f8f4b8459ea 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs @@ -49,7 +49,7 @@ import PlutusTx.PIRTypes import PlutusTx.PLCTypes (PLCType, PLCVar) -- I feel like we shouldn't need this, we only need it to spot the special String type, which is annoying -import PlutusTx.Builtins.IsOpaque qualified as Builtins +import PlutusTx.Builtins.HasOpaque qualified as Builtins import PlutusTx.Trace import PlutusIR qualified as PIR diff --git a/plutus-tx/plutus-tx.cabal b/plutus-tx/plutus-tx.cabal index c050c8ddadd..273f8076183 100644 --- a/plutus-tx/plutus-tx.cabal +++ b/plutus-tx/plutus-tx.cabal @@ -70,9 +70,9 @@ library PlutusTx.Blueprint.Write PlutusTx.Bool PlutusTx.Builtins + PlutusTx.Builtins.HasBuiltin + PlutusTx.Builtins.HasOpaque PlutusTx.Builtins.Internal - PlutusTx.Builtins.IsBuiltin - PlutusTx.Builtins.IsOpaque PlutusTx.Code PlutusTx.Coverage PlutusTx.Either diff --git a/plutus-tx/src/PlutusTx/Builtins.hs b/plutus-tx/src/PlutusTx/Builtins.hs index 7f9474ab617..ab240871164 100644 --- a/plutus-tx/src/PlutusTx/Builtins.hs +++ b/plutus-tx/src/PlutusTx/Builtins.hs @@ -113,12 +113,12 @@ module PlutusTx.Builtins ( import Data.Maybe import PlutusTx.Base (const, uncurry) import PlutusTx.Bool (Bool (..)) +import PlutusTx.Builtins.HasBuiltin +import PlutusTx.Builtins.HasOpaque import PlutusTx.Builtins.Internal (BuiltinBLS12_381_G1_Element (..), BuiltinBLS12_381_G2_Element (..), BuiltinBLS12_381_MlResult (..), BuiltinByteString (..), BuiltinData, BuiltinString) import PlutusTx.Builtins.Internal qualified as BI -import PlutusTx.Builtins.IsBuiltin -import PlutusTx.Builtins.IsOpaque import PlutusTx.Integer (Integer) import GHC.ByteOrder (ByteOrder (BigEndian, LittleEndian)) diff --git a/plutus-tx/src/PlutusTx/Builtins/Class.hs b/plutus-tx/src/PlutusTx/Builtins/Class.hs new file mode 100644 index 00000000000..59d9cd2a4d9 --- /dev/null +++ b/plutus-tx/src/PlutusTx/Builtins/Class.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +-- editorconfig-checker-disable-file +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -fno-specialise #-} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} + +module PlutusTx.Builtins.Class (module Export) where + +import PlutusTx.Builtins.HasBuiltin as Export + +import Prelude qualified as Haskell (String) + +import Data.ByteString (ByteString) +import PlutusTx.Builtins.Internal + +import Data.String (IsString (..)) +import Data.Text (Text, pack) +import GHC.Magic qualified as Magic + +import PlutusCore.Crypto.BLS12_381.G1 qualified as BLS12_381.G1 (Element) +import PlutusCore.Crypto.BLS12_381.G2 qualified as BLS12_381.G2 (Element) +import PlutusCore.Crypto.BLS12_381.Pairing qualified as BLS12_381.Pairing (MlResult) +import PlutusCore.Default qualified as PLC +import PlutusTx.Base (const, id, ($)) +import PlutusTx.Bool (Bool (..)) +import PlutusTx.Integer (Integer) + +-- -- See Note [Builtin types and their Haskell versions] +-- {-| +-- A class witnessing the ability to convert from the builtin representation to the Haskell representation. +-- -} +-- class FromBuiltin arep a | arep -> a where +-- fromBuiltin :: arep -> a + +-- -- See Note [Builtin types and their Haskell versions] +-- {-| +-- A class witnessing the ability to convert from the Haskell representation to the builtin representation. +-- -} +-- class ToBuiltin a arep | a -> arep where +-- toBuiltin :: a -> arep + +-- instance FromBuiltin BuiltinInteger Integer where +-- {-# INLINABLE fromBuiltin #-} +-- fromBuiltin = id +-- instance ToBuiltin Integer BuiltinInteger where +-- {-# INLINABLE toBuiltin #-} +-- toBuiltin = id + +-- instance FromBuiltin BuiltinBool Bool where +-- {-# INLINABLE fromBuiltin #-} +-- fromBuiltin b = ifThenElse b True False +-- instance ToBuiltin Bool BuiltinBool where +-- {-# INLINABLE toBuiltin #-} +-- toBuiltin b = if b then true else false + +-- instance FromBuiltin BuiltinUnit () where +-- -- See Note [Strict conversions to/from unit] +-- {-# INLINABLE fromBuiltin #-} +-- fromBuiltin u = chooseUnit u () +-- instance ToBuiltin () BuiltinUnit where +-- -- See Note [Strict conversions to/from unit] +-- {-# INLINABLE toBuiltin #-} +-- toBuiltin x = case x of () -> unitval + +-- instance FromBuiltin BuiltinByteString ByteString where +-- {-# INLINABLE fromBuiltin #-} +-- fromBuiltin (BuiltinByteString b) = b +-- instance ToBuiltin ByteString BuiltinByteString where +-- {-# INLINABLE toBuiltin #-} +-- toBuiltin = BuiltinByteString + +-- -- We can't put this in `Builtins.hs`, since that force `O0` deliberately, which prevents +-- -- the unfoldings from going in. So we just stick it here. Fiddly. +-- instance IsString BuiltinString where +-- -- Try and make sure the dictionary selector goes away, it's simpler to match on +-- -- the application of 'stringToBuiltinString' +-- {-# INLINE fromString #-} +-- -- See Note [noinline hack] +-- fromString = Magic.noinline stringToBuiltinString + +-- {-# INLINABLE stringToBuiltinString #-} +-- stringToBuiltinString :: Haskell.String -> BuiltinString +-- -- To explain why the obfuscatedId is here +-- -- See Note [noinline hack] +-- stringToBuiltinString str = obfuscatedId (BuiltinString $ pack str) + +-- {-# NOINLINE obfuscatedId #-} +-- obfuscatedId :: a -> a +-- obfuscatedId a = a + +-- instance FromBuiltin BuiltinString Text where +-- {-# INLINABLE fromBuiltin #-} +-- fromBuiltin (BuiltinString t) = t +-- instance ToBuiltin Text BuiltinString where +-- {-# INLINABLE toBuiltin #-} +-- toBuiltin = BuiltinString + +-- {- Same noinline hack as with `String` type. -} +-- instance IsString BuiltinByteString where +-- -- Try and make sure the dictionary selector goes away, it's simpler to match on +-- -- the application of 'stringToBuiltinByteString' +-- {-# INLINE fromString #-} +-- -- See Note [noinline hack] +-- fromString = Magic.noinline stringToBuiltinByteString + +-- {-# INLINABLE stringToBuiltinByteString #-} +-- stringToBuiltinByteString :: Haskell.String -> BuiltinByteString +-- stringToBuiltinByteString str = encodeUtf8 $ stringToBuiltinString str + +-- instance (FromBuiltin arep a, FromBuiltin brep b) => FromBuiltin (BuiltinPair arep brep) (a,b) where +-- {-# INLINABLE fromBuiltin #-} +-- fromBuiltin p = (fromBuiltin $ fst p, fromBuiltin $ snd p) +-- instance ToBuiltin (BuiltinData, BuiltinData) (BuiltinPair BuiltinData BuiltinData) where +-- {-# INLINABLE toBuiltin #-} +-- toBuiltin (d1, d2) = mkPairData d1 d2 + +-- instance FromBuiltin arep a => FromBuiltin (BuiltinList arep) [a] where +-- {-# INLINABLE fromBuiltin #-} +-- fromBuiltin = go +-- where +-- -- The combination of both INLINABLE and a type signature seems to stop this getting lifted to the top +-- -- level, which means it gets a proper unfolding, which means that specialization can work, which can +-- -- actually help quite a bit here. +-- {-# INLINABLE go #-} +-- go :: BuiltinList arep -> [a] +-- -- Note that we are using builtin chooseList here so this is *strict* application! So we need to do +-- -- the manual laziness ourselves. +-- go l = chooseList l (const []) (\_ -> fromBuiltin (head l):go (tail l)) unitval + +-- instance (PLC.DefaultUni `PLC.Contains` a, ToBuiltin a arep) => +-- ToBuiltin [a] (BuiltinList arep) where +-- {-# INLINE toBuiltin #-} +-- toBuiltin = goList where +-- goList :: [a] -> BuiltinList arep +-- goList [] = mkNil @a PLC.knownUni +-- goList (d:ds) = mkCons (toBuiltin d) (goList ds) + +-- instance FromBuiltin BuiltinData BuiltinData where +-- {-# INLINABLE fromBuiltin #-} +-- fromBuiltin = id +-- instance ToBuiltin BuiltinData BuiltinData where +-- {-# INLINABLE toBuiltin #-} +-- toBuiltin = id + +-- instance FromBuiltin BuiltinBLS12_381_G1_Element BLS12_381.G1.Element where +-- {-# INLINABLE fromBuiltin #-} +-- fromBuiltin (BuiltinBLS12_381_G1_Element a) = a +-- instance ToBuiltin BLS12_381.G1.Element BuiltinBLS12_381_G1_Element where +-- {-# INLINABLE toBuiltin #-} +-- toBuiltin = BuiltinBLS12_381_G1_Element + +-- instance FromBuiltin BuiltinBLS12_381_G2_Element BLS12_381.G2.Element where +-- {-# INLINABLE fromBuiltin #-} +-- fromBuiltin (BuiltinBLS12_381_G2_Element a) = a +-- instance ToBuiltin BLS12_381.G2.Element BuiltinBLS12_381_G2_Element where +-- {-# INLINABLE toBuiltin #-} +-- toBuiltin = BuiltinBLS12_381_G2_Element + +-- instance FromBuiltin BuiltinBLS12_381_MlResult BLS12_381.Pairing.MlResult where +-- {-# INLINABLE fromBuiltin #-} +-- fromBuiltin (BuiltinBLS12_381_MlResult a) = a +-- instance ToBuiltin BLS12_381.Pairing.MlResult BuiltinBLS12_381_MlResult where +-- {-# INLINABLE toBuiltin #-} +-- toBuiltin = BuiltinBLS12_381_MlResult diff --git a/plutus-tx/src/PlutusTx/Builtins/IsBuiltin.hs b/plutus-tx/src/PlutusTx/Builtins/HasBuiltin.hs similarity index 99% rename from plutus-tx/src/PlutusTx/Builtins/IsBuiltin.hs rename to plutus-tx/src/PlutusTx/Builtins/HasBuiltin.hs index 963f0fec4fd..f420c8cce41 100644 --- a/plutus-tx/src/PlutusTx/Builtins/IsBuiltin.hs +++ b/plutus-tx/src/PlutusTx/Builtins/HasBuiltin.hs @@ -4,7 +4,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -module PlutusTx.Builtins.IsBuiltin where +module PlutusTx.Builtins.HasBuiltin where import Prelude diff --git a/plutus-tx/src/PlutusTx/Builtins/IsOpaque.hs b/plutus-tx/src/PlutusTx/Builtins/HasOpaque.hs similarity index 99% rename from plutus-tx/src/PlutusTx/Builtins/IsOpaque.hs rename to plutus-tx/src/PlutusTx/Builtins/HasOpaque.hs index 9ed8928db36..ac753fbedc4 100644 --- a/plutus-tx/src/PlutusTx/Builtins/IsOpaque.hs +++ b/plutus-tx/src/PlutusTx/Builtins/HasOpaque.hs @@ -11,7 +11,7 @@ {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} {-# OPTIONS_GHC -Wno-orphans #-} -module PlutusTx.Builtins.IsOpaque where +module PlutusTx.Builtins.HasOpaque where import PlutusTx.Base (id, ($)) import PlutusTx.Bool (Bool (..)) diff --git a/plutus-tx/src/PlutusTx/Lift/Class.hs b/plutus-tx/src/PlutusTx/Lift/Class.hs index 28a89918e6f..7d72e662e5f 100644 --- a/plutus-tx/src/PlutusTx/Lift/Class.hs +++ b/plutus-tx/src/PlutusTx/Lift/Class.hs @@ -30,9 +30,9 @@ import PlutusCore.Data import PlutusCore.Quote import PlutusIR.MkPir import PlutusTx.Builtins +import PlutusTx.Builtins.HasBuiltin (FromBuiltin, HasFromBuiltin) import PlutusTx.Builtins.Internal (BuiltinBool, BuiltinInteger, BuiltinList, BuiltinPair, BuiltinUnit) -import PlutusTx.Builtins.IsBuiltin (FromBuiltin, HasFromBuiltin) import Language.Haskell.TH qualified as TH hiding (newName) diff --git a/plutus-tx/src/PlutusTx/Lift/TestInstances.hs b/plutus-tx/src/PlutusTx/Lift/TestInstances.hs index 7e7256a8b8b..26fbe6c274d 100644 --- a/plutus-tx/src/PlutusTx/Lift/TestInstances.hs +++ b/plutus-tx/src/PlutusTx/Lift/TestInstances.hs @@ -12,15 +12,18 @@ module PlutusTx.Lift.TestInstances () where import PlutusCore qualified as PLC import PlutusCore.Builtin qualified as PLC -import PlutusTx.Builtins.IsBuiltin +import PlutusTx.Builtins.HasBuiltin import PlutusTx.Lift.Class import Data.Kind qualified as GHC +-- | @OnBuiltin constr a@ is the same as @constr (ToBuiltin a)@ except the latter does not work in a +-- quantified context with GHC-8.10, hence we define this class synonym. type OnBuiltin :: (GHC.Type -> GHC.Constraint) -> GHC.Type -> GHC.Constraint class constr (ToBuiltin a) => OnBuiltin constr a instance constr (ToBuiltin a) => OnBuiltin constr a +-- | @BuiltinSatisfies pre post a@ holds if @pre (ToBuiltin a)@ implies @post (ToBuiltin a)@. type BuiltinSatisfies :: (GHC.Type -> GHC.Constraint) -> (GHC.Type -> GHC.Constraint) @@ -29,15 +32,23 @@ type BuiltinSatisfies class (OnBuiltin pre a => OnBuiltin post a) => BuiltinSatisfies pre post a instance (OnBuiltin pre a => OnBuiltin post a) => BuiltinSatisfies pre post a -type AllBuiltinsSatisfy +-- | Test that each built-in type @a@ from 'PLC.DefaultUni' satisfies @post (ToBuiltin a)@ given +-- @pre (ToBuiltin a)@. +type TestAllBuiltinsSatisfy :: (GHC.Type -> GHC.Constraint) -> (GHC.Type -> GHC.Constraint) -> GHC.Constraint -class PLC.DefaultUni `PLC.Everywhere` BuiltinSatisfies pre post => AllBuiltinsSatisfy pre post +class PLC.DefaultUni `PLC.Everywhere` BuiltinSatisfies pre post => TestAllBuiltinsSatisfy pre post -instance AllBuiltinsSatisfy +-- | Test that each built-in type from 'PLC.DefaultUni' has a 'Typeable' instance. +instance TestAllBuiltinsSatisfy (PLC.AllBuiltinArgs PLC.DefaultUni (Typeable PLC.DefaultUni)) (Typeable PLC.DefaultUni) -instance AllBuiltinsSatisfy + +-- | Test that each built-in type from 'PLC.DefaultUni' has a 'Lift' instance. Since the 'Lift' +-- instances are defined in terms of 'fromBuiltin', this also tests that each built-in type has a +-- 'FromBuiltin' instance. Which in turn requires a 'ToBuiltin' instance to exist due to the +-- superclass constraint, so this is implicitly tested as well. +instance TestAllBuiltinsSatisfy (PLC.AllBuiltinArgs PLC.DefaultUni HasFromBuiltin) (Lift PLC.DefaultUni) From 173ee907e1fd0558fd89aa9804a91a72a99fd723 Mon Sep 17 00:00:00 2001 From: effectfully Date: Mon, 13 May 2024 04:48:34 +0200 Subject: [PATCH 26/41] Improve docs --- ...d_ToBuiltin_into_IsBuiltin_and_IsOpaque.md | 5 + plutus-tx/src/PlutusTx/Builtins/Class.hs | 171 ------------- plutus-tx/src/PlutusTx/Builtins/HasBuiltin.hs | 25 +- plutus-tx/src/PlutusTx/Builtins/HasOpaque.hs | 236 ++++++++++-------- plutus-tx/src/PlutusTx/Lift/Class.hs | 2 +- 5 files changed, 147 insertions(+), 292 deletions(-) create mode 100644 plutus-tx/changelog.d/20240513_014001_effectfully_split_FromBuiltin_and_ToBuiltin_into_IsBuiltin_and_IsOpaque.md delete mode 100644 plutus-tx/src/PlutusTx/Builtins/Class.hs diff --git a/plutus-tx/changelog.d/20240513_014001_effectfully_split_FromBuiltin_and_ToBuiltin_into_IsBuiltin_and_IsOpaque.md b/plutus-tx/changelog.d/20240513_014001_effectfully_split_FromBuiltin_and_ToBuiltin_into_IsBuiltin_and_IsOpaque.md new file mode 100644 index 00000000000..053aa96f62a --- /dev/null +++ b/plutus-tx/changelog.d/20240513_014001_effectfully_split_FromBuiltin_and_ToBuiltin_into_IsBuiltin_and_IsOpaque.md @@ -0,0 +1,5 @@ +### Changed + +- Split `PlutusTx.Builtins.Class` into `PlutusTx.Builtins.HasBuiltin` and `PlutusTx.Builtins.HasOpaque` in #5971: ++ Split 'FromBuiltin' into 'HasFromBuiltin' and 'HasFromOpaque' ++ Split 'ToBuiltin' into 'HasToBuiltin' and 'HasToOpaque' diff --git a/plutus-tx/src/PlutusTx/Builtins/Class.hs b/plutus-tx/src/PlutusTx/Builtins/Class.hs deleted file mode 100644 index 59d9cd2a4d9..00000000000 --- a/plutus-tx/src/PlutusTx/Builtins/Class.hs +++ /dev/null @@ -1,171 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} --- editorconfig-checker-disable-file -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -fno-specialise #-} -{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} - -module PlutusTx.Builtins.Class (module Export) where - -import PlutusTx.Builtins.HasBuiltin as Export - -import Prelude qualified as Haskell (String) - -import Data.ByteString (ByteString) -import PlutusTx.Builtins.Internal - -import Data.String (IsString (..)) -import Data.Text (Text, pack) -import GHC.Magic qualified as Magic - -import PlutusCore.Crypto.BLS12_381.G1 qualified as BLS12_381.G1 (Element) -import PlutusCore.Crypto.BLS12_381.G2 qualified as BLS12_381.G2 (Element) -import PlutusCore.Crypto.BLS12_381.Pairing qualified as BLS12_381.Pairing (MlResult) -import PlutusCore.Default qualified as PLC -import PlutusTx.Base (const, id, ($)) -import PlutusTx.Bool (Bool (..)) -import PlutusTx.Integer (Integer) - --- -- See Note [Builtin types and their Haskell versions] --- {-| --- A class witnessing the ability to convert from the builtin representation to the Haskell representation. --- -} --- class FromBuiltin arep a | arep -> a where --- fromBuiltin :: arep -> a - --- -- See Note [Builtin types and their Haskell versions] --- {-| --- A class witnessing the ability to convert from the Haskell representation to the builtin representation. --- -} --- class ToBuiltin a arep | a -> arep where --- toBuiltin :: a -> arep - --- instance FromBuiltin BuiltinInteger Integer where --- {-# INLINABLE fromBuiltin #-} --- fromBuiltin = id --- instance ToBuiltin Integer BuiltinInteger where --- {-# INLINABLE toBuiltin #-} --- toBuiltin = id - --- instance FromBuiltin BuiltinBool Bool where --- {-# INLINABLE fromBuiltin #-} --- fromBuiltin b = ifThenElse b True False --- instance ToBuiltin Bool BuiltinBool where --- {-# INLINABLE toBuiltin #-} --- toBuiltin b = if b then true else false - --- instance FromBuiltin BuiltinUnit () where --- -- See Note [Strict conversions to/from unit] --- {-# INLINABLE fromBuiltin #-} --- fromBuiltin u = chooseUnit u () --- instance ToBuiltin () BuiltinUnit where --- -- See Note [Strict conversions to/from unit] --- {-# INLINABLE toBuiltin #-} --- toBuiltin x = case x of () -> unitval - --- instance FromBuiltin BuiltinByteString ByteString where --- {-# INLINABLE fromBuiltin #-} --- fromBuiltin (BuiltinByteString b) = b --- instance ToBuiltin ByteString BuiltinByteString where --- {-# INLINABLE toBuiltin #-} --- toBuiltin = BuiltinByteString - --- -- We can't put this in `Builtins.hs`, since that force `O0` deliberately, which prevents --- -- the unfoldings from going in. So we just stick it here. Fiddly. --- instance IsString BuiltinString where --- -- Try and make sure the dictionary selector goes away, it's simpler to match on --- -- the application of 'stringToBuiltinString' --- {-# INLINE fromString #-} --- -- See Note [noinline hack] --- fromString = Magic.noinline stringToBuiltinString - --- {-# INLINABLE stringToBuiltinString #-} --- stringToBuiltinString :: Haskell.String -> BuiltinString --- -- To explain why the obfuscatedId is here --- -- See Note [noinline hack] --- stringToBuiltinString str = obfuscatedId (BuiltinString $ pack str) - --- {-# NOINLINE obfuscatedId #-} --- obfuscatedId :: a -> a --- obfuscatedId a = a - --- instance FromBuiltin BuiltinString Text where --- {-# INLINABLE fromBuiltin #-} --- fromBuiltin (BuiltinString t) = t --- instance ToBuiltin Text BuiltinString where --- {-# INLINABLE toBuiltin #-} --- toBuiltin = BuiltinString - --- {- Same noinline hack as with `String` type. -} --- instance IsString BuiltinByteString where --- -- Try and make sure the dictionary selector goes away, it's simpler to match on --- -- the application of 'stringToBuiltinByteString' --- {-# INLINE fromString #-} --- -- See Note [noinline hack] --- fromString = Magic.noinline stringToBuiltinByteString - --- {-# INLINABLE stringToBuiltinByteString #-} --- stringToBuiltinByteString :: Haskell.String -> BuiltinByteString --- stringToBuiltinByteString str = encodeUtf8 $ stringToBuiltinString str - --- instance (FromBuiltin arep a, FromBuiltin brep b) => FromBuiltin (BuiltinPair arep brep) (a,b) where --- {-# INLINABLE fromBuiltin #-} --- fromBuiltin p = (fromBuiltin $ fst p, fromBuiltin $ snd p) --- instance ToBuiltin (BuiltinData, BuiltinData) (BuiltinPair BuiltinData BuiltinData) where --- {-# INLINABLE toBuiltin #-} --- toBuiltin (d1, d2) = mkPairData d1 d2 - --- instance FromBuiltin arep a => FromBuiltin (BuiltinList arep) [a] where --- {-# INLINABLE fromBuiltin #-} --- fromBuiltin = go --- where --- -- The combination of both INLINABLE and a type signature seems to stop this getting lifted to the top --- -- level, which means it gets a proper unfolding, which means that specialization can work, which can --- -- actually help quite a bit here. --- {-# INLINABLE go #-} --- go :: BuiltinList arep -> [a] --- -- Note that we are using builtin chooseList here so this is *strict* application! So we need to do --- -- the manual laziness ourselves. --- go l = chooseList l (const []) (\_ -> fromBuiltin (head l):go (tail l)) unitval - --- instance (PLC.DefaultUni `PLC.Contains` a, ToBuiltin a arep) => --- ToBuiltin [a] (BuiltinList arep) where --- {-# INLINE toBuiltin #-} --- toBuiltin = goList where --- goList :: [a] -> BuiltinList arep --- goList [] = mkNil @a PLC.knownUni --- goList (d:ds) = mkCons (toBuiltin d) (goList ds) - --- instance FromBuiltin BuiltinData BuiltinData where --- {-# INLINABLE fromBuiltin #-} --- fromBuiltin = id --- instance ToBuiltin BuiltinData BuiltinData where --- {-# INLINABLE toBuiltin #-} --- toBuiltin = id - --- instance FromBuiltin BuiltinBLS12_381_G1_Element BLS12_381.G1.Element where --- {-# INLINABLE fromBuiltin #-} --- fromBuiltin (BuiltinBLS12_381_G1_Element a) = a --- instance ToBuiltin BLS12_381.G1.Element BuiltinBLS12_381_G1_Element where --- {-# INLINABLE toBuiltin #-} --- toBuiltin = BuiltinBLS12_381_G1_Element - --- instance FromBuiltin BuiltinBLS12_381_G2_Element BLS12_381.G2.Element where --- {-# INLINABLE fromBuiltin #-} --- fromBuiltin (BuiltinBLS12_381_G2_Element a) = a --- instance ToBuiltin BLS12_381.G2.Element BuiltinBLS12_381_G2_Element where --- {-# INLINABLE toBuiltin #-} --- toBuiltin = BuiltinBLS12_381_G2_Element - --- instance FromBuiltin BuiltinBLS12_381_MlResult BLS12_381.Pairing.MlResult where --- {-# INLINABLE fromBuiltin #-} --- fromBuiltin (BuiltinBLS12_381_MlResult a) = a --- instance ToBuiltin BLS12_381.Pairing.MlResult BuiltinBLS12_381_MlResult where --- {-# INLINABLE toBuiltin #-} --- toBuiltin = BuiltinBLS12_381_MlResult diff --git a/plutus-tx/src/PlutusTx/Builtins/HasBuiltin.hs b/plutus-tx/src/PlutusTx/Builtins/HasBuiltin.hs index f420c8cce41..0c9e4169385 100644 --- a/plutus-tx/src/PlutusTx/Builtins/HasBuiltin.hs +++ b/plutus-tx/src/PlutusTx/Builtins/HasBuiltin.hs @@ -19,11 +19,15 @@ import Data.ByteString (ByteString) import Data.Kind qualified as GHC import Data.Text (Text) +-- | A class for converting values of Haskell-defined built-in types to their Plutus Tx +-- counterparts. type HasToBuiltin :: GHC.Type -> GHC.Constraint class PLC.DefaultUni `PLC.Contains` a => HasToBuiltin a where type ToBuiltin a toBuiltin :: a -> ToBuiltin a +-- | A class for converting values of Plutus Tx built-in types to their Haskell-defined +-- counterparts. type HasFromBuiltin :: GHC.Type -> GHC.Constraint class HasToBuiltin (FromBuiltin arep) => HasFromBuiltin arep where type FromBuiltin arep @@ -105,24 +109,3 @@ instance HasToBuiltin BLS12_381.Pairing.MlResult where instance HasFromBuiltin BuiltinBLS12_381_MlResult where type FromBuiltin BuiltinBLS12_381_MlResult = BLS12_381.Pairing.MlResult fromBuiltin (BuiltinBLS12_381_MlResult a) = a - -{- Note [noinline hack] -For some functions we have two conflicting desires: -- We want to have the unfolding available for the plugin. -- We don't want the function to *actually* get inlined before the plugin runs, since we rely -on being able to see the original function for some reason. - -'INLINABLE' achieves the first, but may cause the function to be inlined too soon. - -We can solve this at specific call sites by using the 'noinline' magic function from -GHC. This stops GHC from inlining it. As a bonus, it also won't be inlined if -that function is compiled later into the body of another function. - -We do therefore need to handle 'noinline' in the plugin, as it itself does not have -an unfolding. - -Another annoying quirk: even if you have 'noinline'd a function call, if the body is -a single variable, it will still inline! This is the case for the obvious definition -of 'stringToBuiltinString' (since the newtype constructor vanishes), so we have to add -some obfuscation to the body to prevent it inlining. --} diff --git a/plutus-tx/src/PlutusTx/Builtins/HasOpaque.hs b/plutus-tx/src/PlutusTx/Builtins/HasOpaque.hs index ac753fbedc4..4cfb70352a2 100644 --- a/plutus-tx/src/PlutusTx/Builtins/HasOpaque.hs +++ b/plutus-tx/src/PlutusTx/Builtins/HasOpaque.hs @@ -23,6 +23,27 @@ import Data.Text qualified as Text import GHC.Magic qualified as Magic import Prelude qualified as Haskell (String) +{- Note [noinline hack] +For some functions we have two conflicting desires: +- We want to have the unfolding available for the plugin. +- We don't want the function to *actually* get inlined before the plugin runs, since we rely +on being able to see the original function for some reason. + +'INLINABLE' achieves the first, but may cause the function to be inlined too soon. + +We can solve this at specific call sites by using the 'noinline' magic function from +GHC. This stops GHC from inlining it. As a bonus, it also won't be inlined if +that function is compiled later into the body of another function. + +We do therefore need to handle 'noinline' in the plugin, as it itself does not have +an unfolding. + +Another annoying quirk: even if you have 'noinline'd a function call, if the body is +a single variable, it will still inline! This is the case for the obvious definition +of 'stringToBuiltinString' (since the newtype constructor vanishes), so we have to add +some obfuscation to the body to prevent it inlining. +-} + obfuscatedId :: a -> a obfuscatedId a = a {-# NOINLINE obfuscatedId #-} @@ -54,13 +75,70 @@ instance IsString BuiltinString where fromString = Magic.noinline stringToBuiltinString {-# INLINE fromString #-} -type HasFromOpaque :: GHC.Type -> GHC.Type -> GHC.Constraint -class HasFromOpaque arep a | arep -> a where - fromOpaque :: arep -> a - default fromOpaque :: a ~ arep => arep -> a - fromOpaque = id - {-# INLINABLE fromOpaque #-} +{- Note [Built-in types and their Haskell versions] +'HasToBuiltin' allows us to convert a value of a built-in type such as 'ByteString' to its Plutus +Tx counterpart, 'BuiltinByteString' in this case. The idea is the same for all built-in types: just +take the Haskell version and make it the Plutus Tx one. + +'HasToOpaque' is different, we use it for converting values of only those built-in types that exist +in the Plutus Tx realm. I.e. we cannot convert a 'ByteString', since 'ByteString's don't exist in +Plutus Tx, only 'BuiltinByteString's do. + +But consider, say, the built-in pair type. In Plutus Tx, we have an (opaque) type for this. It's +opaque because you can't actually pattern match on it, instead you can only in fact use the specific +functions that are available as builtins. +We _also_ have the normal Haskell pair type. This is very different: you can +pattern match on it, and you can use whatever user-defined functions you like on it. + +Users would really like to use the latter, and not the former. So we often want +to _wrap_ our built-in functions with little adapters that convert between the +"opaque builtin" "version" of a type and the "normal Haskell" "version" of a type. + +This is what the 'HasToOpaque' and 'HasFromOpaque' classes do. They let us write wrappers for +builtins relatively consistently by just calling 'toBuiltin' on their arguments and 'fromOpaque' on +the result. They shouldn't really be used otherwise. + +Ideally, we would not have instances for types which don't have a different Haskell representation +type, such as 'Integer'. 'Integer' in Plutus Tx user code _is_ the opaque built-in type, we don't +expose a different one. So there's no conversion to do. However, this interacts badly with the +instances for polymorphic built-in types, which also convert the type _inside_ them. (This is +necessary to avoid doing multiple traversals of the type, e.g. we don't want to turn a built-in list +into a Haskell list, and then traverse it again to conver the contents). Then we _need_ instances +for all built-in types, so we provide a @default@ implementation for both 'toOpaque' and +'fromOpaque' that simply returns the argument back and use it for those types that don't require any +conversions. +-} + +{- Note [HasFromOpaque/HasToOpaque instances for polymorphic builtin types] +For various technical reasons +(see Note [Representable built-in functions over polymorphic built-in types]) +it's not always easy to provide polymorphic constructors for built-in types, but we can usually +provide destructors. + +What this means in practice is that we can write a generic 'HasFromOpaque' instance for pairs that +makes use of polymorphic @fst@/@snd@ builtins, but we can't write a polymorphic 'ToOpaque' instance +because we'd need a polymorphic version of the '(,)' constructor. + +Instead we write monomorphic instances corresponding to monomorphic constructor builtins that we add +for specific purposes. +-} + +{- Note [Fundeps versus type families in HasFromOpaque/HasToOpaque] +We could use a type family here to get the builtin representation of a type. After all, it's +entirely determined by the Haskell type. + +However, this is harder for the plugin to deal with. It's okay to have a type variable for the +representation type that needs to be instantiated later, but it's *not* okay to have an irreducible +type application on a type variable. So fundeps are much nicer here. +-} + +-- See Note [Built-in types and their Haskell versions]. +-- See Note [HasFromOpaque/HasToOpaque instances for polymorphic builtin types]. +-- See Note [Fundeps versus type families in HasFromOpaque/HasToOpaque]. +-- | A class for converting values of transparent Haskell-defined built-in types (such as '()', +-- 'Bool', '[]' etc) to their opaque Plutus Tx counterparts. Instances for built-in types that are +-- not transparent are provided as well, simply as identities, since those types are already opaque. type HasToOpaque :: GHC.Type -> GHC.Type -> GHC.Constraint class HasToOpaque a arep | a -> arep where toOpaque :: a -> arep @@ -68,41 +146,54 @@ class HasToOpaque a arep | a -> arep where toOpaque = id {-# INLINABLE toOpaque #-} -instance HasFromOpaque BuiltinInteger BuiltinInteger +-- See Note [Built-in types and their Haskell versions]. +-- See Note [HasFromOpaque/HasToOpaque instances for polymorphic builtin types]. +-- See Note [Fundeps versus type families in HasFromOpaque/HasToOpaque]. +-- | A class for converting values of transparent Haskell-defined built-in types (such as '()', +-- 'Bool', '[]' etc) to their opaque Plutus Tx counterparts. Instances for built-in types that are +-- not transparent are provided as well, simply as identities, since such types are already opaque. +type HasFromOpaque :: GHC.Type -> GHC.Type -> GHC.Constraint +class HasFromOpaque arep a | arep -> a where + fromOpaque :: arep -> a + default fromOpaque :: a ~ arep => arep -> a + fromOpaque = id + {-# INLINABLE fromOpaque #-} + instance HasToOpaque BuiltinInteger BuiltinInteger +instance HasFromOpaque BuiltinInteger BuiltinInteger -instance HasFromOpaque BuiltinByteString BuiltinByteString instance HasToOpaque BuiltinByteString BuiltinByteString +instance HasFromOpaque BuiltinByteString BuiltinByteString -instance HasFromOpaque BuiltinString BuiltinString instance HasToOpaque BuiltinString BuiltinString +instance HasFromOpaque BuiltinString BuiltinString -instance HasFromOpaque BuiltinUnit () where - fromOpaque u = chooseUnit u () - {-# INLINABLE fromOpaque #-} +{- Note [Strict conversions to/from unit] +Converting to/from unit *should* be straightforward: just `const ()`. +*But* GHC is very good at optimizing this, and we sometimes use unit +where side effects matter, e.g. as the result of `trace`. So GHC will +tend to turn `fromOpaque (trace s)` into `()`, which is wrong. + +So we want our conversions to/from unit to be strict in Haskell. This +means we need to case pointlessly on the argument, which means we need +case on unit (`chooseUnit`) as a builtin. But then it all works okay. +-} + +-- See Note [Strict conversions to/from unit]. instance HasToOpaque () BuiltinUnit where toOpaque x = case x of () -> unitval {-# INLINABLE toOpaque #-} - -instance HasFromOpaque BuiltinBool Bool where - fromOpaque b = ifThenElse b True False +instance HasFromOpaque BuiltinUnit () where + fromOpaque u = chooseUnit u () {-# INLINABLE fromOpaque #-} + instance HasToOpaque Bool BuiltinBool where toOpaque b = if b then true else false {-# INLINABLE toOpaque #-} - -instance HasFromOpaque arep a => HasFromOpaque (BuiltinList arep) [a] where - fromOpaque = go - where - -- The combination of both INLINABLE and a type signature seems to stop this getting - -- lifted to the top level, which means it gets a proper unfolding, which means that - -- specialization can work, which can actually help quite a bit here. - go :: BuiltinList arep -> [a] - -- Note that we are using builtin chooseList here so this is *strict* application! So we - -- need to do the manual laziness ourselves. - go l = chooseList l (\_ -> []) (\_ -> fromOpaque (head l) : go (tail l)) unitval - {-# INLINABLE go #-} +instance HasFromOpaque BuiltinBool Bool where + fromOpaque b = ifThenElse b True False {-# INLINABLE fromOpaque #-} + instance HasToOpaque [BuiltinData] (BuiltinList BuiltinData) where toOpaque = goList where goList :: [BuiltinData] -> BuiltinList BuiltinData @@ -118,88 +209,35 @@ instance goList [] = mkNilPairData unitval goList (d:ds) = mkCons (toOpaque d) (goList ds) {-# INLINE toOpaque #-} +instance HasFromOpaque arep a => HasFromOpaque (BuiltinList arep) [a] where + fromOpaque = go + where + -- The combination of both INLINABLE and a type signature seems to stop this getting + -- lifted to the top level, which means it gets a proper unfolding, which means that + -- specialization can work, which can actually help quite a bit here. + go :: BuiltinList arep -> [a] + -- Note that we are using builtin chooseList here so this is *strict* application! So we + -- need to do the manual laziness ourselves. + go l = chooseList l (\_ -> []) (\_ -> fromOpaque (head l) : go (tail l)) unitval + {-# INLINABLE go #-} + {-# INLINABLE fromOpaque #-} +instance HasToOpaque (BuiltinData, BuiltinData) (BuiltinPair BuiltinData BuiltinData) where + toOpaque (d1, d2) = mkPairData (toOpaque d1) (toOpaque d2) + {-# INLINABLE toOpaque #-} instance (HasFromOpaque arep a, HasFromOpaque brep b) => HasFromOpaque (BuiltinPair arep brep) (a, b) where fromOpaque p = (fromOpaque $ fst p, fromOpaque $ snd p) {-# INLINABLE fromOpaque #-} -instance HasToOpaque (BuiltinData, BuiltinData) (BuiltinPair BuiltinData BuiltinData) where - toOpaque (d1, d2) = mkPairData (toOpaque d1) (toOpaque d2) - {-# INLINABLE toOpaque #-} -instance HasFromOpaque BuiltinData BuiltinData instance HasToOpaque BuiltinData BuiltinData +instance HasFromOpaque BuiltinData BuiltinData -instance HasFromOpaque BuiltinBLS12_381_G1_Element BuiltinBLS12_381_G1_Element instance HasToOpaque BuiltinBLS12_381_G1_Element BuiltinBLS12_381_G1_Element +instance HasFromOpaque BuiltinBLS12_381_G1_Element BuiltinBLS12_381_G1_Element -instance HasFromOpaque BuiltinBLS12_381_G2_Element BuiltinBLS12_381_G2_Element instance HasToOpaque BuiltinBLS12_381_G2_Element BuiltinBLS12_381_G2_Element +instance HasFromOpaque BuiltinBLS12_381_G2_Element BuiltinBLS12_381_G2_Element -instance HasFromOpaque BuiltinBLS12_381_MlResult BuiltinBLS12_381_MlResult instance HasToOpaque BuiltinBLS12_381_MlResult BuiltinBLS12_381_MlResult - --- TODO: FIX THE NOTES - -{- Note [Builtin types and their Haskell versions] -Consider the builtin pair type. In Plutus Tx, we have an (opaque) type for -this. It's opaque because you can't actually pattern match on it, instead you can -only in fact use the specific functions that are available as builtins. - -We _also_ have the normal Haskell pair type. This is very different: you can -pattern match on it, and you can use whatever user-defined functions you like on it. - -Users would really like to use the latter, and not the former. So we often want -to _wrap_ our builtin functions with little adapters that convert between the -"opaque builtin" "version" of a type and the "normal Haskell" "version" of a type. - -This is what the ToBuiltin and FromBuiltin classes do. They let us write wrappers -for builtins relatively consistently by just calling toBuiltin on their arguments -and fromBuiltin on the result. They shouldn't really be used otherwise. - -Ideally, we would not have instances for types which don't have a different -Haskell representation type, such as Integer. Integer in Plutus Tx user code _is_ the -opaque builtin type, we don't expose a different one. So there's no conversion to -do. However, this interacts badly with the instances for polymorphic builtin types, which -also convert the type _inside_ them. (This is necessary to avoid doing multiple -traversals of the type, e.g. we don't want to turn a builtin list into a Haskell -list, and then traverse it again to conver the contents). Then we _need_ instances -for all builtin types, even if they don't quite make sense. - -Possibly this indicates that these type classes are a bit too 'ad-hoc' and we should -get rid of them. --} - -{- Note [From/ToBuiltin instances for polymorphic builtin types] -For various technical reasons -(see Note [Representable built-in functions over polymorphic built-in types]) -it's not always easy to provide polymorphic constructors for builtin types, but -we can usually provide destructors. - -What this means in practice is that we can write a generic FromBuiltin instance -for pairs that makes use of polymorphic fst/snd builtins, but we can't write -a polymorphic ToBuiltin instance because we'd need a polymorphic version of (,). - -Instead we write monomorphic instances corresponding to monomorphic constructor -builtins that we add for specific purposes. --} - -{- Note [Fundeps versus type families in To/FromBuiltin] -We could use a type family here to get the builtin representation of a type. After all, it's -entirely determined by the Haskell type. - -However, this is harder for the plugin to deal with. It's okay to have a type variable -for the representation type that needs to be instantiated later, but it's *not* okay to -have an irreducible type application on a type variable. So fundeps are much nicer here. --} - -{- Note [Strict conversions to/from unit] -Converting to/from unit *should* be straightforward: just `const ()`. -*But* GHC is very good at optimizing this, and we sometimes use unit -where side effects matter, e.g. as the result of `trace`. So GHC will -tend to turn `fromBuiltin (trace s)` into `()`, which is wrong. - -So we want our conversions to/from unit to be strict in Haskell. This -means we need to case pointlessly on the argument, which means we need -case on unit (`chooseUnit`) as a builtin. But then it all works okay. --} +instance HasFromOpaque BuiltinBLS12_381_MlResult BuiltinBLS12_381_MlResult diff --git a/plutus-tx/src/PlutusTx/Lift/Class.hs b/plutus-tx/src/PlutusTx/Lift/Class.hs index 7d72e662e5f..450e60540a4 100644 --- a/plutus-tx/src/PlutusTx/Lift/Class.hs +++ b/plutus-tx/src/PlutusTx/Lift/Class.hs @@ -235,7 +235,7 @@ trying to pattern match on them. So the types don't quite match up with what we to put inside the constant. Fortunately, we have To/FromBuiltin, which happen to do what we want. -See Note [Builtin types and their Haskell versions]. +See Note [Built-in types and their Haskell versions]. This is arguably slightly an abuse: the versions of the types that we want in Plutus Tx source code and the versions that we use as the implementations of the builtin types in the universe could be different. But in practice they From 6e329d685ea4bdabdc28429c2ad5343171367eda Mon Sep 17 00:00:00 2001 From: effectfully Date: Mon, 13 May 2024 05:29:24 +0200 Subject: [PATCH 27/41] Polishing --- .../PlutusIR/Transform/StrictLetRec/strictLetRec.uplc.golden | 1 - plutus-tx/src/PlutusTx/Builtins/HasOpaque.hs | 4 ++-- plutus-tx/src/PlutusTx/Lift/Class.hs | 2 +- 3 files changed, 3 insertions(+), 4 deletions(-) delete mode 100644 plutus-core/plutus-ir/test/PlutusIR/Transform/StrictLetRec/strictLetRec.uplc.golden diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/StrictLetRec/strictLetRec.uplc.golden b/plutus-core/plutus-ir/test/PlutusIR/Transform/StrictLetRec/strictLetRec.uplc.golden deleted file mode 100644 index 7d06755f761..00000000000 --- a/plutus-core/plutus-ir/test/PlutusIR/Transform/StrictLetRec/strictLetRec.uplc.golden +++ /dev/null @@ -1 +0,0 @@ -(\xxx -> 1) ((\s -> s s) (\s -> force trace "hello" (\z -> s s z))) \ No newline at end of file diff --git a/plutus-tx/src/PlutusTx/Builtins/HasOpaque.hs b/plutus-tx/src/PlutusTx/Builtins/HasOpaque.hs index 4cfb70352a2..1927ca98fe8 100644 --- a/plutus-tx/src/PlutusTx/Builtins/HasOpaque.hs +++ b/plutus-tx/src/PlutusTx/Builtins/HasOpaque.hs @@ -199,7 +199,7 @@ instance HasToOpaque [BuiltinData] (BuiltinList BuiltinData) where goList :: [BuiltinData] -> BuiltinList BuiltinData goList [] = mkNilData unitval goList (d:ds) = mkCons (toOpaque d) (goList ds) - {-# INLINE toOpaque #-} + {-# INLINABLE toOpaque #-} instance HasToOpaque [(BuiltinData, BuiltinData)] @@ -208,7 +208,7 @@ instance goList :: [(BuiltinData, BuiltinData)] -> BuiltinList (BuiltinPair BuiltinData BuiltinData) goList [] = mkNilPairData unitval goList (d:ds) = mkCons (toOpaque d) (goList ds) - {-# INLINE toOpaque #-} + {-# INLINABLE toOpaque #-} instance HasFromOpaque arep a => HasFromOpaque (BuiltinList arep) [a] where fromOpaque = go where diff --git a/plutus-tx/src/PlutusTx/Lift/Class.hs b/plutus-tx/src/PlutusTx/Lift/Class.hs index 450e60540a4..51acc514f6a 100644 --- a/plutus-tx/src/PlutusTx/Lift/Class.hs +++ b/plutus-tx/src/PlutusTx/Lift/Class.hs @@ -196,7 +196,7 @@ instance uni `PLC.HasTypeLevel` Data => Typeable uni BuiltinData where -- See Note [Lift and Typeable instances for builtins] instance uni `PLC.HasTermLevel` Data => Lift uni BuiltinData where - lift = liftBuiltin . builtinDataToData + lift = liftBuiltin . fromBuiltin -- See Note [Lift and Typeable instances for builtins] instance uni `PLC.HasTypeLevel` PlutusCore.Crypto.BLS12_381.G1.Element => From 29f0b1acdd9d64ed4c70b91653d3ac7e3f5cdfcb Mon Sep 17 00:00:00 2001 From: effectfully Date: Tue, 14 May 2024 03:44:04 +0200 Subject: [PATCH 28/41] Address comments --- plutus-tx/src/PlutusTx/Builtins/HasBuiltin.hs | 2 ++ plutus-tx/src/PlutusTx/Builtins/HasOpaque.hs | 6 +++--- plutus-tx/src/PlutusTx/Prelude.hs | 4 ++-- 3 files changed, 7 insertions(+), 5 deletions(-) diff --git a/plutus-tx/src/PlutusTx/Builtins/HasBuiltin.hs b/plutus-tx/src/PlutusTx/Builtins/HasBuiltin.hs index 0c9e4169385..8d353a8f0a6 100644 --- a/plutus-tx/src/PlutusTx/Builtins/HasBuiltin.hs +++ b/plutus-tx/src/PlutusTx/Builtins/HasBuiltin.hs @@ -19,6 +19,7 @@ import Data.ByteString (ByteString) import Data.Kind qualified as GHC import Data.Text (Text) +-- Also see Note [Built-in types and their Haskell versions]. -- | A class for converting values of Haskell-defined built-in types to their Plutus Tx -- counterparts. type HasToBuiltin :: GHC.Type -> GHC.Constraint @@ -26,6 +27,7 @@ class PLC.DefaultUni `PLC.Contains` a => HasToBuiltin a where type ToBuiltin a toBuiltin :: a -> ToBuiltin a +-- Also see Note [Built-in types and their Haskell versions]. -- | A class for converting values of Plutus Tx built-in types to their Haskell-defined -- counterparts. type HasFromBuiltin :: GHC.Type -> GHC.Constraint diff --git a/plutus-tx/src/PlutusTx/Builtins/HasOpaque.hs b/plutus-tx/src/PlutusTx/Builtins/HasOpaque.hs index 1927ca98fe8..26e60a50fd1 100644 --- a/plutus-tx/src/PlutusTx/Builtins/HasOpaque.hs +++ b/plutus-tx/src/PlutusTx/Builtins/HasOpaque.hs @@ -84,8 +84,8 @@ take the Haskell version and make it the Plutus Tx one. in the Plutus Tx realm. I.e. we cannot convert a 'ByteString', since 'ByteString's don't exist in Plutus Tx, only 'BuiltinByteString's do. -But consider, say, the built-in pair type. In Plutus Tx, we have an (opaque) type for this. It's -opaque because you can't actually pattern match on it, instead you can only in fact use the specific +Consider, say, the built-in pair type. In Plutus Tx, we have an (opaque) type for this. It's opaque +because you can't actually pattern match on it, instead you can only in fact use the specific functions that are available as builtins. We _also_ have the normal Haskell pair type. This is very different: you can @@ -96,7 +96,7 @@ to _wrap_ our built-in functions with little adapters that convert between the "opaque builtin" "version" of a type and the "normal Haskell" "version" of a type. This is what the 'HasToOpaque' and 'HasFromOpaque' classes do. They let us write wrappers for -builtins relatively consistently by just calling 'toBuiltin' on their arguments and 'fromOpaque' on +builtins relatively consistently by just calling 'toOpaque' on their arguments and 'fromOpaque' on the result. They shouldn't really be used otherwise. Ideally, we would not have instances for types which don't have a different Haskell representation diff --git a/plutus-tx/src/PlutusTx/Prelude.hs b/plutus-tx/src/PlutusTx/Prelude.hs index 7358089cc44..f8594b3bb39 100644 --- a/plutus-tx/src/PlutusTx/Prelude.hs +++ b/plutus-tx/src/PlutusTx/Prelude.hs @@ -229,12 +229,12 @@ odd n = if even n then False else True {-# INLINABLE takeByteString #-} -- | Returns the n length prefix of a 'ByteString'. takeByteString :: Integer -> BuiltinByteString -> BuiltinByteString -takeByteString n bs = Builtins.sliceByteString 0 (toBuiltin n) bs +takeByteString n bs = Builtins.sliceByteString 0 (toOpaque n) bs {-# INLINABLE dropByteString #-} -- | Returns the suffix of a 'ByteString' after n elements. dropByteString :: Integer -> BuiltinByteString -> BuiltinByteString -dropByteString n bs = Builtins.sliceByteString (toBuiltin n) (Builtins.lengthOfByteString bs - n) bs +dropByteString n bs = Builtins.sliceByteString (toOpaque n) (Builtins.lengthOfByteString bs - n) bs {- Note [-fno-full-laziness in Plutus Tx] GHC's full-laziness optimization moves computations inside a lambda that don't depend on From f98841e9b4a88e6d4dee05441b91b6f62537dc98 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Tue, 14 May 2024 15:40:23 +0300 Subject: [PATCH 29/41] Fix compilation errors in AssocMap Signed-off-by: Ana Pantilie --- plutus-tx/src/PlutusTx/Data/AssocMap.hs | 28 ++++++++++++------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/plutus-tx/src/PlutusTx/Data/AssocMap.hs b/plutus-tx/src/PlutusTx/Data/AssocMap.hs index 97d5124da5b..1fefffef9e8 100644 --- a/plutus-tx/src/PlutusTx/Data/AssocMap.hs +++ b/plutus-tx/src/PlutusTx/Data/AssocMap.hs @@ -83,7 +83,7 @@ lookup' k m = go m go xs = P.matchList xs - Nothing + (\() -> Nothing) ( \hd -> let k' = BI.fst hd in if P.equalsData k k' @@ -103,7 +103,7 @@ member' k m = go m go xs = P.matchList xs - False + (\() -> False) ( \hd -> let k' = BI.fst hd in if P.equalsData k k' @@ -130,7 +130,7 @@ insert' k a m = go m go xs = P.matchList xs - (BI.mkCons (BI.mkPairData k a) nil) + (\() -> BI.mkCons (BI.mkPairData k a) nil) ( \hd tl -> let k' = BI.fst hd in if P.equalsData k k' @@ -157,7 +157,7 @@ delete' k m = go m go xs = P.matchList xs - nil + (\() -> nil) ( \hd tl -> let k' = BI.fst hd in if P.equalsData k k' @@ -219,7 +219,7 @@ noDuplicateKeys (Map m) = go m go xs = P.matchList xs - True + (\() -> True) ( \hd tl -> let k = BI.fst hd in if member k (Map tl) then False else go tl @@ -234,7 +234,7 @@ all p (Map m) = go m go xs = P.matchList xs - True + (\() -> True) ( \hd -> let a = P.unsafeFromBuiltinData (BI.snd hd) in if p a then go else \_ -> False @@ -249,7 +249,7 @@ any p (Map m) = go m go xs = P.matchList xs - False + (\() -> False) ( \hd -> let a = P.unsafeFromBuiltinData (BI.snd hd) in if p a then \_ -> True else go @@ -269,7 +269,7 @@ union (Map ls) (Map rs) = Map res goLeft xs = P.matchList xs - nil + (\() -> nil) ( \hd tl -> let k = BI.fst hd v = BI.snd hd @@ -289,7 +289,7 @@ union (Map ls) (Map rs) = Map res goRight xs = P.matchList xs - nil + (\() -> nil) ( \hd tl -> let k = BI.fst hd v = BI.snd hd @@ -311,7 +311,7 @@ union (Map ls) (Map rs) = Map res safeAppend xs1 xs2 = P.matchList xs1 - xs2 + (\() -> xs2) ( \hd tl -> let k = BI.fst hd v = BI.snd hd @@ -335,7 +335,7 @@ unionWith f (Map ls) (Map rs) = go xs = P.matchList xs - nil + (\() -> nil) ( \hd tl -> let k' = BI.fst hd v' = BI.snd hd @@ -353,7 +353,7 @@ unionWith f (Map ls) (Map rs) = go xs = P.matchList xs - nil + (\() -> nil) ( \hd tl -> let k' = BI.fst hd tl' = go tl @@ -368,7 +368,7 @@ unionWith f (Map ls) (Map rs) = go acc xs = P.matchList xs - acc + (\() -> acc) (\hd -> go (BI.mkCons hd acc)) {-# INLINEABLE toList #-} @@ -380,7 +380,7 @@ toList d = go (toBuiltinList d) go xs = P.matchList xs - [] + (\() -> []) ( \hd tl -> (P.unsafeFromBuiltinData (BI.fst hd), P.unsafeFromBuiltinData (BI.snd hd)) : go tl From 38270be4e3eac0c14d77d80241119c37d4bb617c Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Tue, 14 May 2024 15:40:54 +0300 Subject: [PATCH 30/41] Add utils from bench package to plutus-tx-plugin tests Signed-off-by: Ana Pantilie --- plutus-tx-plugin/plutus-tx-plugin.cabal | 1 + plutus-tx-plugin/test/Util/Common.hs | 88 +++++++++++++++++++++++++ 2 files changed, 89 insertions(+) create mode 100644 plutus-tx-plugin/test/Util/Common.hs diff --git a/plutus-tx-plugin/plutus-tx-plugin.cabal b/plutus-tx-plugin/plutus-tx-plugin.cabal index 3100d789aa2..60e5a968783 100644 --- a/plutus-tx-plugin/plutus-tx-plugin.cabal +++ b/plutus-tx-plugin/plutus-tx-plugin.cabal @@ -172,6 +172,7 @@ test-suite plutus-tx-plugin-tests TH.Spec TH.TestTH Unicode.Spec + Util.Common build-depends: , base >=4.9 && <5 diff --git a/plutus-tx-plugin/test/Util/Common.hs b/plutus-tx-plugin/test/Util/Common.hs new file mode 100644 index 00000000000..5f5a866e38d --- /dev/null +++ b/plutus-tx-plugin/test/Util/Common.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} + +module Util.Common + ( Program + , Term + , toAnonDeBruijnTerm + , toNamedDeBruijnTerm + , compiledCodeToTerm + , haskellValueToTerm + , unsafeRunTermCek + , runTermCek + , cekResultMatchesHaskellValue + ) +where + +import PlutusTx qualified as Tx + +import PlutusCore qualified as PLC +import PlutusCore.Default +import PlutusCore.Evaluation.Machine.ExBudgetingDefaults qualified as PLC + +import UntypedPlutusCore qualified as UPLC +import UntypedPlutusCore.Evaluation.Machine.Cek as Cek + +import Data.Text (Text) + +type Term = UPLC.Term PLC.NamedDeBruijn DefaultUni DefaultFun () +type Program = UPLC.Program PLC.NamedDeBruijn DefaultUni DefaultFun () + +{- | Given a DeBruijn-named term, give every variable the name "v". If we later + call unDeBruijn, that will rename the variables to things like "v123", where + 123 is the relevant de Bruijn index.-} +toNamedDeBruijnTerm + :: UPLC.Term UPLC.DeBruijn DefaultUni DefaultFun () + -> UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun () +toNamedDeBruijnTerm = UPLC.termMapNames UPLC.fakeNameDeBruijn + +{- | Remove the textual names from a NamedDeBruijn term -} +toAnonDeBruijnTerm + :: Term + -> UPLC.Term UPLC.DeBruijn DefaultUni DefaultFun () +toAnonDeBruijnTerm = UPLC.termMapNames UPLC.unNameDeBruijn + +{- | Just extract the body of a program wrapped in a 'CompiledCodeIn'. We use this a lot. -} +compiledCodeToTerm + :: Tx.CompiledCodeIn DefaultUni DefaultFun a -> Term +compiledCodeToTerm (Tx.getPlcNoAnn -> UPLC.Program _ _ body) = body + +{- | Lift a Haskell value to a PLC term. The constraints get a bit out of control + if we try to do this over an arbitrary universe.-} +haskellValueToTerm + :: Tx.Lift DefaultUni a => a -> Term +haskellValueToTerm = compiledCodeToTerm . Tx.liftCodeDef + +{- | Just run a term to obtain an `EvaluationResult` (used for tests etc.) -} +unsafeRunTermCek :: Term -> EvaluationResult Term +unsafeRunTermCek = + unsafeExtractEvaluationResult + . (\(res, _, _) -> res) + . runCekDeBruijn PLC.defaultCekParameters Cek.restrictingEnormous Cek.noEmitter + +-- | Just run a term. +runTermCek :: + Term -> + ( Either (CekEvaluationException UPLC.NamedDeBruijn DefaultUni DefaultFun) Term + , [Text] + ) +runTermCek = + (\(res, _, logs) -> (res, logs)) + . runCekDeBruijn PLC.defaultCekParameters Cek.restrictingEnormous Cek.logEmitter + +{- | Evaluate a PLC term and check that the result matches a given Haskell value + (perhaps obtained by running the Haskell code that the term was compiled + from). We evaluate the lifted Haskell value as well, because lifting may + produce reducible terms. The function is polymorphic in the comparison + operator so that we can use it with both HUnit Assertions and QuickCheck + Properties. -} +cekResultMatchesHaskellValue + :: Tx.Lift DefaultUni a + => Term + -> (EvaluationResult Term -> EvaluationResult Term -> b) + -> a + -> b +cekResultMatchesHaskellValue term matches value = + (unsafeRunTermCek term) `matches` (unsafeRunTermCek $ haskellValueToTerm value) From a033dc069549562a698c53d31954eff237cc0788 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Tue, 14 May 2024 16:04:39 +0300 Subject: [PATCH 31/41] Run first PlutusTx property test Signed-off-by: Ana Pantilie --- plutus-tx-plugin/test/AssocMap/Spec.hs | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) diff --git a/plutus-tx-plugin/test/AssocMap/Spec.hs b/plutus-tx-plugin/test/AssocMap/Spec.hs index dc4ea865948..b342ba0e3d5 100644 --- a/plutus-tx-plugin/test/AssocMap/Spec.hs +++ b/plutus-tx-plugin/test/AssocMap/Spec.hs @@ -35,6 +35,7 @@ import PlutusTx.TH (compile) import PlutusTx.These (These (..), these) import Test.Tasty (TestTree, testGroup) import Test.Tasty.Hedgehog (testProperty) +import Util.Common (cekResultMatchesHaskellValue, compiledCodeToTerm) goldenTests :: TestNested goldenTests = @@ -325,8 +326,20 @@ lookupSpec = property $ do key <- forAll $ Gen.integral rangeElem let assocMap = semanticsToAssocMap assocMapS dataAssocMap = semanticsToDataAssocMap assocMapS - lookupS key assocMapS === AssocMap.lookup key assocMap - lookupS key assocMapS === Data.AssocMap.lookup key dataAssocMap + expected = lookupS key assocMapS + cekResultMatchesHaskellValue + ( compiledCodeToTerm + ($$(compile + [|| AssocMap.lookup :: Integer -> AssocMap.Map Integer Integer -> Maybe Integer + ||] + ) + `unsafeApplyCode` (liftCodeDef key) + `unsafeApplyCode` (liftCodeDef assocMap) + ) + ) + (===) + expected + -- lookupS key assocMapS === Data.AssocMap.lookup key dataAssocMap memberSpec :: Property memberSpec = property $ do From bc462b7622b6fb135990fa2fb227ed8a5ab0b601 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Tue, 14 May 2024 19:08:25 +0300 Subject: [PATCH 32/41] WIP: add makeLift to new Map type Signed-off-by: Ana Pantilie --- plutus-tx-plugin/test/AssocMap/Spec.hs | 21 +++++++++++++++------ plutus-tx/src/PlutusTx/Data/AssocMap.hs | 14 ++++++++++---- 2 files changed, 25 insertions(+), 10 deletions(-) diff --git a/plutus-tx-plugin/test/AssocMap/Spec.hs b/plutus-tx-plugin/test/AssocMap/Spec.hs index b342ba0e3d5..10be01cdc71 100644 --- a/plutus-tx-plugin/test/AssocMap/Spec.hs +++ b/plutus-tx-plugin/test/AssocMap/Spec.hs @@ -164,6 +164,12 @@ map3 = ||] ) +lookupProgram :: CompiledCode (Integer -> AssocMap.Map Integer Integer -> Maybe Integer) +lookupProgram = $$(compile [|| AssocMap.lookup ||]) + +dataLookupProgram :: CompiledCode (Integer -> Data.AssocMap.Map Integer Integer -> Maybe Integer) +dataLookupProgram = $$(compile [|| Data.AssocMap.lookup ||]) + -- | The semantics of PlutusTx maps and their operations. -- The 'PlutusTx' implementations maps ('Data.AssocMap.Map' and 'AssocMap.Map') -- are checked against the semantics to ensure correctness. @@ -329,17 +335,20 @@ lookupSpec = property $ do expected = lookupS key assocMapS cekResultMatchesHaskellValue ( compiledCodeToTerm - ($$(compile - [|| AssocMap.lookup :: Integer -> AssocMap.Map Integer Integer -> Maybe Integer - ||] - ) + $ lookupProgram `unsafeApplyCode` (liftCodeDef key) `unsafeApplyCode` (liftCodeDef assocMap) - ) ) (===) expected - -- lookupS key assocMapS === Data.AssocMap.lookup key dataAssocMap + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ dataLookupProgram + `unsafeApplyCode` (liftCodeDef key) + `unsafeApplyCode` (liftCodeDef dataAssocMap) + ) + (===) + expected memberSpec :: Property memberSpec = property $ do diff --git a/plutus-tx/src/PlutusTx/Data/AssocMap.hs b/plutus-tx/src/PlutusTx/Data/AssocMap.hs index 1fefffef9e8..99cf622ebff 100644 --- a/plutus-tx/src/PlutusTx/Data/AssocMap.hs +++ b/plutus-tx/src/PlutusTx/Data/AssocMap.hs @@ -1,7 +1,9 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} module PlutusTx.Data.AssocMap ( Map, @@ -27,9 +29,11 @@ module PlutusTx.Data.AssocMap ( 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.These + import Prelude qualified as Haskell {- | A map associating keys and values backed by `P.BuiltinData`. @@ -405,3 +409,5 @@ unsafeFromBuiltinList = Map -- | An empty `P.BuiltinList` of key-value pairs. nil :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) nil = BI.mkNilPairData BI.unitval + +makeLift ''Map From b2e34e40d90965597b3cd5f40f3b7764f8a3be52 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Tue, 14 May 2024 19:18:18 +0300 Subject: [PATCH 33/41] Add first fully working plutus tx property test Signed-off-by: Ana Pantilie --- plutus-tx/src/PlutusTx/Data/AssocMap.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plutus-tx/src/PlutusTx/Data/AssocMap.hs b/plutus-tx/src/PlutusTx/Data/AssocMap.hs index 99cf622ebff..e132426b79f 100644 --- a/plutus-tx/src/PlutusTx/Data/AssocMap.hs +++ b/plutus-tx/src/PlutusTx/Data/AssocMap.hs @@ -192,7 +192,7 @@ null (Map m) = P.null m safeFromList :: forall k a . (Eq k, P.ToData k, P.ToData a) => [(k, a)] -> Map k a safeFromList = Map - . toBuiltin + . toOpaque . PlutusTx.Prelude.map (\(k, a) -> (P.toBuiltinData k, P.toBuiltinData a)) . foldr (uncurry go) [] where @@ -211,7 +211,7 @@ safeFromList = unsafeFromList :: (P.ToData k, P.ToData a) => [(k, a)] -> Map k a unsafeFromList = Map - . toBuiltin + . toOpaque . PlutusTx.Prelude.map (\(k, a) -> (P.toBuiltinData k, P.toBuiltinData a)) {-# INLINEABLE noDuplicateKeys #-} From 6f778199b50b36f878d41f18f593a6ecef5e1225 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Thu, 16 May 2024 18:38:56 +0300 Subject: [PATCH 34/41] Fix issue with insert propety test Signed-off-by: Ana Pantilie --- plutus-tx-plugin/test/AssocMap/Spec.hs | 144 ++++++++++++++++++------- 1 file changed, 104 insertions(+), 40 deletions(-) diff --git a/plutus-tx-plugin/test/AssocMap/Spec.hs b/plutus-tx-plugin/test/AssocMap/Spec.hs index 10be01cdc71..1ff00a7557e 100644 --- a/plutus-tx-plugin/test/AssocMap/Spec.hs +++ b/plutus-tx-plugin/test/AssocMap/Spec.hs @@ -1,11 +1,13 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} @@ -27,7 +29,8 @@ import PlutusTx.Code import PlutusTx.Data.AssocMap qualified as Data.AssocMap import PlutusTx.IsData () import PlutusTx.IsData qualified as P -import PlutusTx.Lift (liftCodeDef) +import PlutusTx.Lift (liftCodeDef, makeLift) +import PlutusTx.List qualified as PlutusTx import PlutusTx.Prelude qualified as PlutusTx import PlutusTx.Show qualified as PlutusTx import PlutusTx.Test @@ -37,41 +40,6 @@ import Test.Tasty (TestTree, testGroup) import Test.Tasty.Hedgehog (testProperty) import Util.Common (cekResultMatchesHaskellValue, compiledCodeToTerm) -goldenTests :: TestNested -goldenTests = - testNestedGhc - "Budget" - [ goldenPirReadable "map1" map1 - , goldenUPlcReadable "map1" map1 - , goldenEvalCekCatch "map1" $ [map1 `unsafeApplyCode` (liftCodeDef 100)] - , goldenBudget "map1-budget" $ map1 `unsafeApplyCode` (liftCodeDef 100) - , goldenPirReadable "map2" map2 - , goldenUPlcReadable "map2" map2 - , goldenEvalCekCatch "map2" $ [map2 `unsafeApplyCode` (liftCodeDef 100)] - , goldenBudget "map2-budget" $ map2 `unsafeApplyCode` (liftCodeDef 100) - , goldenPirReadable "map3" map2 - , goldenUPlcReadable "map3" map2 - , goldenEvalCekCatch "map3" $ [map2 `unsafeApplyCode` (liftCodeDef 100)] - , goldenBudget "map3-budget" $ map2 `unsafeApplyCode` (liftCodeDef 100) - ] - -propertyTests :: TestTree -propertyTests = - testGroup "Map property tests" - [ testProperty "safeFromList" safeFromListSpec - , testProperty "unsafeFromList" unsafeFromListSpec - , testProperty "lookup" lookupSpec - , testProperty "member" memberSpec - , testProperty "insert" insertSpec - , testProperty "all" allSpec - , testProperty "any" anySpec - , testProperty "keys" keysSpec - , testProperty "noDuplicateKeys" noDuplicateKeysSpec - , testProperty "delete" deleteSpec - , testProperty "union" unionSpec - , testProperty "unionWith" unionWithSpec - , testProperty "builtinDataEncoding" builtinDataEncodingSpec - ] -- | Test the performance and interaction between 'insert', 'delete' and 'lookup'. map1 :: @@ -170,6 +138,32 @@ lookupProgram = $$(compile [|| AssocMap.lookup ||]) dataLookupProgram :: CompiledCode (Integer -> Data.AssocMap.Map Integer Integer -> Maybe Integer) dataLookupProgram = $$(compile [|| Data.AssocMap.lookup ||]) +memberProgram :: CompiledCode (Integer -> AssocMap.Map Integer Integer -> Bool) +memberProgram = $$(compile [|| AssocMap.member ||]) + +dataMemberProgram :: CompiledCode (Integer -> Data.AssocMap.Map Integer Integer -> Bool) +dataMemberProgram = $$(compile [|| Data.AssocMap.member ||]) + +insertProgram + :: CompiledCode + ( Integer + -> Integer + -> AssocMap.Map Integer Integer + -> [(Integer, Integer)] + ) +insertProgram = + $$(compile [|| \k v m -> PlutusTx.sort $ AssocMap.toList $ AssocMap.insert k v m ||]) + +dataInsertProgram + :: CompiledCode + ( Integer + -> Integer + -> Data.AssocMap.Map Integer Integer + -> [(Integer, Integer)] + ) +dataInsertProgram = + $$(compile [|| \k v m -> PlutusTx.sort $ Data.AssocMap.toList $ Data.AssocMap.insert k v m ||]) + -- | The semantics of PlutusTx maps and their operations. -- The 'PlutusTx' implementations maps ('Data.AssocMap.Map' and 'AssocMap.Map') -- are checked against the semantics to ensure correctness. @@ -234,6 +228,8 @@ noDuplicateKeysS :: AssocMapS Integer Integer -> Bool noDuplicateKeysS (AssocMapS l) = length l == length (nubBy (\(k1, _) (k2, _) -> k1 == k2) l) +makeLift ''AssocMapS + -- | The semantics of 'union' is based on the 'AssocMap' implementation. -- The code is duplicated here to avoid any issues if the 'AssocMap' implementation changes. unionS @@ -356,8 +352,23 @@ memberSpec = property $ do key <- forAll $ Gen.integral rangeElem let assocMap = semanticsToAssocMap assocMapS dataAssocMap = semanticsToDataAssocMap assocMapS - memberS key assocMapS === AssocMap.member key assocMap - memberS key assocMapS === Data.AssocMap.member key dataAssocMap + expected = memberS key assocMapS + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ memberProgram + `unsafeApplyCode` (liftCodeDef key) + `unsafeApplyCode` (liftCodeDef assocMap) + ) + (===) + expected + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ dataMemberProgram + `unsafeApplyCode` (liftCodeDef key) + `unsafeApplyCode` (liftCodeDef dataAssocMap) + ) + (===) + expected insertSpec :: Property insertSpec = property $ do @@ -366,8 +377,25 @@ insertSpec = property $ do value <- forAll $ Gen.integral rangeElem let assocMap = semanticsToAssocMap assocMapS dataAssocMap = semanticsToDataAssocMap assocMapS - insertS key value assocMapS ~~ AssocMap.insert key value assocMap - insertS key value assocMapS ~~ Data.AssocMap.insert key value dataAssocMap + expected = sortS $ insertS key value assocMapS + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ insertProgram + `unsafeApplyCode` (liftCodeDef key) + `unsafeApplyCode` (liftCodeDef value) + `unsafeApplyCode` (liftCodeDef assocMap) + ) + (===) + expected + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ dataInsertProgram + `unsafeApplyCode` (liftCodeDef key) + `unsafeApplyCode` (liftCodeDef value) + `unsafeApplyCode` (liftCodeDef dataAssocMap) + ) + (===) + expected deleteSpec :: Property deleteSpec = property $ do @@ -452,3 +480,39 @@ builtinDataEncodingSpec = property $ do assocMapS ~~ fromJust mDecodedDataAssocMap assocMapS ~~ decodedAssocMap assocMapS ~~ decodedDataAssocMap + +goldenTests :: TestNested +goldenTests = + testNestedGhc + "Budget" + [ goldenPirReadable "map1" map1 + , goldenUPlcReadable "map1" map1 + , goldenEvalCekCatch "map1" $ [map1 `unsafeApplyCode` (liftCodeDef 100)] + , goldenBudget "map1-budget" $ map1 `unsafeApplyCode` (liftCodeDef 100) + , goldenPirReadable "map2" map2 + , goldenUPlcReadable "map2" map2 + , goldenEvalCekCatch "map2" $ [map2 `unsafeApplyCode` (liftCodeDef 100)] + , goldenBudget "map2-budget" $ map2 `unsafeApplyCode` (liftCodeDef 100) + , goldenPirReadable "map3" map2 + , goldenUPlcReadable "map3" map2 + , goldenEvalCekCatch "map3" $ [map2 `unsafeApplyCode` (liftCodeDef 100)] + , goldenBudget "map3-budget" $ map2 `unsafeApplyCode` (liftCodeDef 100) + ] + +propertyTests :: TestTree +propertyTests = + testGroup "TESTING Map property tests" + [ testProperty "safeFromList" safeFromListSpec + , testProperty "unsafeFromList" unsafeFromListSpec + , testProperty "lookup" lookupSpec + , testProperty "member" memberSpec + , testProperty "insert" insertSpec + , testProperty "all" allSpec + , testProperty "any" anySpec + , testProperty "keys" keysSpec + , testProperty "noDuplicateKeys" noDuplicateKeysSpec + , testProperty "delete" deleteSpec + , testProperty "union" unionSpec + , testProperty "unionWith" unionWithSpec + , testProperty "builtinDataEncoding" builtinDataEncodingSpec + ] From c57c9b7bb35702c63d3d26e4e2199c0442850915 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Thu, 16 May 2024 21:46:54 +0300 Subject: [PATCH 35/41] Run all tests with PlutusTx Signed-off-by: Ana Pantilie --- plutus-tx-plugin/plutus-tx-plugin.cabal | 1 + plutus-tx-plugin/test/AssocMap/Spec.hs | 371 ++++++++++++++++++++--- plutus-tx/src/PlutusTx/Eq.hs | 8 + plutus-tx/src/PlutusTx/Lift/Instances.hs | 2 + plutus-tx/src/PlutusTx/Ord.hs | 15 + plutus-tx/src/PlutusTx/Show.hs | 2 + plutus-tx/src/PlutusTx/These.hs | 3 - 7 files changed, 357 insertions(+), 45 deletions(-) diff --git a/plutus-tx-plugin/plutus-tx-plugin.cabal b/plutus-tx-plugin/plutus-tx-plugin.cabal index e77322ffcc8..bdf5c1a1482 100644 --- a/plutus-tx-plugin/plutus-tx-plugin.cabal +++ b/plutus-tx-plugin/plutus-tx-plugin.cabal @@ -194,6 +194,7 @@ test-suite plutus-tx-plugin-tests , tasty-hunit , template-haskell , text + , these default-extensions: Strict ghc-options: -threaded -rtsopts -with-rtsopts=-N diff --git a/plutus-tx-plugin/test/AssocMap/Spec.hs b/plutus-tx-plugin/test/AssocMap/Spec.hs index 1ff00a7557e..c45545535bd 100644 --- a/plutus-tx-plugin/test/AssocMap/Spec.hs +++ b/plutus-tx-plugin/test/AssocMap/Spec.hs @@ -19,7 +19,7 @@ import Test.Tasty.Extras import Data.List (nubBy, sort) import Data.Map.Strict qualified as Map -import Data.Maybe (fromJust) +import Data.These qualified as Haskell import Hedgehog (Gen, MonadTest, Property, Range, forAll, property, (===)) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range @@ -38,7 +38,7 @@ import PlutusTx.TH (compile) import PlutusTx.These (These (..), these) import Test.Tasty (TestTree, testGroup) import Test.Tasty.Hedgehog (testProperty) -import Util.Common (cekResultMatchesHaskellValue, compiledCodeToTerm) +import Util.Common (cekResultMatchesHaskellValue, compiledCodeToTerm, unsafeRunTermCek) -- | Test the performance and interaction between 'insert', 'delete' and 'lookup'. @@ -152,7 +152,10 @@ insertProgram -> [(Integer, Integer)] ) insertProgram = - $$(compile [|| \k v m -> PlutusTx.sort $ AssocMap.toList $ AssocMap.insert k v m ||]) + $$(compile + [|| \k v m -> + PlutusTx.sort $ AssocMap.toList $ AssocMap.insert k v m + ||]) dataInsertProgram :: CompiledCode @@ -162,7 +165,179 @@ dataInsertProgram -> [(Integer, Integer)] ) dataInsertProgram = - $$(compile [|| \k v m -> PlutusTx.sort $ Data.AssocMap.toList $ Data.AssocMap.insert k v m ||]) + $$(compile + [|| \k v m -> + PlutusTx.sort $ Data.AssocMap.toList $ Data.AssocMap.insert k v m + ||]) + +deleteProgram + :: CompiledCode + ( Integer + -> AssocMap.Map Integer Integer + -> [(Integer, Integer)] + ) +deleteProgram = + $$(compile + [|| \k m -> + PlutusTx.sort $ AssocMap.toList $ AssocMap.delete k m + ||]) + +dataDeleteProgram + :: CompiledCode + ( Integer + -> Data.AssocMap.Map Integer Integer + -> [(Integer, Integer)] + ) +dataDeleteProgram = + $$(compile + [|| \k m -> + PlutusTx.sort $ Data.AssocMap.toList $ Data.AssocMap.delete k m + ||]) + +allProgram + :: CompiledCode + ( Integer + -> AssocMap.Map Integer Integer + -> Bool + ) +allProgram = + $$(compile [|| \num m -> AssocMap.all (\x -> x PlutusTx.< num) m ||]) + +dataAllProgram + :: CompiledCode + ( Integer + -> Data.AssocMap.Map Integer Integer + -> Bool + ) +dataAllProgram = + $$(compile [|| \num m -> Data.AssocMap.all (\x -> x PlutusTx.< num) m ||]) + +dataAnyProgram + :: CompiledCode + ( Integer + -> Data.AssocMap.Map Integer Integer + -> Bool + ) +dataAnyProgram = + $$(compile [|| \num m -> Data.AssocMap.any (\x -> x PlutusTx.< num) m ||]) + +keysProgram + :: CompiledCode + ( AssocMap.Map Integer Integer + -> [Integer] + ) +keysProgram = + $$(compile [|| AssocMap.keys ||]) + +dataNoDuplicateKeysProgram + :: CompiledCode + ( Data.AssocMap.Map Integer Integer + -> Bool + ) +dataNoDuplicateKeysProgram = + $$(compile [|| Data.AssocMap.noDuplicateKeys ||]) + +unionProgram + :: CompiledCode + ( AssocMap.Map Integer Integer + -> AssocMap.Map Integer Integer + -> [(Integer, These Integer Integer)] + ) +unionProgram = + $$(compile + [|| \m1 m2 -> + PlutusTx.sort $ AssocMap.toList $ AssocMap.union m1 m2 + ||]) + +dataUnionProgram + :: CompiledCode + ( Data.AssocMap.Map Integer Integer + -> Data.AssocMap.Map Integer Integer + -> [(Integer, These Integer Integer)] + ) +dataUnionProgram = + $$(compile + [|| \m1 m2 -> + PlutusTx.sort $ Data.AssocMap.toList $ Data.AssocMap.union m1 m2 + ||]) + +unionWithProgram + :: CompiledCode + ( AssocMap.Map Integer Integer + -> AssocMap.Map Integer Integer + -> [(Integer, Integer)] + ) +unionWithProgram = + $$(compile + [|| \m1 m2 -> + PlutusTx.sort $ AssocMap.toList $ AssocMap.unionWith (\x _ -> x) m1 m2 + ||]) + +dataUnionWithProgram + :: CompiledCode + ( Data.AssocMap.Map Integer Integer + -> Data.AssocMap.Map Integer Integer + -> [(Integer, Integer)] + ) +dataUnionWithProgram = + $$(compile + [|| \m1 m2 -> + PlutusTx.sort $ Data.AssocMap.toList $ Data.AssocMap.unionWith (\x _ -> x) m1 m2 + ||]) + +encodedDataAssocMap + :: CompiledCode + ( Data.AssocMap.Map Integer Integer + -> PlutusTx.BuiltinData + ) +encodedDataAssocMap = $$(compile [|| P.toBuiltinData ||]) + +encodedAssocMap + :: CompiledCode + ( AssocMap.Map Integer Integer + -> PlutusTx.BuiltinData + ) +encodedAssocMap = $$(compile [|| P.toBuiltinData ||]) + +mDecodedDataAssocMap + :: CompiledCode + ( Data.AssocMap.Map Integer Integer + -> PlutusTx.Maybe [(Integer, Integer)] + ) +mDecodedDataAssocMap = + $$(compile + [|| fmap (PlutusTx.sort . Data.AssocMap.toList) . P.fromBuiltinData . P.toBuiltinData + ||]) + +mDecodedAssocMap + :: CompiledCode + ( AssocMap.Map Integer Integer + -> PlutusTx.Maybe [(Integer, Integer)] + ) +mDecodedAssocMap = + $$(compile + [|| fmap (PlutusTx.sort . AssocMap.toList) . P.fromBuiltinData . P.toBuiltinData + ||]) + +decodedDataAssocMap + :: CompiledCode + ( Data.AssocMap.Map Integer Integer + -> [(Integer, Integer)] + ) +decodedDataAssocMap = + $$(compile + [|| PlutusTx.sort . Data.AssocMap.toList . P.unsafeFromBuiltinData . P.toBuiltinData + ||]) + +decodedAssocMap + :: CompiledCode + ( AssocMap.Map Integer Integer + -> [(Integer, Integer)] + ) +decodedAssocMap = + $$(compile + [|| PlutusTx.sort . AssocMap.toList . P.unsafeFromBuiltinData . P.toBuiltinData + ||]) -- | The semantics of PlutusTx maps and their operations. -- The 'PlutusTx' implementations maps ('Data.AssocMap.Map' and 'AssocMap.Map') @@ -228,6 +403,9 @@ noDuplicateKeysS :: AssocMapS Integer Integer -> Bool noDuplicateKeysS (AssocMapS l) = length l == length (nubBy (\(k1, _) (k2, _) -> k1 == k2) l) +mapS :: (a -> b) -> AssocMapS k a -> AssocMapS k b +mapS f (AssocMapS l) = AssocMapS $ map (\(k, v) -> (k, f v)) l + makeLift ''AssocMapS -- | The semantics of 'union' is based on the 'AssocMap' implementation. @@ -235,22 +413,28 @@ makeLift ''AssocMapS unionS :: AssocMapS Integer Integer -> AssocMapS Integer Integer - -> AssocMapS Integer (These Integer Integer) + -> AssocMapS Integer (Haskell.These Integer Integer) unionS (AssocMapS ls) (AssocMapS rs) = let f a b' = case b' of - Nothing -> This a - Just b -> These a b + Nothing -> Haskell.This a + Just b -> Haskell.These a b ls' = fmap (\(c, i) -> (c, f i (lookupS c (AssocMapS rs)))) ls -- Keeps only those keys which don't appear in the left map. rs' = filter (\(c, _) -> not (any (\(c', _) -> c' == c) ls)) rs - rs'' = fmap (fmap That) rs' + rs'' = fmap (fmap Haskell.That) rs' in AssocMapS (ls' ++ rs'') +haskellToPlutusThese :: Haskell.These a b -> These a b +haskellToPlutusThese = \case + Haskell.This a -> This a + Haskell.That b -> That b + Haskell.These a b -> These a b + unionWithS :: (Integer -> Integer -> Integer) -> AssocMapS Integer Integer @@ -403,8 +587,23 @@ deleteSpec = property $ do key <- forAll $ Gen.integral rangeElem let assocMap = semanticsToAssocMap assocMapS dataAssocMap = semanticsToDataAssocMap assocMapS - deleteS key assocMapS ~~ AssocMap.delete key assocMap - deleteS key assocMapS ~~ Data.AssocMap.delete key dataAssocMap + expected = sortS $ deleteS key assocMapS + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ deleteProgram + `unsafeApplyCode` (liftCodeDef key) + `unsafeApplyCode` (liftCodeDef assocMap) + ) + (===) + expected + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ dataDeleteProgram + `unsafeApplyCode` (liftCodeDef key) + `unsafeApplyCode` (liftCodeDef dataAssocMap) + ) + (===) + expected allSpec :: Property allSpec = property $ do @@ -412,74 +611,162 @@ allSpec = property $ do num <- forAll $ Gen.integral rangeElem let assocMap = semanticsToAssocMap assocMapS dataAssocMap = semanticsToDataAssocMap assocMapS - predicate x = x < num - allS predicate assocMapS === AssocMap.all predicate assocMap - allS predicate assocMapS === Data.AssocMap.all predicate dataAssocMap + expected = allS (< num) assocMapS + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ allProgram + `unsafeApplyCode` (liftCodeDef num) + `unsafeApplyCode` (liftCodeDef assocMap) + ) + (===) + expected + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ dataAllProgram + `unsafeApplyCode` (liftCodeDef num) + `unsafeApplyCode` (liftCodeDef dataAssocMap) + ) + (===) + expected anySpec :: Property anySpec = property $ do assocMapS <- forAll genAssocMapS num <- forAll $ Gen.integral rangeElem let dataAssocMap = semanticsToDataAssocMap assocMapS - predicate x = x < num - anyS predicate assocMapS === Data.AssocMap.any predicate dataAssocMap + expected = anyS (< num) assocMapS + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ dataAnyProgram + `unsafeApplyCode` (liftCodeDef num) + `unsafeApplyCode` (liftCodeDef dataAssocMap) + ) + (===) + expected keysSpec :: Property keysSpec = property $ do assocMapS <- forAll genAssocMapS let assocMap = semanticsToAssocMap assocMapS - keysS assocMapS === AssocMap.keys assocMap + expected = keysS assocMapS + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ keysProgram + `unsafeApplyCode` (liftCodeDef assocMap) + ) + (===) + expected noDuplicateKeysSpec :: Property noDuplicateKeysSpec = property $ do assocMapS <- forAll genAssocMapS let dataAssocMap = semanticsToDataAssocMap assocMapS - noDuplicateKeysS assocMapS === Data.AssocMap.noDuplicateKeys dataAssocMap + expected = noDuplicateKeysS assocMapS + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ dataNoDuplicateKeysProgram + `unsafeApplyCode` (liftCodeDef dataAssocMap) + ) + (===) + expected unionSpec :: Property unionSpec = property $ do - assocMapS1 <- forAll genAssocMapS - assocMapS2 <- forAll genAssocMapS + -- resizing the generator for performance + assocMapS1 <- forAll (Gen.resize 20 genAssocMapS) + assocMapS2 <- forAll (Gen.resize 20 genAssocMapS) let assocMap1 = semanticsToAssocMap assocMapS1 assocMap2 = semanticsToAssocMap assocMapS2 dataAssocMap1 = semanticsToDataAssocMap assocMapS1 dataAssocMap2 = semanticsToDataAssocMap assocMapS2 - unionS assocMapS1 assocMapS2 ~~ AssocMap.union assocMap1 assocMap2 - unionS assocMapS1 assocMapS2 ~~ Data.AssocMap.union dataAssocMap1 dataAssocMap2 + expected = mapS haskellToPlutusThese $ sortS $ unionS assocMapS1 assocMapS2 + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ unionProgram + `unsafeApplyCode` (liftCodeDef assocMap1) + `unsafeApplyCode` (liftCodeDef assocMap2) + ) + (===) + expected + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ dataUnionProgram + `unsafeApplyCode` (liftCodeDef dataAssocMap1) + `unsafeApplyCode` (liftCodeDef dataAssocMap2) + ) + (===) + expected unionWithSpec :: Property unionWithSpec = property $ do - assocMapS1 <- forAll genAssocMapS - assocMapS2 <- forAll genAssocMapS + -- resizing the generator for performance + assocMapS1 <- forAll (Gen.resize 20 genAssocMapS) + assocMapS2 <- forAll (Gen.resize 20 genAssocMapS) let assocMap1 = semanticsToAssocMap assocMapS1 assocMap2 = semanticsToAssocMap assocMapS2 dataAssocMap1 = semanticsToDataAssocMap assocMapS1 dataAssocMap2 = semanticsToDataAssocMap assocMapS2 merge i1 _ = i1 - unionWithS merge assocMapS1 assocMapS2 ~~ AssocMap.unionWith merge assocMap1 assocMap2 - unionWithS merge assocMapS1 assocMapS2 - ~~ Data.AssocMap.unionWith merge dataAssocMap1 dataAssocMap2 + expected = unionWithS merge assocMapS1 assocMapS2 + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ unionWithProgram + `unsafeApplyCode` (liftCodeDef assocMap1) + `unsafeApplyCode` (liftCodeDef assocMap2) + ) + (===) + expected + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ dataUnionWithProgram + `unsafeApplyCode` (liftCodeDef dataAssocMap1) + `unsafeApplyCode` (liftCodeDef dataAssocMap2) + ) + (===) + expected builtinDataEncodingSpec :: Property builtinDataEncodingSpec = property $ do assocMapS <- forAll genAssocMapS let assocMap = semanticsToAssocMap assocMapS dataAssocMap = semanticsToDataAssocMap assocMapS - encodedDataAssocMap = P.toBuiltinData dataAssocMap - encodedAssocMap = P.toBuiltinData assocMap - mDecodedDataAssocMap :: Maybe (Data.AssocMap.Map Integer Integer) - mDecodedDataAssocMap = P.fromBuiltinData encodedDataAssocMap - mDecodedAssocMap :: Maybe (AssocMap.Map Integer Integer) - mDecodedAssocMap = P.fromBuiltinData encodedAssocMap - decodedDataAssocMap :: Data.AssocMap.Map Integer Integer - decodedDataAssocMap = P.unsafeFromBuiltinData encodedDataAssocMap - decodedAssocMap :: AssocMap.Map Integer Integer - decodedAssocMap = P.unsafeFromBuiltinData encodedAssocMap - encodedDataAssocMap === encodedAssocMap - assocMapS ~~ fromJust mDecodedAssocMap - assocMapS ~~ fromJust mDecodedDataAssocMap - assocMapS ~~ decodedAssocMap - assocMapS ~~ decodedDataAssocMap + unsafeRunTermCek + ( compiledCodeToTerm + $ encodedDataAssocMap `unsafeApplyCode` (liftCodeDef dataAssocMap) + ) + === + unsafeRunTermCek + ( compiledCodeToTerm + $ encodedAssocMap `unsafeApplyCode` (liftCodeDef assocMap) + ) + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ mDecodedAssocMap + `unsafeApplyCode` (liftCodeDef assocMap) + ) + (===) + (Just assocMapS) + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ mDecodedDataAssocMap + `unsafeApplyCode` (liftCodeDef dataAssocMap) + ) + (===) + (Just assocMapS) + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ decodedAssocMap + `unsafeApplyCode` (liftCodeDef assocMap) + ) + (===) + assocMapS + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ decodedDataAssocMap + `unsafeApplyCode` (liftCodeDef dataAssocMap) + ) + (===) + assocMapS goldenTests :: TestNested goldenTests = @@ -501,7 +788,7 @@ goldenTests = propertyTests :: TestTree propertyTests = - testGroup "TESTING Map property tests" + testGroup "Map property tests" [ testProperty "safeFromList" safeFromListSpec , testProperty "unsafeFromList" unsafeFromListSpec , testProperty "lookup" lookupSpec diff --git a/plutus-tx/src/PlutusTx/Eq.hs b/plutus-tx/src/PlutusTx/Eq.hs index 0e7b921dfad..de6e87926c7 100644 --- a/plutus-tx/src/PlutusTx/Eq.hs +++ b/plutus-tx/src/PlutusTx/Eq.hs @@ -4,6 +4,7 @@ module PlutusTx.Eq (Eq(..), (/=)) where import PlutusTx.Bool import PlutusTx.Builtins qualified as Builtins import PlutusTx.Either (Either (..)) +import PlutusTx.These import Prelude (Maybe (..)) {- HLINT ignore -} @@ -77,3 +78,10 @@ instance Eq () where instance (Eq a, Eq b) => Eq (a, b) where {-# INLINABLE (==) #-} (a, b) == (a', b') = a == a' && b == b' + +instance (Eq a, Eq b) => Eq (These a b) where + {-# INLINABLE (==) #-} + (This a) == (This a') = a == a' + (That b) == (That b') = b == b' + (These a b) == (These a' b') = a == a' && b == b' + _ == _ = False diff --git a/plutus-tx/src/PlutusTx/Lift/Instances.hs b/plutus-tx/src/PlutusTx/Lift/Instances.hs index d5132023e16..98832e7b576 100644 --- a/plutus-tx/src/PlutusTx/Lift/Instances.hs +++ b/plutus-tx/src/PlutusTx/Lift/Instances.hs @@ -18,6 +18,7 @@ import PlutusTx.Bool (Bool (..)) import PlutusTx.Either (Either (..)) import PlutusTx.Lift.TH import PlutusTx.Maybe (Maybe (..)) +import PlutusTx.These (These (..)) -- Standard types -- These need to be in a separate file for TH staging reasons @@ -25,6 +26,7 @@ import PlutusTx.Maybe (Maybe (..)) makeLift ''Bool makeLift ''Maybe makeLift ''Either +makeLift ''These makeLift ''[] makeLift ''() -- include a few tuple instances for convenience diff --git a/plutus-tx/src/PlutusTx/Ord.hs b/plutus-tx/src/PlutusTx/Ord.hs index 210826488df..f92baf2e2bb 100644 --- a/plutus-tx/src/PlutusTx/Ord.hs +++ b/plutus-tx/src/PlutusTx/Ord.hs @@ -11,6 +11,7 @@ import PlutusTx.Bool (Bool (..)) import PlutusTx.Builtins qualified as Builtins import PlutusTx.Either (Either (..)) import PlutusTx.Eq +import PlutusTx.These import Prelude (Maybe (..), Ordering (..)) {- HLINT ignore -} @@ -123,3 +124,17 @@ instance (Ord a, Ord b) => Ord (a, b) where case compare a a' of EQ -> compare b b' c -> c + +instance (Ord a, Ord b) => Ord (These a b) where + {-# INLINABLE compare #-} + compare (This a) (This a') = compare a a' + compare (That b) (That b') = compare b b' + compare (These a b) (These a' b') = + case compare a a' of + EQ -> compare b b' + c -> c + compare (This _) _ = LT + compare (That _) (This _) = GT + compare (That _) (These _ _) = LT + compare (These _ _) (This _) = GT + compare (These _ _) (That _) = GT diff --git a/plutus-tx/src/PlutusTx/Show.hs b/plutus-tx/src/PlutusTx/Show.hs index 5b16c1ebf9c..e8d57caedbc 100644 --- a/plutus-tx/src/PlutusTx/Show.hs +++ b/plutus-tx/src/PlutusTx/Show.hs @@ -25,6 +25,7 @@ import PlutusTx.List (foldr) import PlutusTx.Maybe import PlutusTx.Prelude hiding (foldr) import PlutusTx.Show.TH +import PlutusTx.These instance Show Builtins.Integer where {-# INLINEABLE showsPrec #-} @@ -160,3 +161,4 @@ deriveShow ''(,,,,,,,,,,,,,,,,,,,,,,,,,) deriveShow ''(,,,,,,,,,,,,,,,,,,,,,,,,,,) deriveShow ''Maybe deriveShow ''Either +deriveShow ''These diff --git a/plutus-tx/src/PlutusTx/These.hs b/plutus-tx/src/PlutusTx/These.hs index 42306b4d99a..124a37d6102 100644 --- a/plutus-tx/src/PlutusTx/These.hs +++ b/plutus-tx/src/PlutusTx/These.hs @@ -10,12 +10,9 @@ module PlutusTx.These( , theseWithDefault ) where -import Prelude - -- | A 'These' @a@ @b@ is either an @a@, or a @b@ or an @a@ and a @b@. -- Plutus version of 'Data.These'. data These a b = This a | That b | These a b - deriving stock (Show, Eq, Ord) {-# INLINABLE theseWithDefault #-} -- | Consume a 'These a b' value. From 678992df97a0f0192e8ed98e9891d015d8714adf Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Thu, 16 May 2024 22:00:53 +0300 Subject: [PATCH 36/41] Add changelog Signed-off-by: Ana Pantilie --- .../20240516_215552_ana.pantilie95_data_assoclist.md | 7 +++++++ 1 file changed, 7 insertions(+) create mode 100644 plutus-tx/changelog.d/20240516_215552_ana.pantilie95_data_assoclist.md diff --git a/plutus-tx/changelog.d/20240516_215552_ana.pantilie95_data_assoclist.md b/plutus-tx/changelog.d/20240516_215552_ana.pantilie95_data_assoclist.md new file mode 100644 index 00000000000..73cd8f8e8af --- /dev/null +++ b/plutus-tx/changelog.d/20240516_215552_ana.pantilie95_data_assoclist.md @@ -0,0 +1,7 @@ +### Added + +- Added `Data.AssocList.Map` module which provides a map implementation based on `Data`. + +### Changed + +- The PlutusTx `These` type had the Haskell implementations of `Show`, `Eq` and `Ord` instances instead of PlutusTx ones. This has been fixed. From 8cda32bd8d0a85297453c6707b1efa79fc0a8d36 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Tue, 21 May 2024 16:18:34 +0300 Subject: [PATCH 37/41] Fix test module warning Signed-off-by: Ana Pantilie --- plutus-tx-plugin/test/AssocMap/Spec.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/plutus-tx-plugin/test/AssocMap/Spec.hs b/plutus-tx-plugin/test/AssocMap/Spec.hs index c45545535bd..d8658ebd69c 100644 --- a/plutus-tx-plugin/test/AssocMap/Spec.hs +++ b/plutus-tx-plugin/test/AssocMap/Spec.hs @@ -12,6 +12,7 @@ {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} module AssocMap.Spec where From 393162cf5081083d55fbc089078d2fb4f3bf79a1 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Tue, 21 May 2024 16:19:23 +0300 Subject: [PATCH 38/41] Fix isData instance for These Signed-off-by: Ana Pantilie --- .../test/Budget/9.6/map1-budget.budget.golden | 4 +- .../test/Budget/9.6/map1.pir.golden | 39 +- .../test/Budget/9.6/map1.uplc.golden | 370 ++++++++--------- .../test/Budget/9.6/map2-budget.budget.golden | 4 +- .../test/Budget/9.6/map2.pir.golden | 44 +-- .../test/Budget/9.6/map2.uplc.golden | 372 +++++++++--------- .../test/Budget/9.6/map3-budget.budget.golden | 4 +- .../test/Budget/9.6/map3.pir.golden | 44 +-- .../test/Budget/9.6/map3.uplc.golden | 372 +++++++++--------- plutus-tx/src/PlutusTx/IsData/Instances.hs | 2 +- 10 files changed, 629 insertions(+), 626 deletions(-) diff --git a/plutus-tx-plugin/test/Budget/9.6/map1-budget.budget.golden b/plutus-tx-plugin/test/Budget/9.6/map1-budget.budget.golden index a25b08605a7..86ad2362090 100644 --- a/plutus-tx-plugin/test/Budget/9.6/map1-budget.budget.golden +++ b/plutus-tx-plugin/test/Budget/9.6/map1-budget.budget.golden @@ -1,2 +1,2 @@ -({cpu: 444554968 -| mem: 1075929}) \ No newline at end of file +({cpu: 390652748 +| mem: 872009}) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Budget/9.6/map1.pir.golden b/plutus-tx-plugin/test/Budget/9.6/map1.pir.golden index 12bfa01abdc..3598b6e089e 100644 --- a/plutus-tx-plugin/test/Budget/9.6/map1.pir.golden +++ b/plutus-tx-plugin/test/Budget/9.6/map1.pir.golden @@ -222,32 +222,27 @@ in let data Unit | Unit_match where Unit : Unit - !matchList : all a r. list a -> r -> (a -> list a -> r) -> r - = /\a r -> - \(l : list a) (nilCase : r) (consCase : a -> list a -> r) -> - chooseList - {a} - {Unit -> r} - l - (\(ds : Unit) -> nilCase) - (\(ds : Unit) -> consCase (headList {a} l) (tailList {a} l)) - Unit in letrec !delete' : data -> list (pair data data) -> list (pair data data) = \(k : data) (m : list (pair data data)) -> - matchList + chooseList {pair data data} - {list (pair data data)} + {Unit -> list (pair data data)} m - [] - (\(hd : pair data data) (tl : list (pair data data)) -> + (\(ds : Unit) -> []) + (\(ds : Unit) -> + let + !hd : pair data data = headList {pair data data} m + !tl : list (pair data data) = tailList {pair data data} m + in ifThenElse {all dead. list (pair data data)} (equalsData k (fstPair {data} {data} hd)) (/\dead -> tl) (/\dead -> mkCons {pair data data} hd (delete' k tl)) {all dead. dead}) + Unit in let data (Maybe :: * -> *) a | Maybe_match where @@ -343,12 +338,19 @@ in letrec !go : list (pair data data) -> list (pair data data) = \(xs : list (pair data data)) -> - matchList + chooseList {pair data data} - {list (pair data data)} + {Unit -> list (pair data data)} xs - (mkCons {pair data data} (mkPairData k a) []) - (\(hd : pair data data) (tl : list (pair data data)) -> + (\(ds : Unit) -> + mkCons {pair data data} (mkPairData 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 ifThenElse {all dead. list (pair data data)} (equalsData k (fstPair {data} {data} hd)) @@ -356,6 +358,7 @@ in mkCons {pair data data} (mkPairData k a) tl) (/\dead -> mkCons {pair data data} hd (go tl)) {all dead. dead}) + Unit in go ds) (mkCons {pair data data} (mkPairData (iData n) (B #30)) []) diff --git a/plutus-tx-plugin/test/Budget/9.6/map1.uplc.golden b/plutus-tx-plugin/test/Budget/9.6/map1.uplc.golden index 3fb12e1a7d7..b1d2b4e885b 100644 --- a/plutus-tx-plugin/test/Budget/9.6/map1.uplc.golden +++ b/plutus-tx-plugin/test/Budget/9.6/map1.uplc.golden @@ -8,190 +8,194 @@ program (\go -> (\go -> (\concatBuiltinStrings -> - (\matchList -> - (\delete' - n -> - (\nt -> - (\cse -> - (\nt -> - (\lookup -> - constr 0 - [ (lookup - (\i -> iData i) - unBData - n - nt) - , (lookup - (\i -> iData i) - unBData - cse - nt) - , (lookup - (\i -> iData i) - unBData - (addInteger 10 n) - nt) - , (lookup - (\i -> iData i) - unBData - (addInteger 20 n) - nt) - , (lookup - (\i -> iData i) - unBData - cse - nt) ]) - (\`$dToData` - `$dUnsafeFromData` - ds - ds -> - force - (case - ((\k -> - fix1 - (\go - xs -> - force - (force - chooseList) - xs - (\ds -> - constr 1 []) - (\ds -> - (\hd -> - force - (force - ifThenElse - (equalsData - k - (force - (force - fstPair) - hd)) - (delay - ((\ds -> - constr 0 - [ (force - (force - sndPair) - hd) ]) - (force - tailList - xs))) - (delay - (go - (force - tailList - xs))))) + (\delete' + n -> + (\nt -> + (\cse -> + (\nt -> + (\lookup -> + constr 0 + [ (lookup + (\i -> iData i) + unBData + n + nt) + , (lookup + (\i -> iData i) + unBData + cse + nt) + , (lookup + (\i -> iData i) + unBData + (addInteger 10 n) + nt) + , (lookup + (\i -> iData i) + unBData + (addInteger 20 n) + nt) + , (lookup + (\i -> iData i) + unBData + cse + nt) ]) + (\`$dToData` + `$dUnsafeFromData` + ds + ds -> + force + (case + ((\k -> + fix1 + (\go + xs -> + force + (force chooseList) + xs + (\ds -> constr 1 []) + (\ds -> + (\hd -> + force (force - headList - xs)) - (constr 0 [])) - ds) - (`$dToData` ds)) - [ (\a -> - delay - (constr 0 - [ (`$dUnsafeFromData` - a) ])) - , (delay (constr 1 [])) ]))) - (delete' (iData cse) nt)) - (addInteger 5 n)) - ((\z -> - (\go eta -> - go eta) - (fix1 - (\go - ds -> - force - (case - ds - [ (delay z) - , (\y - ys -> - delay - ((\ds -> - (\ds - ds -> - (\k -> - (\a -> - fix1 - (\go - xs -> - (\cse -> - (\cse -> - matchList - xs - (cse - [ ]) - (\hd - tl -> - force - (force - ifThenElse - (equalsData - k - (force - (force - fstPair) - hd)) - (delay - (cse - tl)) - (delay + ifThenElse + (equalsData + k + (force + (force + fstPair) + hd)) + (delay + ((\ds -> + constr 0 + [ (force + (force + sndPair) + hd) ]) + (force + tailList + xs))) + (delay + (go + (force + tailList + xs))))) + (force headList + xs)) + (constr 0 [])) + ds) + (`$dToData` ds)) + [ (\a -> + delay + (constr 0 + [ (`$dUnsafeFromData` + a) ])) + , (delay (constr 1 [])) ]))) + (delete' (iData cse) nt)) + (addInteger 5 n)) + ((\z -> + (\go eta -> + go eta) + (fix1 + (\go + ds -> + force + (case + ds + [ (delay z) + , (\y + ys -> + delay + ((\ds -> + (\ds + ds -> + (\k -> + (\a -> + fix1 + (\go + xs -> + force + (force + chooseList) + xs + (\ds -> + force + mkCons + (mkPairData + k + a) + [ ]) + (\ds -> + (\hd -> + (\tl -> + force + (force + ifThenElse + (equalsData + k + (force (force - mkCons - hd - (go - tl)))))) - (force - mkCons - cse)) - (mkPairData - k - a)) - ds) - (bData - ds)) - (iData ds)) - (encodeUtf8 - (concatBuiltinStrings - (`$fShowBuiltinByteString_$cshowsPrec` - 0 - y - (constr 0 - [ ]))))) - (addInteger n y) - (go ys))) ])))) - (force mkCons - (mkPairData (iData n) (B #30)) - []) - (`$fEnumBool_$cenumFromTo` 1 10))) - (fix1 - (\delete' k m -> - matchList - m - [] - (\hd tl -> - force - (force ifThenElse - (equalsData - k - (force (force fstPair) hd)) - (delay tl) - (delay - (force mkCons - hd - (delete' k tl)))))))) - (\l nilCase consCase -> - force (force chooseList) - l - (\ds -> nilCase) - (\ds -> - consCase - (force headList l) - (force tailList l)) - (constr 0 []))) + fstPair) + hd)) + (delay + (force + mkCons + (mkPairData + k + a) + tl)) + (delay + (force + mkCons + hd + (go + tl))))) + (force + tailList + xs)) + (force + headList + xs)) + (constr 0 + [ ])) + ds) + (bData ds)) + (iData ds)) + (encodeUtf8 + (concatBuiltinStrings + (`$fShowBuiltinByteString_$cshowsPrec` + 0 + y + (constr 0 + [ ]))))) + (addInteger n y) + (go ys))) ])))) + (force mkCons + (mkPairData (iData n) (B #30)) + []) + (`$fEnumBool_$cenumFromTo` 1 10))) + (fix1 + (\delete' k m -> + force (force chooseList) + m + (\ds -> []) + (\ds -> + (\hd -> + (\tl -> + force + (force ifThenElse + (equalsData + k + (force (force fstPair) + hd)) + (delay tl) + (delay + (force mkCons + hd + (delete' k tl))))) + (force tailList m)) + (force headList m)) + (constr 0 [])))) (fix1 (\concatBuiltinStrings ds -> @@ -408,4 +412,4 @@ program (constr 1 [x, (`$fEnumBool_$cenumFromTo` (addInteger 1 x) lim)])) (delay (constr 0 [])))))) - (\f -> (\s -> s s) (\s x -> f (s s) x))) \ No newline at end of file + (\f -> (\s -> s s) (\s -> f (\x -> s s x)))) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Budget/9.6/map2-budget.budget.golden b/plutus-tx-plugin/test/Budget/9.6/map2-budget.budget.golden index 102157ec94e..2c63bc124a1 100644 --- a/plutus-tx-plugin/test/Budget/9.6/map2-budget.budget.golden +++ b/plutus-tx-plugin/test/Budget/9.6/map2-budget.budget.golden @@ -1,2 +1,2 @@ -({cpu: 160633417 -| mem: 416622}) \ No newline at end of file +({cpu: 155458417 +| mem: 394122}) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Budget/9.6/map2.pir.golden b/plutus-tx-plugin/test/Budget/9.6/map2.pir.golden index 8289ed83adf..c735c68c517 100644 --- a/plutus-tx-plugin/test/Budget/9.6/map2.pir.golden +++ b/plutus-tx-plugin/test/Budget/9.6/map2.pir.golden @@ -50,23 +50,12 @@ let data (Maybe :: * -> *) a | Maybe_match where Just : a -> Maybe a Nothing : Maybe a - !matchList : all a r. list a -> r -> (a -> list a -> r) -> r - = /\a r -> - \(l : list a) (nilCase : r) (consCase : a -> list a -> r) -> - chooseList - {a} - {Unit -> r} - l - (\(ds : Unit) -> nilCase) - (\(ds : Unit) -> consCase (headList {a} l) (tailList {a} l)) - Unit data Bool | Bool_match where True : Bool False : Bool in letrec - !`$fToBuiltinListBuiltinList_$ctoBuiltin` : - List (Tuple2 data data) -> list (pair data data) + !goList : List (Tuple2 data data) -> list (pair data data) = \(ds : List (Tuple2 data data)) -> List_match {Tuple2 data data} @@ -83,7 +72,7 @@ letrec d {pair data data} (\(d : data) (d : data) -> mkPairData d d)) - (`$fToBuiltinListBuiltinList_$ctoBuiltin` ds)) + (goList ds)) {all dead. dead} in let @@ -123,7 +112,10 @@ let {all dead. dead} in \(eta : List (Tuple2 k a)) -> - `$fToBuiltinListBuiltinList_$ctoBuiltin` (go eta) + let + !eta : List (Tuple2 data data) = go eta + in + goList eta in \(n : integer) -> let @@ -165,13 +157,15 @@ in letrec !go : list (pair data data) -> list (pair data data) = \(xs : list (pair data data)) -> - matchList + chooseList {pair data data} - {list (pair data data)} + {Unit -> list (pair data data)} xs - [] - (\(hd : pair data data) (tl : list (pair data data)) -> + (\(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 @@ -215,6 +209,7 @@ in (go tl)) (/\dead -> mkCons {pair data data} (mkPairData k' v') (go tl)) {all dead. dead}) + Unit in let !nt : list (pair data data) @@ -257,14 +252,16 @@ in letrec !go : list (pair data data) -> list (pair data data) = \(xs : list (pair data data)) -> - matchList + chooseList {pair data data} - {list (pair data data)} + {Unit -> list (pair data data)} xs - [] - (\(hd : pair data data) (tl : list (pair data data)) -> + (\(ds : Unit) -> []) + (\(ds : Unit) -> let - !tl' : list (pair data data) = go tl + !hd : pair data data = headList {pair data data} xs + !tl' : list (pair data data) + = go (tailList {pair data data} xs) in Bool_match (let @@ -302,6 +299,7 @@ in (/\dead -> tl') (/\dead -> mkCons {pair data data} hd tl') {all dead. dead}) + Unit in let !nt : list (pair data data) diff --git a/plutus-tx-plugin/test/Budget/9.6/map2.uplc.golden b/plutus-tx-plugin/test/Budget/9.6/map2.uplc.golden index c3b5c686f66..f1bf99b0f21 100644 --- a/plutus-tx-plugin/test/Budget/9.6/map2.uplc.golden +++ b/plutus-tx-plugin/test/Budget/9.6/map2.uplc.golden @@ -3,47 +3,47 @@ program ((\fix1 -> (\go -> (\go -> - (\matchList -> - (\`$fToBuiltinListBuiltinList_$ctoBuiltin` - n -> - (\unsafeFromList -> + (\goList + n -> + (\unsafeFromList -> + (\cse -> (\cse -> - (\cse -> - (\nt -> - (\go -> + (\nt -> + (\go -> + (\nt -> (\nt -> - (\nt -> - fix1 + fix1 + (\go + ds -> + force + (case + ds + [ (delay (constr 0 [])) + , (\x + xs -> + delay + (constr 1 + [ (case + x + [ (\k + v -> + constr 0 + [ k + , (decodeUtf8 + v) ]) ]) + , (go xs) ])) ])) + (go nt)) + ((\rs' -> + (\ls' -> go rs' ls') (go nt)) + (fix1 (\go - ds -> + xs -> force - (case - ds - [ (delay (constr 0 [])) - , (\x - xs -> - delay - (constr 1 - [ (case - x - [ (\k - v -> - constr 0 - [ k - , (decodeUtf8 - v) ]) ]) - , (go xs) ])) ])) - (go nt)) - ((\rs' -> - (\ls' -> go rs' ls') (go nt)) - (fix1 - (\go - xs -> - matchList - xs - [] - (\hd - tl -> + (force chooseList) + xs + (\ds -> []) + (\ds -> + (\hd -> (\tl' -> force (case @@ -94,155 +94,155 @@ program (force mkCons hd tl')) ])) - (go tl))) - nt))) - (unsafeFromList - (\i -> iData i) - bData - (constr 1 - [ (constr 0 - [(addInteger 1 n), #6f6e65]) - , (constr 1 - [ (constr 0 - [(addInteger 2 n), #74776f]) - , (constr 1 - [ (constr 0 - [cse, #7468726565]) - , (constr 1 - [ (constr 0 - [cse, #666f7572]) - , (constr 1 - [ (constr 0 - [ (addInteger - 5 - n) - , #66697665 ]) - , (constr 0 - [ ]) ]) ]) ]) ]) ]))) - (fix1 - (\go - xs -> - matchList - xs - [] - (\hd - tl -> - (\v' -> - (\k' -> - force - (case - (fix1 - (\go - xs -> - force - (force chooseList) - xs - (\ds -> - constr 1 []) - (\ds -> - (\hd -> - force - (force - ifThenElse - (equalsData - k' - (force - (force - fstPair) - hd)) - (delay - ((\ds -> - constr 0 - [ (force - (force - sndPair) - hd) ]) + (go (force tailList xs))) + (force headList xs)) + (constr 0 [])) + nt))) + (unsafeFromList + (\i -> iData i) + bData + (constr 1 + [ (constr 0 [(addInteger 1 n), #6f6e65]) + , (constr 1 + [ (constr 0 + [(addInteger 2 n), #74776f]) + , (constr 1 + [ (constr 0 [cse, #7468726565]) + , (constr 1 + [ (constr 0 + [cse, #666f7572]) + , (constr 1 + [ (constr 0 + [ (addInteger + 5 + n) + , #66697665 ]) + , (constr 0 + [ ]) ]) ]) ]) ]) ]))) + (fix1 + (\go + xs -> + force + (force chooseList) + xs + (\ds -> []) + (\ds -> + (\hd -> + (\tl -> + (\v' -> + (\k' -> + force + (case + (fix1 + (\go + xs -> + force + (force + chooseList) + xs + (\ds -> + constr 1 []) + (\ds -> + (\hd -> + force + (force + ifThenElse + (equalsData + k' (force - tailList - xs))) - (delay - (go - (force - tailList - xs))))) - (force - headList - xs)) - (constr 0 [])) - nt) - [ (\r -> - delay - (force - mkCons - (mkPairData - k' - (bData - (appendByteString - (unBData - v') - (unBData - r)))) - (go tl))) - , (delay - (force mkCons - (mkPairData k' v') - (go tl))) ])) - (force (force fstPair) hd)) - (force (force sndPair) hd))))) - (unsafeFromList - (\i -> iData i) - bData - (constr 1 - [ (constr 0 [cse, #5448524545]) - , (constr 1 - [ (constr 0 [cse, #464f5552]) - , (constr 1 - [ (constr 0 - [(addInteger 6 n), #534958]) - , (constr 1 - [ (constr 0 - [ (addInteger 7 n) - , #534556454e ]) - , (constr 0 []) ]) ]) ]) ]))) - (addInteger 4 n)) - (addInteger 3 n)) - (\`$dToData` `$dToData` -> - (\go eta -> - `$fToBuiltinListBuiltinList_$ctoBuiltin` (go eta)) - (fix1 - (\go ds -> - force - (case - ds - [ (delay (constr 0 [])) - , (\x xs -> - delay - (constr 1 - [ (case - x - [ (\k a -> - constr 0 - [ (`$dToData` k) - , (`$dToData` a) ]) ]) - , (go xs) ])) ]))))) - (fix1 - (\`$fToBuiltinListBuiltinList_$ctoBuiltin` ds -> - force - (case - ds - [ (delay []) - , (\d ds -> - delay - (force mkCons - (case d [(\d d -> mkPairData d d)]) - (`$fToBuiltinListBuiltinList_$ctoBuiltin` - ds))) ])))) - (\l nilCase consCase -> - force (force chooseList) - l - (\ds -> nilCase) - (\ds -> consCase (force headList l) (force tailList l)) - (constr 0 []))) + (force + fstPair) + hd)) + (delay + ((\ds -> + constr 0 + [ (force + (force + sndPair) + hd) ]) + (force + tailList + xs))) + (delay + (go + (force + tailList + xs))))) + (force + headList + xs)) + (constr 0 [])) + nt) + [ (\r -> + delay + (force + mkCons + (mkPairData + k' + (bData + (appendByteString + (unBData + v') + (unBData + r)))) + (go tl))) + , (delay + (force mkCons + (mkPairData + k' + v') + (go tl))) ])) + (force (force fstPair) hd)) + (force (force sndPair) hd)) + (force tailList xs)) + (force headList xs)) + (constr 0 [])))) + (unsafeFromList + (\i -> iData i) + bData + (constr 1 + [ (constr 0 [cse, #5448524545]) + , (constr 1 + [ (constr 0 [cse, #464f5552]) + , (constr 1 + [ (constr 0 + [(addInteger 6 n), #534958]) + , (constr 1 + [ (constr 0 + [ (addInteger 7 n) + , #534556454e ]) + , (constr 0 []) ]) ]) ]) ]))) + (addInteger 4 n)) + (addInteger 3 n)) + (\`$dToData` `$dToData` -> + (\go eta -> goList (go eta)) + (fix1 + (\go ds -> + force + (case + ds + [ (delay (constr 0 [])) + , (\x xs -> + delay + (constr 1 + [ (case + x + [ (\k a -> + constr 0 + [ (`$dToData` k) + , (`$dToData` a) ]) ]) + , (go xs) ])) ]))))) + (fix1 + (\goList ds -> + force + (case + ds + [ (delay []) + , (\d ds -> + delay + (force mkCons + (case d [(\d d -> mkPairData d d)]) + (goList ds))) ])))) (fix1 (\go acc xs -> force (force chooseList) @@ -269,4 +269,4 @@ program (force tailList xs)) (force headList xs)) (constr 0 [])))) - (\f -> (\s -> s s) (\s x -> f (s s) x))) \ No newline at end of file + (\f -> (\s -> s s) (\s -> f (\x -> s s x)))) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Budget/9.6/map3-budget.budget.golden b/plutus-tx-plugin/test/Budget/9.6/map3-budget.budget.golden index 102157ec94e..2c63bc124a1 100644 --- a/plutus-tx-plugin/test/Budget/9.6/map3-budget.budget.golden +++ b/plutus-tx-plugin/test/Budget/9.6/map3-budget.budget.golden @@ -1,2 +1,2 @@ -({cpu: 160633417 -| mem: 416622}) \ No newline at end of file +({cpu: 155458417 +| mem: 394122}) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Budget/9.6/map3.pir.golden b/plutus-tx-plugin/test/Budget/9.6/map3.pir.golden index 8289ed83adf..c735c68c517 100644 --- a/plutus-tx-plugin/test/Budget/9.6/map3.pir.golden +++ b/plutus-tx-plugin/test/Budget/9.6/map3.pir.golden @@ -50,23 +50,12 @@ let data (Maybe :: * -> *) a | Maybe_match where Just : a -> Maybe a Nothing : Maybe a - !matchList : all a r. list a -> r -> (a -> list a -> r) -> r - = /\a r -> - \(l : list a) (nilCase : r) (consCase : a -> list a -> r) -> - chooseList - {a} - {Unit -> r} - l - (\(ds : Unit) -> nilCase) - (\(ds : Unit) -> consCase (headList {a} l) (tailList {a} l)) - Unit data Bool | Bool_match where True : Bool False : Bool in letrec - !`$fToBuiltinListBuiltinList_$ctoBuiltin` : - List (Tuple2 data data) -> list (pair data data) + !goList : List (Tuple2 data data) -> list (pair data data) = \(ds : List (Tuple2 data data)) -> List_match {Tuple2 data data} @@ -83,7 +72,7 @@ letrec d {pair data data} (\(d : data) (d : data) -> mkPairData d d)) - (`$fToBuiltinListBuiltinList_$ctoBuiltin` ds)) + (goList ds)) {all dead. dead} in let @@ -123,7 +112,10 @@ let {all dead. dead} in \(eta : List (Tuple2 k a)) -> - `$fToBuiltinListBuiltinList_$ctoBuiltin` (go eta) + let + !eta : List (Tuple2 data data) = go eta + in + goList eta in \(n : integer) -> let @@ -165,13 +157,15 @@ in letrec !go : list (pair data data) -> list (pair data data) = \(xs : list (pair data data)) -> - matchList + chooseList {pair data data} - {list (pair data data)} + {Unit -> list (pair data data)} xs - [] - (\(hd : pair data data) (tl : list (pair data data)) -> + (\(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 @@ -215,6 +209,7 @@ in (go tl)) (/\dead -> mkCons {pair data data} (mkPairData k' v') (go tl)) {all dead. dead}) + Unit in let !nt : list (pair data data) @@ -257,14 +252,16 @@ in letrec !go : list (pair data data) -> list (pair data data) = \(xs : list (pair data data)) -> - matchList + chooseList {pair data data} - {list (pair data data)} + {Unit -> list (pair data data)} xs - [] - (\(hd : pair data data) (tl : list (pair data data)) -> + (\(ds : Unit) -> []) + (\(ds : Unit) -> let - !tl' : list (pair data data) = go tl + !hd : pair data data = headList {pair data data} xs + !tl' : list (pair data data) + = go (tailList {pair data data} xs) in Bool_match (let @@ -302,6 +299,7 @@ in (/\dead -> tl') (/\dead -> mkCons {pair data data} hd tl') {all dead. dead}) + Unit in let !nt : list (pair data data) diff --git a/plutus-tx-plugin/test/Budget/9.6/map3.uplc.golden b/plutus-tx-plugin/test/Budget/9.6/map3.uplc.golden index c3b5c686f66..f1bf99b0f21 100644 --- a/plutus-tx-plugin/test/Budget/9.6/map3.uplc.golden +++ b/plutus-tx-plugin/test/Budget/9.6/map3.uplc.golden @@ -3,47 +3,47 @@ program ((\fix1 -> (\go -> (\go -> - (\matchList -> - (\`$fToBuiltinListBuiltinList_$ctoBuiltin` - n -> - (\unsafeFromList -> + (\goList + n -> + (\unsafeFromList -> + (\cse -> (\cse -> - (\cse -> - (\nt -> - (\go -> + (\nt -> + (\go -> + (\nt -> (\nt -> - (\nt -> - fix1 + fix1 + (\go + ds -> + force + (case + ds + [ (delay (constr 0 [])) + , (\x + xs -> + delay + (constr 1 + [ (case + x + [ (\k + v -> + constr 0 + [ k + , (decodeUtf8 + v) ]) ]) + , (go xs) ])) ])) + (go nt)) + ((\rs' -> + (\ls' -> go rs' ls') (go nt)) + (fix1 (\go - ds -> + xs -> force - (case - ds - [ (delay (constr 0 [])) - , (\x - xs -> - delay - (constr 1 - [ (case - x - [ (\k - v -> - constr 0 - [ k - , (decodeUtf8 - v) ]) ]) - , (go xs) ])) ])) - (go nt)) - ((\rs' -> - (\ls' -> go rs' ls') (go nt)) - (fix1 - (\go - xs -> - matchList - xs - [] - (\hd - tl -> + (force chooseList) + xs + (\ds -> []) + (\ds -> + (\hd -> (\tl' -> force (case @@ -94,155 +94,155 @@ program (force mkCons hd tl')) ])) - (go tl))) - nt))) - (unsafeFromList - (\i -> iData i) - bData - (constr 1 - [ (constr 0 - [(addInteger 1 n), #6f6e65]) - , (constr 1 - [ (constr 0 - [(addInteger 2 n), #74776f]) - , (constr 1 - [ (constr 0 - [cse, #7468726565]) - , (constr 1 - [ (constr 0 - [cse, #666f7572]) - , (constr 1 - [ (constr 0 - [ (addInteger - 5 - n) - , #66697665 ]) - , (constr 0 - [ ]) ]) ]) ]) ]) ]))) - (fix1 - (\go - xs -> - matchList - xs - [] - (\hd - tl -> - (\v' -> - (\k' -> - force - (case - (fix1 - (\go - xs -> - force - (force chooseList) - xs - (\ds -> - constr 1 []) - (\ds -> - (\hd -> - force - (force - ifThenElse - (equalsData - k' - (force - (force - fstPair) - hd)) - (delay - ((\ds -> - constr 0 - [ (force - (force - sndPair) - hd) ]) + (go (force tailList xs))) + (force headList xs)) + (constr 0 [])) + nt))) + (unsafeFromList + (\i -> iData i) + bData + (constr 1 + [ (constr 0 [(addInteger 1 n), #6f6e65]) + , (constr 1 + [ (constr 0 + [(addInteger 2 n), #74776f]) + , (constr 1 + [ (constr 0 [cse, #7468726565]) + , (constr 1 + [ (constr 0 + [cse, #666f7572]) + , (constr 1 + [ (constr 0 + [ (addInteger + 5 + n) + , #66697665 ]) + , (constr 0 + [ ]) ]) ]) ]) ]) ]))) + (fix1 + (\go + xs -> + force + (force chooseList) + xs + (\ds -> []) + (\ds -> + (\hd -> + (\tl -> + (\v' -> + (\k' -> + force + (case + (fix1 + (\go + xs -> + force + (force + chooseList) + xs + (\ds -> + constr 1 []) + (\ds -> + (\hd -> + force + (force + ifThenElse + (equalsData + k' (force - tailList - xs))) - (delay - (go - (force - tailList - xs))))) - (force - headList - xs)) - (constr 0 [])) - nt) - [ (\r -> - delay - (force - mkCons - (mkPairData - k' - (bData - (appendByteString - (unBData - v') - (unBData - r)))) - (go tl))) - , (delay - (force mkCons - (mkPairData k' v') - (go tl))) ])) - (force (force fstPair) hd)) - (force (force sndPair) hd))))) - (unsafeFromList - (\i -> iData i) - bData - (constr 1 - [ (constr 0 [cse, #5448524545]) - , (constr 1 - [ (constr 0 [cse, #464f5552]) - , (constr 1 - [ (constr 0 - [(addInteger 6 n), #534958]) - , (constr 1 - [ (constr 0 - [ (addInteger 7 n) - , #534556454e ]) - , (constr 0 []) ]) ]) ]) ]))) - (addInteger 4 n)) - (addInteger 3 n)) - (\`$dToData` `$dToData` -> - (\go eta -> - `$fToBuiltinListBuiltinList_$ctoBuiltin` (go eta)) - (fix1 - (\go ds -> - force - (case - ds - [ (delay (constr 0 [])) - , (\x xs -> - delay - (constr 1 - [ (case - x - [ (\k a -> - constr 0 - [ (`$dToData` k) - , (`$dToData` a) ]) ]) - , (go xs) ])) ]))))) - (fix1 - (\`$fToBuiltinListBuiltinList_$ctoBuiltin` ds -> - force - (case - ds - [ (delay []) - , (\d ds -> - delay - (force mkCons - (case d [(\d d -> mkPairData d d)]) - (`$fToBuiltinListBuiltinList_$ctoBuiltin` - ds))) ])))) - (\l nilCase consCase -> - force (force chooseList) - l - (\ds -> nilCase) - (\ds -> consCase (force headList l) (force tailList l)) - (constr 0 []))) + (force + fstPair) + hd)) + (delay + ((\ds -> + constr 0 + [ (force + (force + sndPair) + hd) ]) + (force + tailList + xs))) + (delay + (go + (force + tailList + xs))))) + (force + headList + xs)) + (constr 0 [])) + nt) + [ (\r -> + delay + (force + mkCons + (mkPairData + k' + (bData + (appendByteString + (unBData + v') + (unBData + r)))) + (go tl))) + , (delay + (force mkCons + (mkPairData + k' + v') + (go tl))) ])) + (force (force fstPair) hd)) + (force (force sndPair) hd)) + (force tailList xs)) + (force headList xs)) + (constr 0 [])))) + (unsafeFromList + (\i -> iData i) + bData + (constr 1 + [ (constr 0 [cse, #5448524545]) + , (constr 1 + [ (constr 0 [cse, #464f5552]) + , (constr 1 + [ (constr 0 + [(addInteger 6 n), #534958]) + , (constr 1 + [ (constr 0 + [ (addInteger 7 n) + , #534556454e ]) + , (constr 0 []) ]) ]) ]) ]))) + (addInteger 4 n)) + (addInteger 3 n)) + (\`$dToData` `$dToData` -> + (\go eta -> goList (go eta)) + (fix1 + (\go ds -> + force + (case + ds + [ (delay (constr 0 [])) + , (\x xs -> + delay + (constr 1 + [ (case + x + [ (\k a -> + constr 0 + [ (`$dToData` k) + , (`$dToData` a) ]) ]) + , (go xs) ])) ]))))) + (fix1 + (\goList ds -> + force + (case + ds + [ (delay []) + , (\d ds -> + delay + (force mkCons + (case d [(\d d -> mkPairData d d)]) + (goList ds))) ])))) (fix1 (\go acc xs -> force (force chooseList) @@ -269,4 +269,4 @@ program (force tailList xs)) (force headList xs)) (constr 0 [])))) - (\f -> (\s -> s s) (\s x -> f (s s) x))) \ No newline at end of file + (\f -> (\s -> s s) (\s -> f (\x -> s s x)))) \ No newline at end of file diff --git a/plutus-tx/src/PlutusTx/IsData/Instances.hs b/plutus-tx/src/PlutusTx/IsData/Instances.hs index 24ed9a19ca8..ad0dbf5b5d4 100644 --- a/plutus-tx/src/PlutusTx/IsData/Instances.hs +++ b/plutus-tx/src/PlutusTx/IsData/Instances.hs @@ -19,7 +19,7 @@ import PlutusTx.These (These (..)) makeIsDataIndexed ''Bool [('False,0),('True,1)] makeIsDataIndexed ''Maybe [('Just,0),('Nothing,1)] makeIsDataIndexed ''Either [('Left,0),('Right,1)] -makeIsDataIndexed ''These [('This,1),('That,2),('These,3)] +makeIsDataIndexed ''These [('This,0),('That,1),('These,2)] -- Okay to use unstableMakeIsData here since there's only one alternative and we're sure -- that will never change. From 361cba39b6cb9ded045a526ed14161e58d96fc16 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Tue, 21 May 2024 16:38:46 +0300 Subject: [PATCH 39/41] Fix delete implementation Signed-off-by: Ana Pantilie --- .../test/Budget/9.6/map1-budget.budget.golden | 4 +- .../test/Budget/9.6/map1.pir.golden | 50 +-- .../test/Budget/9.6/map1.uplc.golden | 367 +++++++++--------- plutus-tx/src/PlutusTx/Data/AssocMap.hs | 12 +- 4 files changed, 215 insertions(+), 218 deletions(-) diff --git a/plutus-tx-plugin/test/Budget/9.6/map1-budget.budget.golden b/plutus-tx-plugin/test/Budget/9.6/map1-budget.budget.golden index 86ad2362090..3a0c427ec3e 100644 --- a/plutus-tx-plugin/test/Budget/9.6/map1-budget.budget.golden +++ b/plutus-tx-plugin/test/Budget/9.6/map1-budget.budget.golden @@ -1,2 +1,2 @@ -({cpu: 390652748 -| mem: 872009}) \ No newline at end of file +({cpu: 390169748 +| mem: 869909}) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Budget/9.6/map1.pir.golden b/plutus-tx-plugin/test/Budget/9.6/map1.pir.golden index 3598b6e089e..dc42876c182 100644 --- a/plutus-tx-plugin/test/Budget/9.6/map1.pir.golden +++ b/plutus-tx-plugin/test/Budget/9.6/map1.pir.golden @@ -222,29 +222,6 @@ in let data Unit | Unit_match where Unit : Unit -in -letrec - !delete' : data -> list (pair data data) -> list (pair data data) - = \(k : data) (m : list (pair data data)) -> - chooseList - {pair data data} - {Unit -> list (pair data data)} - m - (\(ds : Unit) -> []) - (\(ds : Unit) -> - let - !hd : pair data data = headList {pair data data} m - !tl : list (pair data data) = tailList {pair data data} m - in - ifThenElse - {all dead. list (pair data data)} - (equalsData k (fstPair {data} {data} hd)) - (/\dead -> tl) - (/\dead -> mkCons {pair data data} hd (delete' k tl)) - {all dead. dead}) - Unit -in -let data (Maybe :: * -> *) a | Maybe_match where Just : a -> Maybe a Nothing : Maybe a @@ -363,7 +340,32 @@ in go ds) (mkCons {pair data data} (mkPairData (iData n) (B #30)) []) (`$fEnumBool_$cenumFromTo` 1 10) - !nt : list (pair data data) = delete' (iData (addInteger 5 n)) nt + !nt : list (pair data data) + = let + !k : data = iData (addInteger 5 n) + 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) -> []) + (\(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 -> tl) + (/\dead -> mkCons {pair data data} hd (go tl)) + {all dead. dead}) + Unit + in + go nt in Tuple5 {Maybe bytestring} diff --git a/plutus-tx-plugin/test/Budget/9.6/map1.uplc.golden b/plutus-tx-plugin/test/Budget/9.6/map1.uplc.golden index b1d2b4e885b..9553f47f06b 100644 --- a/plutus-tx-plugin/test/Budget/9.6/map1.uplc.golden +++ b/plutus-tx-plugin/test/Budget/9.6/map1.uplc.golden @@ -7,195 +7,192 @@ program (\`$fShowBuiltinByteString_$cshowsPrec` -> (\go -> (\go -> - (\concatBuiltinStrings -> - (\delete' - n -> - (\nt -> - (\cse -> - (\nt -> - (\lookup -> - constr 0 - [ (lookup - (\i -> iData i) - unBData - n - nt) - , (lookup - (\i -> iData i) - unBData - cse - nt) - , (lookup - (\i -> iData i) - unBData - (addInteger 10 n) - nt) - , (lookup - (\i -> iData i) - unBData - (addInteger 20 n) - nt) - , (lookup - (\i -> iData i) - unBData - cse - nt) ]) - (\`$dToData` - `$dUnsafeFromData` - ds - ds -> - force - (case - ((\k -> - fix1 - (\go - xs -> - force - (force chooseList) - xs - (\ds -> constr 1 []) - (\ds -> - (\hd -> - force - (force - ifThenElse - (equalsData - k + (\concatBuiltinStrings + n -> + (\nt -> + (\cse -> + (\nt -> + (\lookup -> + constr 0 + [ (lookup (\i -> iData i) unBData n nt) + , (lookup + (\i -> iData i) + unBData + cse + nt) + , (lookup + (\i -> iData i) + unBData + (addInteger 10 n) + nt) + , (lookup + (\i -> iData i) + unBData + (addInteger 20 n) + nt) + , (lookup + (\i -> iData i) + unBData + cse + nt) ]) + (\`$dToData` + `$dUnsafeFromData` + ds + ds -> + force + (case + ((\k -> + fix1 + (\go + xs -> + force + (force chooseList) + xs + (\ds -> constr 1 []) + (\ds -> + (\hd -> + force + (force + ifThenElse + (equalsData + k + (force (force - (force - fstPair) - hd)) - (delay - ((\ds -> - constr 0 - [ (force - (force - sndPair) - hd) ]) - (force - tailList - xs))) - (delay - (go - (force - tailList - xs))))) - (force headList - xs)) - (constr 0 [])) - ds) - (`$dToData` ds)) - [ (\a -> - delay - (constr 0 - [ (`$dUnsafeFromData` - a) ])) - , (delay (constr 1 [])) ]))) - (delete' (iData cse) nt)) - (addInteger 5 n)) - ((\z -> - (\go eta -> - go eta) - (fix1 - (\go - ds -> - force - (case - ds - [ (delay z) - , (\y - ys -> - delay - ((\ds -> - (\ds - ds -> - (\k -> - (\a -> - fix1 - (\go - xs -> - force - (force - chooseList) - xs - (\ds -> - force - mkCons - (mkPairData - k - a) - [ ]) - (\ds -> - (\hd -> - (\tl -> - force - (force - ifThenElse - (equalsData - k - (force - (force - fstPair) - hd)) - (delay - (force - mkCons - (mkPairData - k - a) - tl)) - (delay - (force - mkCons - hd - (go - tl))))) + fstPair) + hd)) + (delay + ((\ds -> + constr 0 + [ (force + (force + sndPair) + hd) ]) + (force + tailList + xs))) + (delay + (go + (force + tailList + xs))))) + (force headList + xs)) + (constr 0 [])) + ds) + (`$dToData` ds)) + [ (\a -> + delay + (constr 0 + [ (`$dUnsafeFromData` + a) ])) + , (delay (constr 1 [])) ]))) + ((\k -> + fix1 + (\go xs -> + force (force chooseList) + xs + (\ds -> []) + (\ds -> + (\hd -> + (\tl -> + force + (force ifThenElse + (equalsData + k + (force + (force + fstPair) + hd)) + (delay tl) + (delay + (force mkCons + hd + (go tl))))) + (force tailList xs)) + (force headList xs)) + (constr 0 [])) + nt) + (iData cse))) + (addInteger 5 n)) + ((\z -> + (\go eta -> + go eta) + (fix1 + (\go + ds -> + force + (case + ds + [ (delay z) + , (\y + ys -> + delay + ((\ds -> + (\ds + ds -> + (\k -> + (\a -> + fix1 + (\go + xs -> + force + (force + chooseList) + xs + (\ds -> + force + mkCons + (mkPairData + k + a) + [ ]) + (\ds -> + (\hd -> + (\tl -> + force (force - tailList - xs)) + ifThenElse + (equalsData + k + (force + (force + fstPair) + hd)) + (delay + (force + mkCons + (mkPairData + k + a) + tl)) + (delay + (force + mkCons + hd + (go + tl))))) (force - headList + tailList xs)) - (constr 0 - [ ])) - ds) - (bData ds)) - (iData ds)) - (encodeUtf8 - (concatBuiltinStrings - (`$fShowBuiltinByteString_$cshowsPrec` - 0 - y - (constr 0 - [ ]))))) - (addInteger n y) - (go ys))) ])))) - (force mkCons - (mkPairData (iData n) (B #30)) - []) - (`$fEnumBool_$cenumFromTo` 1 10))) - (fix1 - (\delete' k m -> - force (force chooseList) - m - (\ds -> []) - (\ds -> - (\hd -> - (\tl -> - force - (force ifThenElse - (equalsData - k - (force (force fstPair) - hd)) - (delay tl) - (delay - (force mkCons - hd - (delete' k tl))))) - (force tailList m)) - (force headList m)) - (constr 0 [])))) + (force + headList + xs)) + (constr 0 + [])) + ds) + (bData ds)) + (iData ds)) + (encodeUtf8 + (concatBuiltinStrings + (`$fShowBuiltinByteString_$cshowsPrec` + 0 + y + (constr 0 + []))))) + (addInteger n y) + (go ys))) ])))) + (force mkCons (mkPairData (iData n) (B #30)) []) + (`$fEnumBool_$cenumFromTo` 1 10))) (fix1 (\concatBuiltinStrings ds -> diff --git a/plutus-tx/src/PlutusTx/Data/AssocMap.hs b/plutus-tx/src/PlutusTx/Data/AssocMap.hs index e132426b79f..efe717f08cb 100644 --- a/plutus-tx/src/PlutusTx/Data/AssocMap.hs +++ b/plutus-tx/src/PlutusTx/Data/AssocMap.hs @@ -166,7 +166,7 @@ delete' k m = go m let k' = BI.fst hd in if P.equalsData k k' then tl - else BI.mkCons hd (delete' k tl) + else BI.mkCons hd (go tl) ) {-# INLINEABLE singleton #-} @@ -193,15 +193,13 @@ safeFromList :: forall k a . (Eq k, P.ToData k, P.ToData a) => [(k, a)] -> Map k safeFromList = Map . toOpaque - . PlutusTx.Prelude.map (\(k, a) -> (P.toBuiltinData k, P.toBuiltinData a)) . foldr (uncurry go) [] where - go :: k -> a -> [(k, a)] -> [(k, a)] - go k v [] = [(k, v)] + go k v [] = [(P.toBuiltinData k, P.toBuiltinData v)] go k v ((k', v') : rest) = - if k == k' - then (k, v) : rest - else (k', v') : go k v rest + if P.toBuiltinData k == k' + then (P.toBuiltinData k, P.toBuiltinData v) : go k v rest + else (P.toBuiltinData k', P.toBuiltinData v') : go k v rest {-# INLINEABLE unsafeFromList #-} -- | Unsafely create an 'Map' from a list of pairs. From 72334a58256ee7b051dabbf4353b596b5270c6ac Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Tue, 21 May 2024 16:41:48 +0300 Subject: [PATCH 40/41] Fix redundancy Signed-off-by: Ana Pantilie --- plutus-tx/src/PlutusTx/Data/AssocMap.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plutus-tx/src/PlutusTx/Data/AssocMap.hs b/plutus-tx/src/PlutusTx/Data/AssocMap.hs index efe717f08cb..c5b66e982d2 100644 --- a/plutus-tx/src/PlutusTx/Data/AssocMap.hs +++ b/plutus-tx/src/PlutusTx/Data/AssocMap.hs @@ -189,7 +189,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 . (Eq k, 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 c5c85ed0617261262973d68ab423cf279b4e2328 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Tue, 21 May 2024 17:25:28 +0300 Subject: [PATCH 41/41] Address other review comments Signed-off-by: Ana Pantilie --- plutus-tx/src/PlutusTx/Builtins.hs | 2 +- plutus-tx/src/PlutusTx/Data/AssocMap.hs | 13 +++++++------ 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/plutus-tx/src/PlutusTx/Builtins.hs b/plutus-tx/src/PlutusTx/Builtins.hs index 68a65b074e7..5e9550d9bb6 100644 --- a/plutus-tx/src/PlutusTx/Builtins.hs +++ b/plutus-tx/src/PlutusTx/Builtins.hs @@ -391,7 +391,7 @@ encodeUtf8 = BI.encodeUtf8 {-# INLINABLE null #-} null :: forall a. BI.BuiltinList a -> Bool -null l = fromBuiltin (BI.null l) +null l = fromOpaque (BI.null l) {-# INLINABLE matchList #-} matchList :: forall a r . BI.BuiltinList a -> (() -> r) -> (a -> BI.BuiltinList a -> r) -> r diff --git a/plutus-tx/src/PlutusTx/Data/AssocMap.hs b/plutus-tx/src/PlutusTx/Data/AssocMap.hs index c5b66e982d2..48712bd3274 100644 --- a/plutus-tx/src/PlutusTx/Data/AssocMap.hs +++ b/plutus-tx/src/PlutusTx/Data/AssocMap.hs @@ -43,9 +43,9 @@ This implementation has the following characteristics: * The `P.toBuiltinData` and `P.unsafeFromBuiltinData` operations are no-op. * Other operations are slower than @PlutusTx.AssocMap.Map@, although equality checks on keys can be faster due to `P.equalsData`. - * Many operations involve converting the keys and/or values to/from `P.BuiltinData`. + * Many operations involve converting the keys and\/or values to\/from `P.BuiltinData`. -Therefore this implementation is likely a better choice than @PlutusTx.AssocMap.Map@ +Therefore this implementation is likely a better choice than "PlutusTx.AssocMap.Map" if it is part of a data type defined using @asData@, and the key and value types have efficient `P.toBuiltinData` and `P.unsafeFromBuiltinData` operations (e.g., they are primitive types or types defined using @asData@). @@ -53,7 +53,8 @@ are primitive types or types defined using @asData@). A `Map` is considered well-defined if it has no duplicate keys. Most operations preserve the definedness of the resulting `Map` unless otherwise noted. It is important to observe that, in comparison to standard map implementations, -this implementation provides slow lookup and update operations. +this implementation provides slow lookup and update operations because it is based +on a list representation. -} newtype Map k a = Map (BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData)) deriving stock (Haskell.Eq, Haskell.Show) @@ -101,7 +102,7 @@ member :: forall k a. (P.ToData k) => k -> Map k a -> Bool member (P.toBuiltinData -> k) (Map m) = member' k m member' :: BuiltinData -> BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> Bool -member' k m = go m +member' k = go where go :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> Bool go xs = @@ -126,7 +127,7 @@ insert' -> BuiltinData -> BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -insert' k a m = go m +insert' k a = go where go :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> @@ -153,7 +154,7 @@ delete' :: BuiltinData -> BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -delete' k m = go m +delete' k = go where go :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) ->