BuiltinArray for Plinth

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

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

plutus-tx-plugin/test/Array/9.6/compiledIndexArray.eval.golden

@@ -0,0 +1 @@
+I 3

plutus-tx-plugin/test/Array/9.6/compiledIndexArray.pir.golden

@@ -0,0 +1 @@
+indexArray {data} [I 1, I 2, I 3] 2

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))

plutus-tx-plugin/test/Array/9.6/compiledLengthArray.eval.golden

@@ -0,0 +1 @@
+3

plutus-tx-plugin/test/Array/9.6/compiledLengthArray.pir.golden

@@ -0,0 +1 @@
+lengthArray {data} [I 1, I 2, I 3]

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]))

plutus-tx-plugin/test/Array/9.6/compiledListToArray.eval.golden

@@ -0,0 +1 @@
+[I 1, I 2, I 3]

plutus-tx-plugin/test/Array/9.6/compiledListToArray.pir.golden

@@ -0,0 +1 @@
+[I 1, I 2, I 3]

plutus-tx-plugin/test/Array/9.6/compiledListToArray.uplc.golden

@@ -0,0 +1 @@
+(program 1.1.0 [I 1, I 2, I 3])

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

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
     ]

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

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)

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

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 @(,))