Skip to content

Commit 119a64e

Browse files
ana-pantilieana-pantilie
authored
Add BuiltinValue type to plutus-core (#7225)
1 parent ad408e9 commit 119a64e

File tree

18 files changed

+142
-2
lines changed

18 files changed

+142
-2
lines changed

‎cabal.project‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -87,4 +87,4 @@ allow-newer:
8787

8888
-- https://github.com/IntersectMBO/plutus/pull/7236
8989
constraints: setup.optparse-applicative >=0.19.0.0
90-
allow-newer: turtle:optparse-applicative
90+
allow-newer: turtle:optparse-applicative

‎plutus-core/plutus-core.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -193,6 +193,7 @@ library
193193
PlutusCore.Subst
194194
PlutusCore.TypeCheck
195195
PlutusCore.TypeCheck.Internal
196+
PlutusCore.Value
196197
PlutusCore.Version
197198
PlutusPrelude
198199
Prettyprinter.Custom

‎plutus-core/plutus-core/src/PlutusCore/Default/Universe.hs‎

Lines changed: 19 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -53,6 +53,7 @@ import PlutusCore.Data (Data)
5353
import PlutusCore.Evaluation.Machine.ExMemoryUsage (IntegerCostedLiterally (..),
5454
NumBytesCostedAsNumWords (..))
5555
import PlutusCore.Pretty.Extra (juxtRenderContext)
56+
import PlutusCore.Value (Value)
5657

5758
import Control.Monad.Except (throwError)
5859
import Data.ByteString (ByteString)
@@ -118,6 +119,7 @@ data DefaultUni a where
118119
DefaultUniBLS12_381_G1_Element :: DefaultUni (Esc BLS12_381.G1.Element)
119120
DefaultUniBLS12_381_G2_Element :: DefaultUni (Esc BLS12_381.G2.Element)
120121
DefaultUniBLS12_381_MlResult :: DefaultUni (Esc BLS12_381.Pairing.MlResult)
122+
DefaultUniValue :: DefaultUni (Esc Value)
121123

122124
-- GHC infers crazy types for these two and the straightforward ones break pattern matching,
123125
-- so we just leave GHC with its craziness.
@@ -182,6 +184,9 @@ instance GEq DefaultUni where
182184
geqStep DefaultUniBLS12_381_MlResult a2 = do
183185
DefaultUniBLS12_381_MlResult <- Just a2
184186
Just Refl
187+
geqStep DefaultUniValue a2 = do
188+
DefaultUniValue <- Just a2
189+
Just Refl
185190
{-# INLINE geqStep #-}
186191

187192
geqRec :: DefaultUni a1 -> DefaultUni a2 -> Maybe (a1 :~: a2)
@@ -206,6 +211,7 @@ instance ToKind DefaultUni where
206211
toSingKind DefaultUniBLS12_381_G1_Element = knownKind
207212
toSingKind DefaultUniBLS12_381_G2_Element = knownKind
208213
toSingKind DefaultUniBLS12_381_MlResult = knownKind
214+
toSingKind DefaultUniValue = knownKind
209215

210216
instance HasUniApply DefaultUni where
211217
uniApply = DefaultUniApply
@@ -231,6 +237,7 @@ instance PrettyBy RenderContext (DefaultUni a) where
231237
DefaultUniBLS12_381_G1_Element -> "bls12_381_G1_element"
232238
DefaultUniBLS12_381_G2_Element -> "bls12_381_G2_element"
233239
DefaultUniBLS12_381_MlResult -> "bls12_381_mlresult"
240+
DefaultUniValue -> "value"
234241

235242
instance PrettyBy RenderContext (SomeTypeIn DefaultUni) where
236243
prettyBy config (SomeTypeIn uni) = prettyBy config uni
@@ -263,6 +270,8 @@ instance DefaultUni `Contains` () where
263270
knownUni = DefaultUniUnit
264271
instance DefaultUni `Contains` Bool where
265272
knownUni = DefaultUniBool
273+
instance DefaultUni `Contains` Value where
274+
knownUni = DefaultUniValue
266275
instance DefaultUni `Contains` [] where
267276
knownUni = DefaultUniProtoList
268277
instance DefaultUni `Contains` Strict.Vector where
@@ -302,6 +311,8 @@ instance KnownBuiltinTypeAst tyname DefaultUni BLS12_381.G2.Element =>
302311
KnownTypeAst tyname DefaultUni BLS12_381.G2.Element
303312
instance KnownBuiltinTypeAst tyname DefaultUni BLS12_381.Pairing.MlResult =>
304313
KnownTypeAst tyname DefaultUni BLS12_381.Pairing.MlResult
314+
instance KnownBuiltinTypeAst tyname DefaultUni Value =>
315+
KnownTypeAst tyname DefaultUni Value
305316

306317
instance KnownBuiltinTypeIn DefaultUni term Integer =>
307318
ReadKnownIn DefaultUni term Integer
@@ -327,6 +338,8 @@ instance KnownBuiltinTypeIn DefaultUni term BLS12_381.G2.Element =>
327338
ReadKnownIn DefaultUni term BLS12_381.G2.Element
328339
instance KnownBuiltinTypeIn DefaultUni term BLS12_381.Pairing.MlResult =>
329340
ReadKnownIn DefaultUni term BLS12_381.Pairing.MlResult
341+
instance KnownBuiltinTypeIn DefaultUni term Value =>
342+
ReadKnownIn DefaultUni term Value
330343

331344
instance KnownBuiltinTypeIn DefaultUni term Integer =>
332345
MakeKnownIn DefaultUni term Integer
@@ -352,6 +365,8 @@ instance KnownBuiltinTypeIn DefaultUni term BLS12_381.G2.Element =>
352365
MakeKnownIn DefaultUni term BLS12_381.G2.Element
353366
instance KnownBuiltinTypeIn DefaultUni term BLS12_381.Pairing.MlResult =>
354367
MakeKnownIn DefaultUni term BLS12_381.Pairing.MlResult
368+
instance KnownBuiltinTypeIn DefaultUni term Value =>
369+
MakeKnownIn DefaultUni term Value
355370

356371
-- If this tells you an instance is missing, add it right above, following the pattern.
357372
instance TestTypesFromTheUniverseAreAllKnown DefaultUni
@@ -604,6 +619,7 @@ instance Closed DefaultUni where
604619
, constr `Permits` Text
605620
, constr `Permits` ()
606621
, constr `Permits` Bool
622+
, constr `Permits` Value
607623
, constr `Permits` []
608624
, constr `Permits` Strict.Vector
609625
, constr `Permits` (,)
@@ -628,6 +644,7 @@ instance Closed DefaultUni where
628644
encodeUni DefaultUniBLS12_381_G2_Element = [10]
629645
encodeUni DefaultUniBLS12_381_MlResult = [11]
630646
encodeUni DefaultUniProtoArray = [12]
647+
encodeUni DefaultUniValue = [13]
631648

632649
-- See Note [Decoding universes].
633650
-- See Note [Stable encoding of tags].
@@ -649,6 +666,7 @@ instance Closed DefaultUni where
649666
10 -> k DefaultUniBLS12_381_G2_Element
650667
11 -> k DefaultUniBLS12_381_MlResult
651668
12 -> k DefaultUniProtoArray
669+
13 -> k DefaultUniValue
652670
_ -> empty
653671

654672
bring
@@ -671,3 +689,4 @@ instance Closed DefaultUni where
671689
bring _ DefaultUniBLS12_381_G1_Element r = r
672690
bring _ DefaultUniBLS12_381_G2_Element r = r
673691
bring _ DefaultUniBLS12_381_MlResult r = r
692+
bring _ DefaultUniValue r = r

‎plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExMemoryUsage.hs‎

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -20,9 +20,11 @@ import PlutusCore.Crypto.BLS12_381.Pairing as BLS12_381.Pairing
2020
import PlutusCore.Data
2121
import PlutusCore.Evaluation.Machine.CostStream
2222
import PlutusCore.Evaluation.Machine.ExMemory
23+
import PlutusCore.Value
2324

2425
import Data.ByteString qualified as BS
2526
import Data.Functor
27+
import Data.Map.Strict qualified as Map
2628
import Data.Proxy
2729
import Data.SatInt
2830
import Data.Text qualified as T
@@ -368,6 +370,13 @@ instance ExMemoryUsage Data where
368370
I n -> memoryUsage n
369371
B b -> memoryUsage b
370372

373+
instance ExMemoryUsage Value where
374+
memoryUsage (Value v) = case Map.toList v of
375+
[] -> CostRose 0 []
376+
x : xs -> CostRose (f x) (flip CostRose [] . f <$> xs)
377+
where
378+
f = fromIntegral . Map.size . snd
379+
371380
{- Note [Costing constant-size types]
372381
The memory usage of each of the BLS12-381 types is constant, so we may be able
373382
to optimise things a little by ensuring that we don't re-compute the size of

‎plutus-core/plutus-core/src/PlutusCore/Flat.hs‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -20,6 +20,7 @@ import PlutusCore.Core
2020
import PlutusCore.Data (Data)
2121
import PlutusCore.DeBruijn
2222
import PlutusCore.Name.Unique
23+
import PlutusCore.Value (Value)
2324

2425
import Data.Proxy
2526
import Flat
@@ -121,6 +122,8 @@ decodeConstant = dBEBits8 constantWidth
121122

122123
deriving via FlatViaSerialise Data instance Flat Data
123124

125+
deriving via FlatViaSerialise Value instance Flat Value
126+
124127
decodeKindedUniFlat :: Closed uni => Get (SomeTypeIn (Kinded uni))
125128
decodeKindedUniFlat =
126129
go . decodeKindedUni . map (fromIntegral :: Word8 -> Int)

‎plutus-core/plutus-core/src/PlutusCore/Parser/Builtin.hs‎

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,8 @@ import PlutusCore.Name.Unique
1414
import PlutusCore.Parser.ParserCommon
1515
import PlutusCore.Parser.Type (defaultUni)
1616
import PlutusCore.Pretty (display)
17+
import PlutusCore.Value qualified as PLC (Value)
18+
import PlutusCore.Value qualified as Value
1719

1820
import Control.Monad.Combinators
1921
import Data.ByteString (ByteString, pack)
@@ -86,6 +88,10 @@ conList uniA = trailingWhitespace . inBrackets $
8688
conArray :: DefaultUni (Esc a) -> Parser (Vector a)
8789
conArray uniA = Vector.fromList <$> conList uniA
8890

91+
-- | Parser for values.
92+
conValue :: Parser PLC.Value
93+
conValue = Value.fromList <$> conList knownUni
94+
8995
-- | Parser for pairs.
9096
conPair :: DefaultUni (Esc a) -> DefaultUni (Esc b) -> Parser (a, b)
9197
conPair uniA uniB = trailingWhitespace . inParens $ do
@@ -136,6 +142,7 @@ constantOf expectParens uni =
136142
DefaultUniString -> conText
137143
DefaultUniUnit -> conUnit
138144
DefaultUniBool -> conBool
145+
DefaultUniValue -> conValue
139146
DefaultUniProtoList `DefaultUniApply` uniA -> conList uniA
140147
DefaultUniProtoArray `DefaultUniApply` uniA -> conArray uniA
141148
DefaultUniProtoPair `DefaultUniApply` uniA `DefaultUniApply` uniB -> conPair uniA uniB

‎plutus-core/plutus-core/src/PlutusCore/Parser/Type.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -18,6 +18,7 @@ import PlutusCore.Default
1818
import PlutusCore.MkPlc (mkIterTyApp)
1919
import PlutusCore.Name.Unique
2020
import PlutusCore.Parser.ParserCommon
21+
import PlutusCore.Value (Value)
2122

2223
import Control.Monad
2324
import Data.ByteString (ByteString)
@@ -145,6 +146,7 @@ defaultUni = choice $ map try
145146
, someType @_ @BLS12_381.G1.Element <$ symbol "bls12_381_G1_element"
146147
, someType @_ @BLS12_381.G2.Element <$ symbol "bls12_381_G2_element"
147148
, someType @_ @BLS12_381.Pairing.MlResult <$ symbol "bls12_381_mlresult"
149+
, someType @_ @Value <$ symbol "value"
148150
]
149151

150152
tyName :: Parser TyName

‎plutus-core/plutus-core/src/PlutusCore/Pretty/PrettyConst.hs‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -15,6 +15,8 @@ module PlutusCore.Pretty.PrettyConst where
1515

1616
import PlutusCore.Data
1717
import PlutusCore.Pretty.Readable
18+
import PlutusCore.Value (Value (..))
19+
import PlutusCore.Value qualified as Value
1820

1921
import Control.Lens hiding (List)
2022
import Data.ByteString qualified as BS
@@ -157,6 +159,9 @@ instance PrettyBy ConstConfig Data where
157159
I i -> ("I" <+> prettyArg i) :| []
158160
B b -> ("B" <+> prettyArg b) :| []
159161

162+
instance PrettyBy ConstConfig Value where
163+
prettyBy config = prettyBy config . Value.toList
164+
160165
instance PrettyBy ConstConfig BS.ByteString where
161166
prettyBy _ b = "#" <> toBytes b
162167

‎plutus-core/plutus-core/src/PlutusCore/Value.hs‎

Lines changed: 48 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,48 @@
1+
{-# LANGUAGE FlexibleInstances #-}
2+
3+
module PlutusCore.Value (
4+
Value (..),
5+
empty,
6+
fromList,
7+
toList,
8+
totalSize,
9+
) where
10+
11+
import Codec.Serialise (Serialise)
12+
import Control.DeepSeq (NFData)
13+
import Data.Bifunctor
14+
import Data.ByteString (ByteString)
15+
import Data.ByteString.Base64 qualified as Base64
16+
import Data.Hashable (Hashable)
17+
import Data.Map.Strict (Map)
18+
import Data.Map.Strict qualified as Map
19+
import Data.Text.Encoding qualified as Text
20+
21+
import PlutusPrelude (Pretty (..))
22+
23+
newtype Value = Value {unValue :: Map ByteString (Map ByteString Integer)}
24+
deriving newtype (Eq, Show, Hashable, Serialise, NFData)
25+
26+
empty :: Value
27+
empty = Value mempty
28+
29+
toList :: Value -> [(ByteString, [(ByteString, Integer)])]
30+
toList = Map.toList . Map.map Map.toList . unValue
31+
32+
fromList :: [(ByteString, [(ByteString, Integer)])] -> Value
33+
fromList =
34+
normalize
35+
. Value
36+
. Map.fromListWith (Map.unionWith (+))
37+
. fmap (second (Map.fromListWith (+)))
38+
39+
normalize :: Value -> Value
40+
normalize = Value . Map.filter (not . Map.null) . Map.map (Map.filter (/= 0)) . unValue
41+
42+
totalSize :: Value -> Int
43+
totalSize = Map.foldl' (\n -> (n +) . Map.size) 0 . unValue
44+
45+
instance Pretty Value where
46+
pretty = pretty . fmap (bimap toText (fmap (first toText))) . toList
47+
where
48+
toText = Text.decodeLatin1 . Base64.encode

‎plutus-core/plutus-ir/test/PlutusIR/Parser/Tests.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -96,6 +96,7 @@ isScramblable (PLC.Some (PLC.ValueOf uni0 x0)) = go uni0 x0 where
9696
go (f `PLC.DefaultUniApply` _ `PLC.DefaultUniApply` _ `PLC.DefaultUniApply` _) _ =
9797
noMoreTypeFunctions f
9898
go PLC.DefaultUniData _ = True
99+
go PLC.DefaultUniValue _ = True
99100
go PLC.DefaultUniBLS12_381_G1_Element _ = False
100101
go PLC.DefaultUniBLS12_381_G2_Element _ = False
101102
go PLC.DefaultUniBLS12_381_MlResult _ = False

0 commit comments

Comments
 (0)