From e6dad3a44cea0f9f7f41e678d94039c46df4db33 Mon Sep 17 00:00:00 2001 From: Yura <1009751+Unisay@users.noreply.github.com> Date: Fri, 13 Dec 2024 12:35:16 +0100 Subject: [PATCH] BuiltinArray for Plinth --- plutus-tx-plugin/plutus-tx-plugin.cabal | 1 + .../src/PlutusTx/Compiler/Builtins.hs | 15 ++++- .../Array/9.6/compiledIndexArray.eval.golden | 1 + .../Array/9.6/compiledIndexArray.pir.golden | 1 + .../Array/9.6/compiledIndexArray.uplc.golden | 1 + .../Array/9.6/compiledLengthArray.eval.golden | 1 + .../Array/9.6/compiledLengthArray.pir.golden | 1 + .../Array/9.6/compiledLengthArray.uplc.golden | 1 + .../Array/9.6/compiledListToArray.eval.golden | 1 + .../Array/9.6/compiledListToArray.pir.golden | 1 + .../Array/9.6/compiledListToArray.uplc.golden | 1 + plutus-tx-plugin/test/Array/Spec.hs | 59 +++++++++++++++++++ plutus-tx-plugin/test/Spec.hs | 2 + plutus-tx/src/PlutusTx/Builtins.hs | 5 ++ plutus-tx/src/PlutusTx/Builtins/HasBuiltin.hs | 11 ++-- plutus-tx/src/PlutusTx/Builtins/Internal.hs | 26 ++++++++ plutus-tx/src/PlutusTx/Lift/Class.hs | 11 ++++ 17 files changed, 132 insertions(+), 7 deletions(-) create mode 100644 plutus-tx-plugin/test/Array/9.6/compiledIndexArray.eval.golden create mode 100644 plutus-tx-plugin/test/Array/9.6/compiledIndexArray.pir.golden create mode 100644 plutus-tx-plugin/test/Array/9.6/compiledIndexArray.uplc.golden create mode 100644 plutus-tx-plugin/test/Array/9.6/compiledLengthArray.eval.golden create mode 100644 plutus-tx-plugin/test/Array/9.6/compiledLengthArray.pir.golden create mode 100644 plutus-tx-plugin/test/Array/9.6/compiledLengthArray.uplc.golden create mode 100644 plutus-tx-plugin/test/Array/9.6/compiledListToArray.eval.golden create mode 100644 plutus-tx-plugin/test/Array/9.6/compiledListToArray.pir.golden create mode 100644 plutus-tx-plugin/test/Array/9.6/compiledListToArray.uplc.golden create mode 100644 plutus-tx-plugin/test/Array/Spec.hs diff --git a/plutus-tx-plugin/plutus-tx-plugin.cabal b/plutus-tx-plugin/plutus-tx-plugin.cabal index f872c951304..c5bf14c9deb 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 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/9.6/compiledIndexArray.eval.golden b/plutus-tx-plugin/test/Array/9.6/compiledIndexArray.eval.golden new file mode 100644 index 00000000000..361ee8e0beb --- /dev/null +++ b/plutus-tx-plugin/test/Array/9.6/compiledIndexArray.eval.golden @@ -0,0 +1 @@ +I 3 \ No newline at end of file diff --git a/plutus-tx-plugin/test/Array/9.6/compiledIndexArray.pir.golden b/plutus-tx-plugin/test/Array/9.6/compiledIndexArray.pir.golden new file mode 100644 index 00000000000..1914d707801 --- /dev/null +++ b/plutus-tx-plugin/test/Array/9.6/compiledIndexArray.pir.golden @@ -0,0 +1 @@ +indexArray {data} [I 1, I 2, I 3] 2 \ No newline at end of file diff --git a/plutus-tx-plugin/test/Array/9.6/compiledIndexArray.uplc.golden b/plutus-tx-plugin/test/Array/9.6/compiledIndexArray.uplc.golden new file mode 100644 index 00000000000..53f79520ef2 --- /dev/null +++ b/plutus-tx-plugin/test/Array/9.6/compiledIndexArray.uplc.golden @@ -0,0 +1 @@ +(program 1.1.0 (force indexArray [I 1, I 2, I 3] 2)) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Array/9.6/compiledLengthArray.eval.golden b/plutus-tx-plugin/test/Array/9.6/compiledLengthArray.eval.golden new file mode 100644 index 00000000000..e440e5c8425 --- /dev/null +++ b/plutus-tx-plugin/test/Array/9.6/compiledLengthArray.eval.golden @@ -0,0 +1 @@ +3 \ No newline at end of file diff --git a/plutus-tx-plugin/test/Array/9.6/compiledLengthArray.pir.golden b/plutus-tx-plugin/test/Array/9.6/compiledLengthArray.pir.golden new file mode 100644 index 00000000000..b215127edfd --- /dev/null +++ b/plutus-tx-plugin/test/Array/9.6/compiledLengthArray.pir.golden @@ -0,0 +1 @@ +lengthArray {data} [I 1, I 2, I 3] \ No newline at end of file diff --git a/plutus-tx-plugin/test/Array/9.6/compiledLengthArray.uplc.golden b/plutus-tx-plugin/test/Array/9.6/compiledLengthArray.uplc.golden new file mode 100644 index 00000000000..a71685a77f0 --- /dev/null +++ b/plutus-tx-plugin/test/Array/9.6/compiledLengthArray.uplc.golden @@ -0,0 +1 @@ +(program 1.1.0 (force lengthArray [I 1, I 2, I 3])) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Array/9.6/compiledListToArray.eval.golden b/plutus-tx-plugin/test/Array/9.6/compiledListToArray.eval.golden new file mode 100644 index 00000000000..e3446f4a641 --- /dev/null +++ b/plutus-tx-plugin/test/Array/9.6/compiledListToArray.eval.golden @@ -0,0 +1 @@ +[I 1, I 2, I 3] \ No newline at end of file diff --git a/plutus-tx-plugin/test/Array/9.6/compiledListToArray.pir.golden b/plutus-tx-plugin/test/Array/9.6/compiledListToArray.pir.golden new file mode 100644 index 00000000000..e3446f4a641 --- /dev/null +++ b/plutus-tx-plugin/test/Array/9.6/compiledListToArray.pir.golden @@ -0,0 +1 @@ +[I 1, I 2, I 3] \ No newline at end of file diff --git a/plutus-tx-plugin/test/Array/9.6/compiledListToArray.uplc.golden b/plutus-tx-plugin/test/Array/9.6/compiledListToArray.uplc.golden new file mode 100644 index 00000000000..1ae8317b7b8 --- /dev/null +++ b/plutus-tx-plugin/test/Array/9.6/compiledListToArray.uplc.golden @@ -0,0 +1 @@ +(program 1.1.0 [I 1, I 2, I 3]) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Array/Spec.hs b/plutus-tx-plugin/test/Array/Spec.hs new file mode 100644 index 00000000000..cd06e5a7e3a --- /dev/null +++ b/plutus-tx-plugin/test/Array/Spec.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} + +module Array.Spec where + +import PlutusCore.Test (goldenUEval) +import PlutusTx +import PlutusTx.Builtins.Internal +import PlutusTx.Test (goldenPirReadable, goldenUPlcReadable) +import Test.Tasty.Extras + +smokeTests :: TestNested +smokeTests = + testNested + "Array" + [ testNestedGhc + [ goldenPirReadable "compiledListToArray" compiledListToArray + , goldenUPlcReadable "compiledListToArray" compiledListToArray + , goldenUEval "compiledListToArray" [compiledListToArray] + , goldenPirReadable "compiledLengthArray" compiledLengthArray + , goldenUPlcReadable "compiledLengthArray" compiledLengthArray + , goldenUEval "compiledLengthArray" [compiledLengthArray] + , goldenPirReadable "compiledIndexArray" compiledIndexArray + , goldenUPlcReadable "compiledIndexArray" compiledIndexArray + , goldenUEval "compiledIndexArray" [compiledIndexArray] + ] + ] + +compiledListToArray :: CompiledCode (BuiltinArray BuiltinData) +compiledListToArray = + $$( compile + [|| + listToArray + ( mkCons + (mkI 1) + ( mkCons + (mkI 2) + ( mkCons + (mkI 3) + (mkNilData unitval) + ) + ) + ) + ||] + ) + +compiledLengthArray :: CompiledCode BuiltinInteger +compiledLengthArray = + $$(compile [||lengthOfArray||]) `unsafeApplyCode` compiledListToArray + +compiledIndexArray :: CompiledCode BuiltinData +compiledIndexArray = + $$(compile [||indexArray||]) + `unsafeApplyCode` compiledListToArray + `unsafeApplyCode` liftCodeDef 2 diff --git a/plutus-tx-plugin/test/Spec.hs b/plutus-tx-plugin/test/Spec.hs index f9b3a5acf10..5a69c0c6f74 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 + , 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..110ef682b89 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 @(,))