diff --git a/flake.lock b/flake.lock index 66b5129daed..f0a1cbadfba 100644 --- a/flake.lock +++ b/flake.lock @@ -279,11 +279,11 @@ "hackage": { "flake": false, "locked": { - "lastModified": 1729124899, - "narHash": "sha256-cmb4iMcgk5+jUGMiZGNMzPCAnG17Kz9J6WIitYM17Fc=", + "lastModified": 1733963387, + "narHash": "sha256-jvsFZ+VbYB/hEqNuX9px8mH8xfoY4VAHZV9+VXcz/0w=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "138edf81c8bcc4209e9706966f7feece70c37a96", + "rev": "5c0fd51259ba86b2f81fe9d97f6dc09ebc7f5cf4", "type": "github" }, "original": { @@ -1097,4 +1097,4 @@ }, "root": "root", "version": 7 -} \ No newline at end of file +} diff --git a/plutus-tx-plugin/plutus-tx-plugin.cabal b/plutus-tx-plugin/plutus-tx-plugin.cabal index f872c951304..da06bd4345e 100644 --- a/plutus-tx-plugin/plutus-tx-plugin.cabal +++ b/plutus-tx-plugin/plutus-tx-plugin.cabal @@ -115,6 +115,7 @@ test-suite plutus-tx-plugin-tests hs-source-dirs: test main-is: Spec.hs other-modules: + Array.Spec AsData.Budget.Spec AsData.Budget.Types AssocMap.Spec @@ -166,7 +167,7 @@ test-suite plutus-tx-plugin-tests Unicode.Spec build-depends: - , base >=4.9 && <5 + , base >=4.9 && <5 , base16-bytestring , bytestring , containers @@ -190,6 +191,7 @@ test-suite plutus-tx-plugin-tests , template-haskell , text , these + , vector ^>=0.13.2 default-extensions: Strict ghc-options: -threaded -rtsopts -with-rtsopts=-N diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs index 367f3ba9644..6049cf4b507 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs @@ -239,6 +239,11 @@ builtinNames = [ , 'Builtins.mkNilPairData , 'Builtins.mkCons + , ''Builtins.BuiltinArray + , 'Builtins.lengthOfArray + , 'Builtins.listToArray + , 'Builtins.indexArray + , ''Builtins.BuiltinData , 'Builtins.chooseData , 'Builtins.caseData' @@ -460,6 +465,11 @@ defineBuiltinTerms = do PLC.MkNilPairData -> defineBuiltinInl 'Builtins.mkNilPairData PLC.MkCons -> defineBuiltinInl 'Builtins.mkCons + -- Arrays + PLC.LengthArray -> defineBuiltinInl 'Builtins.lengthOfArray + PLC.ListToArray -> defineBuiltinInl 'Builtins.listToArray + PLC.IndexArray -> defineBuiltinInl 'Builtins.indexArray + -- Data PLC.ChooseData -> defineBuiltinInl 'Builtins.chooseData PLC.EqualsData -> defineBuiltinInl 'Builtins.equalsData @@ -597,9 +607,7 @@ defineBuiltinTerms = do PLC.ExpModInteger -> defineBuiltinInl 'Builtins.expModInteger -defineBuiltinTypes - :: CompilingDefault uni fun m ann - => m () +defineBuiltinTypes :: CompilingDefault uni fun m ann => m () defineBuiltinTypes = do defineBuiltinType ''Builtins.BuiltinByteString . ($> annMayInline) $ PLC.toTypeAst $ Proxy @BS.ByteString defineBuiltinType ''Integer . ($> annMayInline) $ PLC.toTypeAst $ Proxy @Integer @@ -609,6 +617,7 @@ defineBuiltinTypes = do defineBuiltinType ''Builtins.BuiltinData . ($> annMayInline) $ PLC.toTypeAst $ Proxy @PLC.Data defineBuiltinType ''Builtins.BuiltinPair . ($> annMayInline) $ PLC.TyBuiltin () (PLC.SomeTypeIn PLC.DefaultUniProtoPair) defineBuiltinType ''Builtins.BuiltinList . ($> annMayInline) $ PLC.TyBuiltin () (PLC.SomeTypeIn PLC.DefaultUniProtoList) + defineBuiltinType ''Builtins.BuiltinArray . ($> annMayInline) $ PLC.TyBuiltin () (PLC.SomeTypeIn PLC.DefaultUniProtoArray) defineBuiltinType ''Builtins.BuiltinBLS12_381_G1_Element . ($> annMayInline) $ PLC.toTypeAst $ Proxy @BLS12_381.G1.Element defineBuiltinType ''Builtins.BuiltinBLS12_381_G2_Element . ($> annMayInline) $ PLC.toTypeAst $ Proxy @BLS12_381.G2.Element defineBuiltinType ''Builtins.BuiltinBLS12_381_MlResult . ($> annMayInline) $ PLC.toTypeAst $ Proxy @BLS12_381.Pairing.MlResult diff --git a/plutus-tx-plugin/test/Array/Spec.hs b/plutus-tx-plugin/test/Array/Spec.hs new file mode 100644 index 00000000000..3b734d9eac4 --- /dev/null +++ b/plutus-tx-plugin/test/Array/Spec.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} + +module Array.Spec where + +import Data.Vector.Strict qualified as Vector +import PlutusCore (someValue) +import PlutusTx (CompiledCode, getPlcNoAnn) +import PlutusTx.Builtins (toOpaque) +import PlutusTx.Builtins.Internal (BuiltinInteger, BuiltinList, listToArray) +import PlutusTx.TH (compile) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) +import UntypedPlutusCore (DefaultFun, DefaultUni, NamedDeBruijn, Program (_progTerm), + Term (Constant)) + +smokeTests :: TestTree +smokeTests = + testGroup "Array" [testListToArray] + +testListToArray :: TestTree +testListToArray = testCase "Array" do + term compiledArray @?= Constant () (someValue (Vector.fromList [1 :: Integer, 2, 3])) + where + compiledArray = + $$( compile + [|| + let xs :: BuiltinList BuiltinInteger + xs = toOpaque [1 :: Integer, 2, 3] + in listToArray xs + ||] + ) + +term :: CompiledCode a -> Term NamedDeBruijn DefaultUni DefaultFun () +term = _progTerm . getPlcNoAnn diff --git a/plutus-tx-plugin/test/Spec.hs b/plutus-tx-plugin/test/Spec.hs index f9b3a5acf10..da5b7df56d1 100644 --- a/plutus-tx-plugin/test/Spec.hs +++ b/plutus-tx-plugin/test/Spec.hs @@ -1,5 +1,6 @@ module Main (main) where +import Array.Spec qualified as Array import AsData.Budget.Spec qualified as AsData.Budget import AssocMap.Spec qualified as AssocMap import Blueprint.Tests qualified @@ -49,4 +50,5 @@ tests = , embed Unicode.tests , embed AssocMap.propertyTests , embed List.propertyTests + , embed Array.smokeTests ] diff --git a/plutus-tx/src/PlutusTx/Builtins.hs b/plutus-tx/src/PlutusTx/Builtins.hs index be380ec2ab0..158276203d8 100644 --- a/plutus-tx/src/PlutusTx/Builtins.hs +++ b/plutus-tx/src/PlutusTx/Builtins.hs @@ -86,6 +86,11 @@ module PlutusTx.Builtins ( , BI.tail , uncons , unsafeUncons + -- * Arrays + , BI.BuiltinArray + , BI.listToArray + , BI.lengthOfArray + , BI.indexArray -- * Tracing , trace -- * BLS12_381 diff --git a/plutus-tx/src/PlutusTx/Builtins/HasBuiltin.hs b/plutus-tx/src/PlutusTx/Builtins/HasBuiltin.hs index ee9951155b0..ab2b22097c8 100644 --- a/plutus-tx/src/PlutusTx/Builtins/HasBuiltin.hs +++ b/plutus-tx/src/PlutusTx/Builtins/HasBuiltin.hs @@ -18,7 +18,7 @@ import PlutusTx.Builtins.Internal import Data.ByteString (ByteString) import Data.Kind qualified as GHC import Data.Text (Text) -import Data.Vector.Strict (Vector) +import Data.Vector.Strict qualified as Strict {- Note [useToOpaque and useFromOpaque] It used to be possible to use 'toBuiltin'/'fromBuiltin' within a smart contract, but this is no @@ -92,9 +92,12 @@ instance HasFromBuiltin a => HasFromBuiltin (BuiltinList a) where type FromBuiltin (BuiltinList a) = [FromBuiltin a] fromBuiltin (BuiltinList xs) = map fromBuiltin xs -instance HasToBuiltin a => HasToBuiltin (Vector a) where - type ToBuiltin (Vector a) = BuiltinArray (ToBuiltin a) - toBuiltin = useToOpaque (BuiltinArray . map toBuiltin) +instance HasToBuiltin a => HasToBuiltin (Strict.Vector a) where + type ToBuiltin (Strict.Vector a) = BuiltinArray (ToBuiltin a) + toBuiltin = useToOpaque (BuiltinArray . fmap toBuiltin) +instance HasFromBuiltin a => HasFromBuiltin (BuiltinArray a) where + type FromBuiltin (BuiltinArray a) = Strict.Vector (FromBuiltin a) + fromBuiltin (BuiltinArray xs) = fmap fromBuiltin xs instance (HasToBuiltin a, HasToBuiltin b) => HasToBuiltin (a, b) where type ToBuiltin (a, b) = BuiltinPair (ToBuiltin a) (ToBuiltin b) diff --git a/plutus-tx/src/PlutusTx/Builtins/Internal.hs b/plutus-tx/src/PlutusTx/Builtins/Internal.hs index 3cae9fa6f21..5764f44b9ee 100644 --- a/plutus-tx/src/PlutusTx/Builtins/Internal.hs +++ b/plutus-tx/src/PlutusTx/Builtins/Internal.hs @@ -31,6 +31,8 @@ import Data.Hashable (Hashable (..)) import Data.Kind (Type) import Data.Text as Text (Text, empty) import Data.Text.Encoding as Text (decodeUtf8, encodeUtf8) +import Data.Vector.Strict (Vector) +import Data.Vector.Strict qualified as Vector import GHC.Generics (Generic) import PlutusCore.Bitwise qualified as Bitwise import PlutusCore.Builtin (BuiltinResult (..)) @@ -551,6 +553,30 @@ serialiseData :: BuiltinData -> BuiltinByteString serialiseData (BuiltinData b) = BuiltinByteString $ BSL.toStrict $ serialise b {-# OPAQUE serialiseData #-} +{- +ARRAY +-} + +data BuiltinArray a = BuiltinArray ~(Vector a) deriving stock (Data) + +instance Haskell.Show a => Haskell.Show (BuiltinArray a) where + show (BuiltinArray v) = show v +instance Haskell.Eq a => Haskell.Eq (BuiltinArray a) where + (==) (BuiltinArray v) (BuiltinArray v') = (==) v v' +instance Haskell.Ord a => Haskell.Ord (BuiltinArray a) where + compare (BuiltinArray v) (BuiltinArray v') = compare v v' + +lengthOfArray :: BuiltinArray a -> BuiltinInteger +lengthOfArray (BuiltinArray v) = toInteger (Vector.length v) +{-# OPAQUE lengthOfArray #-} + +listToArray :: BuiltinList a -> BuiltinArray a +listToArray (BuiltinList l) = BuiltinArray (Vector.fromList l) +{-# OPAQUE listToArray #-} + +indexArray :: BuiltinArray a -> BuiltinInteger -> a +indexArray (BuiltinArray v) i = v Vector.! fromInteger i +{-# OPAQUE indexArray #-} {- BLS12_381 diff --git a/plutus-tx/src/PlutusTx/Lift/Class.hs b/plutus-tx/src/PlutusTx/Lift/Class.hs index 7df54048efc..89f9e9d2053 100644 --- a/plutus-tx/src/PlutusTx/Lift/Class.hs +++ b/plutus-tx/src/PlutusTx/Lift/Class.hs @@ -40,6 +40,7 @@ import Data.ByteString qualified as BS import Data.Kind qualified as GHC import Data.Proxy import Data.Text qualified as T +import Data.Vector.Strict qualified as Strict import GHC.TypeLits (ErrorMessage (..), TypeError) -- We do not use qualified import because the whole module contains off-chain code @@ -180,6 +181,16 @@ instance (HasFromBuiltin arep, uni `PLC.HasTermLevel` [FromBuiltin arep]) => Lift uni (BuiltinList arep) where lift = liftBuiltin . fromBuiltin +-- See Note [Lift and Typeable instances for builtins] +instance uni `PLC.HasTypeLevel` Strict.Vector => Typeable uni BuiltinArray where + typeRep _ = typeRepBuiltin (Proxy @Strict.Vector) + +-- See Note [Lift and Typeable instances for builtins] +instance ( HasFromBuiltin arep + , uni `PLC.HasTermLevel` Strict.Vector (FromBuiltin arep) + ) => Lift uni (BuiltinArray arep) where + lift = liftBuiltin . fromBuiltin + instance uni `PLC.HasTypeLevel` (,) => Typeable uni BuiltinPair where typeRep _ = typeRepBuiltin (Proxy @(,))