Skip to content

Commit 7ec8992

Browse files
bladyjokerbladyjoker
committed
Implements the PList
1 parent 675265d commit 7ec8992

File tree

8 files changed

+159
-27
lines changed

8 files changed

+159
-27
lines changed

‎lambda-buffers-codegen/data/plutarch-prelude.json

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -6,9 +6,9 @@
66
"PMap"
77
],
88
"Prelude.List": [
9-
"plutarch",
10-
"Plutarch.Builtin",
11-
"PBuiltinList"
9+
"lbr-plutarch",
10+
"LambdaBuffers.Runtime.Plutarch",
11+
"PList"
1212
],
1313
"Prelude.Either": [
1414
"lbr-plutarch",

‎lambda-buffers-codegen/src/LambdaBuffers/Codegen/Plutarch/Print/Derive.hs

Lines changed: 1 addition & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -56,20 +56,6 @@ hsClassImplPrinters =
5656
useVal :: MonadPrint m => HsSyntax.QValName -> m (Doc ann)
5757
useVal qvn = Print.importValue qvn >> return (HsSyntax.printHsQValName qvn)
5858

59-
-- Plutarch derived classes (Generic, PShow).
60-
61-
-- showClass :: HsSyntax.QClassName
62-
-- showClass = (HsSyntax.MkCabalPackageName "plutarch", HsSyntax.MkModuleName "Plutarch.Show", HsSyntax.MkClassName "PShow")
63-
64-
-- derivingShowDoc :: Doc ann
65-
-- derivingShowDoc = "deriving anyclass" <+> HsSyntax.printHsQClassName showClass
66-
67-
-- genericClass :: HsSyntax.QClassName
68-
-- genericClass = (HsSyntax.MkCabalPackageName "base", HsSyntax.MkModuleName "GHC.Generics", HsSyntax.MkClassName "Generic")
69-
70-
-- derivingGenericDoc :: Doc ann
71-
-- derivingGenericDoc = "deriving stock" <+> HsSyntax.printHsQClassName genericClass
72-
7359
{- | Deriving PEq.
7460
7561
NOTE(bladyjoker): Doesn't derive the implementation but only uses the underlying PData representation for equality.
@@ -141,7 +127,7 @@ printDerivePlutusType :: MonadPrint m => PC.ModuleName -> PC.TyDefs -> (Doc ann
141127
printDerivePlutusType mn iTyDefs _mkInstanceDoc ty = do
142128
pappDoc <- useVal PlRefs.pappQValName
143129
pconDoc <- useVal PlRefs.pconQValName
144-
-- TODO(bladyjoker): The `fromData` implementation is trying to construct a term, which for Plutarch means `pcon`. However, this is 'pmatch' implementation which is NOT really exactly 'fromData', and has a different type signature for which we do this. I'm sorry.
130+
-- HACK(bladyjoker): The `fromData` implementation is trying to construct a term, which for Plutarch means `pcon`. However, this is 'pmatch' implementation which is NOT really exactly 'fromData', and has a different type signature for which we do this. I'm sorry.
145131
let dirtyHack :: Doc ann -> Doc ann
146132
dirtyHack = pretty . Text.replace (docToText pconDoc <> " ") "f " . docToText
147133

‎runtimes/haskell/lbr-plutarch/lbr-plutarch.cabal

Lines changed: 16 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -94,3 +94,19 @@ library
9494
exposed-modules:
9595
LambdaBuffers.Runtime.Plutarch
9696
LambdaBuffers.Runtime.Plutarch.LamVal
97+
98+
test-suite tests
99+
import: common-language
100+
type: exitcode-stdio-1.0
101+
hs-source-dirs: test
102+
main-is: Test.hs
103+
build-depends:
104+
, base >=4.16
105+
, hedgehog >=1.2
106+
, lbr-plutarch
107+
, plutarch >=1.3
108+
, tasty >=1.4
109+
, tasty-hedgehog >=1.4
110+
, tasty-hunit
111+
112+
other-modules: Test.LambdaBuffers.Runtime.Plutarch

‎runtimes/haskell/lbr-plutarch/src/LambdaBuffers/Runtime/Plutarch.hs

Lines changed: 77 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -1,13 +1,30 @@
11
{-# LANGUAGE AllowAmbiguousTypes #-}
2+
{-# LANGUAGE LiberalTypeSynonyms #-}
23
{-# LANGUAGE OverloadedLists #-}
34
{-# LANGUAGE UndecidableInstances #-}
45
{-# OPTIONS_GHC -Wno-orphans #-}
5-
6-
module LambdaBuffers.Runtime.Plutarch (PEither (..), PAssetClass, PMap, PChar, PSet, PValue, ptryFromPAsData, PMaybe (..), pcon) where
6+
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
7+
8+
module LambdaBuffers.Runtime.Plutarch (
9+
PEither (..),
10+
PAssetClass,
11+
PMap,
12+
PChar,
13+
PSet,
14+
PValue,
15+
ptryFromPAsData,
16+
PMaybe (..),
17+
pcon,
18+
PList (..),
19+
caseList,
20+
pcons,
21+
pnil,
22+
) where
723

824
import Data.Functor.Const (Const)
925
import GHC.Generics (Generic)
1026
import GHC.TypeLits qualified as GHC
27+
import LambdaBuffers.Runtime.Plutarch.LamVal (pfromPlutusDataPTryFrom)
1128
import LambdaBuffers.Runtime.Plutarch.LamVal qualified as LamVal
1229
import Plutarch (
1330
PType,
@@ -41,6 +58,14 @@ import Plutarch.Reducible (Reduce)
4158
import Plutarch.TryFrom (PTryFrom (PTryFromExcess, ptryFrom'))
4259
import Plutarch.Unsafe (punsafeCoerce)
4360

61+
{- | PList because PBuiltinList misses `PAsData` on its constituents which causes type errors when used.
62+
TODO(bladyjoker): Upstream these changes or fix PBuiltinList.
63+
-}
64+
newtype PList (a :: PType) (s :: S)
65+
= PList (Term s (PBuiltinList (PAsData a)))
66+
deriving stock (Generic)
67+
deriving anyclass (Pl.PShow)
68+
4469
-- | PAssetClass missing from Plutarch.
4570
type PAssetClass = Plutarch.Api.V1.PTuple Plutarch.Api.V1.PCurrencySymbol Plutarch.Api.V1.PTokenName
4671

@@ -53,6 +78,9 @@ type PValue = Plutarch.Api.V1.PValue 'Plutarch.Api.V1.Sorted 'Plutarch.Api.V1.No
5378
-- | Not implemented.
5479
data PChar (s :: S) = PChar
5580

81+
-- | Not implemented.
82+
data PSet (a :: PType) (s :: S) = PSet
83+
5684
-- | PEither missing from Plutarch.
5785
data PEither (a :: PType) (b :: PType) (s :: S)
5886
= PLeft (Term s (PAsData a))
@@ -76,6 +104,7 @@ data PFoo (a :: PType) (s :: S)
76104
(Term s (PAsData (PEither a a)))
77105
(Term s (PAsData PAssetClass))
78106
(Term s (PAsData (PFoo a)))
107+
(Term s (PAsData (PList a)))
79108
deriving stock (Generic)
80109
deriving anyclass (Pl.PShow)
81110

@@ -136,9 +165,14 @@ instance PlutusType (PEither a b) where
136165
(const perror)
137166
pd
138167

168+
instance PlutusType (PList a) where
169+
type PInner (PList a) = (PBuiltinList (PAsData a))
170+
pcon' (PList x) = x
171+
pmatch' x f = f (PList x)
172+
139173
instance PlutusType (PFoo a) where
140174
type PInner (PFoo a) = PData
141-
pcon' (PFoo i b bs may eit ac foo) =
175+
pcon' (PFoo i b bs may eit ac foo xs) =
142176
LamVal.listData
143177
[ LamVal.toPlutusData i
144178
, LamVal.toPlutusData b
@@ -147,6 +181,7 @@ instance PlutusType (PFoo a) where
147181
, LamVal.toPlutusData eit
148182
, LamVal.toPlutusData ac
149183
, LamVal.toPlutusData foo
184+
, LamVal.toPlutusData xs
150185
]
151186
pmatch' pd f =
152187
f
@@ -158,6 +193,7 @@ instance PlutusType (PFoo a) where
158193
(LamVal.pfromPlutusDataPlutusType # pd)
159194
(LamVal.pfromPlutusDataPlutusType # pd)
160195
(LamVal.pfromPlutusDataPlutusType # pd)
196+
(LamVal.pfromPlutusDataPlutusType # pd)
161197
)
162198

163199
-- PTryFrom instances.
@@ -241,6 +277,20 @@ instance (PTryFrom PData (PAsData a)) => PTryFrom PData (PAsData (PMaybe a)) whe
241277
, ()
242278
)
243279

280+
instance PTryFrom PData (PAsData a) => PTryFrom PData (PAsData (PList a)) where
281+
type PTryFromExcess PData (PAsData (PList a)) = Const ()
282+
ptryFrom' pd f =
283+
f
284+
( LamVal.casePlutusData
285+
(const $ const perror)
286+
( \xs -> pcon $ PList $ Pl.pmap # pfromPlutusDataPTryFrom # xs
287+
)
288+
(const perror)
289+
(const perror)
290+
pd
291+
, ()
292+
)
293+
244294
instance (PTryFrom PData (PAsData a)) => PTryFrom PData (PFoo a) where
245295
type PTryFromExcess PData (PFoo a) = Const ()
246296
ptryFrom' = ptryFromPAsData
@@ -504,7 +554,7 @@ instance PTryFrom PData (PAsData Plutarch.Api.V2.PTxOut) where
504554
, ()
505555
)
506556

507-
-- FIXME(bladyjoker): This is used above and it's a hack because something is off with PMaybeData instances.
557+
-- HACK(bladyjoker): This is used above and it's a hack because something is off with PMaybeData instances.
508558
maybeToMaybe :: Term s (PAsData (PMaybe a) :--> PAsData (PMaybeData a))
509559
maybeToMaybe =
510560
phoistAcyclic $
@@ -581,6 +631,7 @@ instance (PTryFrom PData (PAsData a)) => PTryFrom PData (PAsData (PFoo a)) where
581631
(LamVal.pfromPlutusDataPTryFrom # pd)
582632
(LamVal.pfromPlutusDataPTryFrom # pd)
583633
(LamVal.pfromPlutusDataPTryFrom # pd)
634+
(LamVal.pfromPlutusDataPTryFrom # pd)
584635
, ()
585636
)
586637

@@ -598,9 +649,6 @@ instance GHC.TypeError ('GHC.Text "LambdaBuffers Prelude.Char not implemented")
598649
instance GHC.TypeError ('GHC.Text "LambdaBuffers Prelude.Char not implemented") => PEq PChar where
599650
(#==) _l _r = error "unreachable"
600651

601-
-- | Not implemented.
602-
data PSet (a :: PType) (s :: S) = PSet
603-
604652
instance GHC.TypeError ('GHC.Text "LambdaBuffers Prelude.Set not implemented") => PlutusType (PSet a) where
605653
type PInner (PSet a) = PData
606654
pcon' PSet = error "unreachable"
@@ -626,6 +674,10 @@ instance PIsData (PEither a b) where
626674
pdataImpl = punsafeCoerce
627675
pfromDataImpl = punsafeCoerce
628676

677+
instance PIsData (PList a) where
678+
pdataImpl = punsafeCoerce
679+
pfromDataImpl = punsafeCoerce
680+
629681
instance PEq (PFoo a) where
630682
(#==) l r = pdata l #== pdata r
631683

@@ -635,5 +687,23 @@ instance PEq (PMaybe a) where
635687
instance PEq (PEither a b) where
636688
(#==) l r = pdata l #== pdata r
637689

690+
instance PEq (PList a) where
691+
(#==) l r = Pl.plistEquals # Pl.pto l # Pl.pto r
692+
638693
pcon :: (PlutusType a, PIsData a) => a s -> Term s (PAsData a)
639694
pcon = pdata . Pl.pcon
695+
696+
{- | PListLike instance was a problem for PList, so this is done instead.
697+
698+
TODO(bladyjoker): Upstream with PList and plan to remove.
699+
-}
700+
caseList :: (PIsData a) => (Term s a -> Term s (PList a) -> Term s r) -> Term s r -> Term s (PList a) -> Term s r
701+
caseList consCase nilCase ls = pmatch (Pl.pto ls) $ \case
702+
Pl.PCons x xs -> consCase (Pl.pfromData x) (Pl.pcon $ PList xs)
703+
Pl.PNil -> nilCase
704+
705+
pcons :: PIsData a => Term s (a :--> (PList a :--> PList a))
706+
pcons = phoistAcyclic $ plam $ \x xs -> Pl.pcon $ PList (Pl.pcons # Pl.pdata x # Pl.pto xs)
707+
708+
pnil :: Term s (PList a)
709+
pnil = Pl.pcon $ PList $ Pl.pcon Pl.PNil

‎runtimes/haskell/lbr-plutarch/test/Test.hs

Lines changed: 12 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,12 @@
1+
module Main (main) where
2+
3+
import Test.LambdaBuffers.Runtime.Plutarch qualified as Pl
4+
import Test.Tasty (defaultMain, testGroup)
5+
6+
main :: IO ()
7+
main =
8+
defaultMain $
9+
testGroup
10+
"LambdaBuffers `lbr-plutarch` tests"
11+
[ Pl.test
12+
]

‎runtimes/haskell/lbr-plutarch/test/Test/LambdaBuffers/Runtime/Plutarch.hs

Lines changed: 48 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,48 @@
1+
module Test.LambdaBuffers.Runtime.Plutarch (test) where
2+
3+
import Control.Monad.IO.Class (MonadIO (liftIO))
4+
import Hedgehog qualified as H
5+
import Hedgehog.Gen qualified as Gen
6+
import Hedgehog.Range qualified as Range
7+
import LambdaBuffers.Runtime.Plutarch (PList)
8+
import LambdaBuffers.Runtime.Plutarch qualified as Lb
9+
import Plutarch (ClosedTerm, Config (Config), Term, TracingMode (DoTracingAndBinds), compile, pcon, perror, (#))
10+
import Plutarch.Evaluate (evalScript)
11+
import Plutarch.Prelude (PBool (PTrue), PEq ((#==)), PInteger, PIsData, pconstant, pif)
12+
import Test.Tasty (TestTree, adjustOption, testGroup)
13+
import Test.Tasty.HUnit (assertFailure)
14+
import Test.Tasty.Hedgehog (testProperty)
15+
import Test.Tasty.Hedgehog qualified as H
16+
17+
test :: TestTree
18+
test =
19+
adjustOption (\_ -> H.HedgehogTestLimit $ Just 1000) $
20+
testGroup
21+
"PList tests"
22+
[ testProperty "forall xs :: [Integer] ys :: [Integer]. (xs == ys) === evalEq (toPlutarch xs) (toPlutarch ys)" $
23+
H.property $
24+
H.forAll
25+
((,) <$> genInts <*> genInts)
26+
>>= ( \(xs, ys) -> do
27+
b <- liftIO $ evalEq (fromList $ pconstant <$> xs) (fromList $ pconstant <$> ys)
28+
(xs == ys) H.=== b
29+
)
30+
]
31+
where
32+
genInts :: H.Gen [Integer]
33+
genInts = Gen.list (Range.linear 0 100) (Gen.integral (Range.linear 0 100))
34+
35+
fromList :: PIsData a => [Term s a] -> Term s (PList a)
36+
fromList = foldr (\x -> (#) (Lb.pcons # x)) Lb.pnil
37+
38+
evalEq :: ClosedTerm (PList PInteger) -> ClosedTerm (PList PInteger) -> IO Bool
39+
evalEq l r =
40+
let
41+
t :: ClosedTerm PBool
42+
t = pif (l #== r) (pcon PTrue) perror
43+
in
44+
case Plutarch.compile (Config DoTracingAndBinds) t of
45+
Left err -> assertFailure $ show ("Error while compiling a Plutarch Term" :: String, err)
46+
Right script -> case evalScript script of
47+
(Left _err, _, _) -> return False
48+
_ -> return True

‎runtimes/haskell/lbr-prelude/src/LambdaBuffers/Runtime/Prelude/Generators/Correct.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -17,7 +17,7 @@ genInteger :: H.Gen Integer
1717
genInteger = H.integral (HR.constant (-100000000000000000000000000000000000000000000000) 100000000000000000000000000000000000000000000000)
1818

1919
genChar :: H.Gen Char
20-
genChar = H.unicode -- TODO(bladyjoker): Using H.unicodeAll breaks the tests \65533 != \55296
20+
genChar = H.unicode -- WARN(bladyjoker): Using H.unicodeAll breaks the tests \65533 != \55296
2121

2222
genBytes :: H.Gen ByteString
2323
genBytes = H.bytes (HR.constant 0 500)

‎testsuites/lbt-plutus/api/Foo.lbf

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -58,7 +58,7 @@ prod E a b = Address
5858
TxOut
5959
(Maybe a)
6060
(Either a b)
61-
-- (List b) -- FIXME(bladyjoker): Using PBuiltinList in Plutarch breaks the compilation.
61+
(List b)
6262

6363
derive Eq (E a b)
6464
derive Json (E a b)

0 commit comments

Comments
 (0)