Skip to content

Commit 680b192

Browse files
bladyjokerbladyjoker
committed
Plutarch example done and update the PList to align with others
1 parent 50b74dd commit 680b192

File tree

13 files changed

+437
-67
lines changed

13 files changed

+437
-67
lines changed

‎.gitignore

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -16,3 +16,6 @@ result
1616
**/dist
1717
**/output
1818
.DS_Store
19+
**/.work
20+
**/.extras
21+
**/autogen

‎docs/plutarch/.envrc

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
use flake ..#dev-plutarch-example

‎docs/plutarch/api/Example.lbf

Lines changed: 54 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,54 @@
1+
module Example
2+
3+
import Prelude
4+
import Plutus.V1 (PlutusData)
5+
import qualified Plutus.V1 (Bytes, AssetClass, POSIXTime)
6+
7+
-- Reference a UTxO or an entity using its unique asset class.
8+
prod Ref a = Plutus.V1.AssetClass
9+
10+
derive Eq (Ref a)
11+
derive Json (Ref a)
12+
derive PlutusData (Ref a)
13+
14+
-- User has a name, some friends and a status
15+
record User = {
16+
name : Plutus.V1.Bytes,
17+
status : Status,
18+
friends : List (Ref User)
19+
}
20+
21+
derive Eq User
22+
derive Json User
23+
derive PlutusData User
24+
25+
sum Status = Active Plutus.V1.POSIXTime | Inactive Plutus.V1.POSIXTime
26+
27+
derive Eq Status
28+
derive Json Status
29+
derive PlutusData Status
30+
31+
-- Message can be exchanged between users.
32+
record Message = {
33+
time : Plutus.V1.POSIXTime,
34+
from : Ref User,
35+
to : Ref User,
36+
content : Content
37+
}
38+
39+
derive Eq Message
40+
derive Json Message
41+
derive PlutusData Message
42+
43+
sum Content = Text Plutus.V1.Bytes | Emoji Emoji
44+
45+
derive Eq Content
46+
derive Json Content
47+
derive PlutusData Content
48+
49+
sum Emoji = ThumbsUp | ThumbsDown | NoThumbs
50+
51+
derive Eq Emoji
52+
derive Json Emoji
53+
derive PlutusData Emoji
54+

‎docs/plutarch/app/Example.hs

Lines changed: 116 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,116 @@
1+
module Main (main) where
2+
3+
import Data.Text (Text)
4+
import Data.Text.Encoding qualified as Text
5+
import LambdaBuffers.Example.Plutarch (
6+
Content (Content'Text),
7+
Message (Message),
8+
Ref (Ref),
9+
Status (Status'Active),
10+
User (User),
11+
)
12+
import LambdaBuffers.Plutus.V1.Plutarch (Bytes, POSIXTime)
13+
import LambdaBuffers.Prelude.Plutarch ()
14+
import LambdaBuffers.Runtime.Plutarch (PList (PList))
15+
import LambdaBuffers.Runtime.Plutarch qualified as Lb
16+
import Plutarch (ClosedTerm, Config (Config), PlutusType, Term, TracingMode (DoTracingAndBinds), compile, pcon, perror, plam, pmatch, unTermCont, (#), (:-->))
17+
import Plutarch.Api.V1 (PCurrencySymbol (PCurrencySymbol), PTokenName (PTokenName), ptuple)
18+
import Plutarch.Api.V1.Time (PPOSIXTime (PPOSIXTime))
19+
import Plutarch.ByteString (PByteString)
20+
import Plutarch.Evaluate (evalScript)
21+
import Plutarch.Extra.TermCont (pletC, pmatchC)
22+
import Plutarch.Maybe qualified as Scott
23+
import Plutarch.Prelude (PAsData, PBool (PFalse, PTrue), PBuiltinList, PEq ((#==)), PIsData, pconstant, pdata, pfind, pfromData, pif, pshow, ptrace, (#&&))
24+
25+
userRef :: Text -> Term s (Ref User)
26+
userRef userName = userRef' (pfromData $ name userName)
27+
28+
userRef' :: Term s Bytes -> Term s (Ref User)
29+
userRef' userName = pcon $ Ref (pdata $ ptuple # pcon' (PCurrencySymbol (pconstant "users")) # pcon' (PTokenName userName))
30+
31+
activeUser :: Text -> [Term s (Ref User)] -> Integer -> Term s User
32+
activeUser n friends since = pcon $ User (name n) (pdata $ activeSince since) (pdata $ Lb.plistFrom friends)
33+
34+
activeSince :: Integer -> Term s Status
35+
activeSince since = pcon (Status'Active (pcon' $ PPOSIXTime (pconstant since)))
36+
37+
name :: Text -> Term s (PAsData PByteString)
38+
name = textToBytes
39+
40+
message :: Term s POSIXTime -> Term s (Ref User) -> Term s (Ref User) -> Term s Content -> Term s Message
41+
message at from to content = pcon $ Message (pdata at) (pdata from) (pdata to) (pdata content)
42+
43+
-- | `isFriendly users msg` checks whether a "'sup" message is exchanged between friends.
44+
isFriendly :: Term s (Lb.PList User :--> Message :--> PBool)
45+
isFriendly = plam $ \users msg -> unTermCont $ do
46+
Message _at from to content <- pmatchC msg
47+
PList users' <- pmatchC users
48+
User fromName _ fromFriends <- pmatchC (pfromData $ findUserOrError # users' # pfromData from)
49+
User toName _ toFriends <- pmatchC (pfromData $ findUserOrError # users' # pfromData to)
50+
pletC $
51+
pif
52+
( (isFriend # fromFriends # toName)
53+
#== (isFriend # toFriends # fromName)
54+
#&& (content #== pcon' (Content'Text (textToBytes "'sup")))
55+
)
56+
(pcon PTrue)
57+
(ptrace ("This wasn't a friendly message :(" <> pshow msg) perror)
58+
where
59+
findUser :: Term s (PBuiltinList (PAsData User) :--> Ref User :--> Scott.PMaybe (PAsData User))
60+
findUser = plam $
61+
\users uRef ->
62+
pfind
63+
# plam (\u -> pmatch (pfromData u) (\(User userName _userActiveSince _userFriends) -> userRef' (pfromData userName) #== uRef))
64+
# users
65+
66+
findUserOrError :: Term s (PBuiltinList (PAsData User) :--> Ref User :--> PAsData User)
67+
findUserOrError = plam $
68+
\users uRef ->
69+
pmatch
70+
(findUser # users # uRef)
71+
$ \case
72+
Scott.PJust uName -> uName
73+
Scott.PNothing -> ptrace ("Error while finding a user with reference " <> pshow uRef <> " amongst given users " <> pshow users) perror
74+
75+
isFriend :: Term s (PAsData (Lb.PList (Ref User)) :--> (PAsData Bytes :--> PBool))
76+
isFriend = plam $ \friends uname ->
77+
pmatch
78+
(pfind # plam (\friendRef -> pdata (userRef' (pfromData uname)) #== friendRef) # (toBuiltinList # pfromData friends))
79+
( \case
80+
Scott.PJust _ -> pcon PTrue
81+
_ -> pcon PFalse
82+
)
83+
84+
-- | Utils
85+
pcon' :: PIsData a => PlutusType a => a s -> Term s (PAsData a)
86+
pcon' = pdata . pcon
87+
88+
textToBytes :: Text -> Term s (PAsData PByteString)
89+
textToBytes = pdata . pconstant . Text.encodeUtf8
90+
91+
toBuiltinList :: Term s (Lb.PList a :--> PBuiltinList (PAsData a))
92+
toBuiltinList = plam $ \xs -> pmatch xs (\(Lb.PList xs') -> xs')
93+
94+
evalBool :: ClosedTerm PBool -> IO ()
95+
evalBool t =
96+
case Plutarch.compile (Config DoTracingAndBinds) (pif t (pcon PTrue) (ptrace "Term evaluated to False" perror)) of
97+
Left err -> print ("Error while compiling a Plutarch Term" :: String, err)
98+
Right script -> case evalScript script of
99+
(Left err, _, trace) -> print ("Not a friendly message it seems" :: String, err, trace)
100+
_ -> print ("Friends, peace and love!!!" :: String)
101+
102+
-- | Main program
103+
drazen :: Term s User
104+
drazen = activeUser "Drazen Popovic" [userRef "Gergely Szabó", userRef "Jared Pon"] 0
105+
106+
gergo :: Term s User
107+
gergo = activeUser "Gergely Szabó" [userRef "Jared Pon", userRef "Drazen Popovic"] 1
108+
109+
jared :: Term s User
110+
jared = activeUser "Jared Pon" [userRef "Gergely Szabó", userRef "Drazen Popovic"] 2
111+
112+
supJaredSaidGergo :: Term s Message
113+
supJaredSaidGergo = message (pcon $ PPOSIXTime (pconstant 10)) (userRef "Gergely Szabó") (userRef "Jared Pon") (pcon $ Content'Text (textToBytes "'sup"))
114+
115+
main :: IO ()
116+
main = evalBool $ isFriendly # Lb.plistFrom [drazen, gergo, jared] # supJaredSaidGergo

‎docs/plutarch/build.nix

Lines changed: 77 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,77 @@
1+
{ inputs, ... }:
2+
{
3+
perSystem = { pkgs, config, ... }:
4+
let
5+
project = { lib, ... }: {
6+
src = ./.;
7+
8+
name = "plutarch-example";
9+
10+
inherit (config.settings.haskell) index-state compiler-nix-name;
11+
12+
extraHackage = [
13+
# Load Plutarch support
14+
"${config.packages.lbf-prelude-plutarch}"
15+
"${config.packages.lbf-plutus-plutarch}"
16+
"${config.packages.lbr-plutarch-src}"
17+
# Api
18+
"${config.packages.lbf-plutus-golden-api-plutarch}"
19+
"${config.packages.lbf-plutarch-example-api}"
20+
# Plutarch itself
21+
"${inputs.plutarch}"
22+
"${inputs.plutarch}/plutarch-extra"
23+
];
24+
25+
modules = [
26+
(_: {
27+
packages = {
28+
allComponent.doHoogle = true;
29+
allComponent.doHaddock = true;
30+
31+
# Enable strict compilation
32+
plutarch-example.configureFlags = [ "-f-dev" ];
33+
};
34+
})
35+
];
36+
37+
shell = {
38+
39+
withHoogle = true;
40+
41+
exactDeps = true;
42+
43+
nativeBuildInputs = config.settings.shell.tools;
44+
45+
tools = {
46+
cabal = { };
47+
haskell-language-server = { };
48+
};
49+
50+
shellHook = lib.mkForce config.settings.shell.hook;
51+
};
52+
};
53+
hsNixFlake = (pkgs.haskell-nix.cabalProject' [
54+
inputs.mlabs-tooling.lib.mkHackageMod
55+
inputs.mlabs-tooling.lib.moduleMod
56+
project
57+
]).flake { };
58+
59+
in
60+
61+
{
62+
devShells.dev-plutarch-example = hsNixFlake.devShell;
63+
64+
packages = {
65+
plutarch-example-cli = hsNixFlake.packages."plutarch-example:exe:plutarch-example";
66+
67+
lbf-plutarch-example-api = config.overlayAttrs.lbf-nix.lbfPlutarch {
68+
name = "lbf-plutarch-example-api";
69+
src = ./api;
70+
files = [ "Example.lbf" ];
71+
};
72+
73+
};
74+
75+
76+
};
77+
}

‎docs/plutarch/cabal.project

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,3 @@
1+
packages: ./.
2+
3+
tests: true

‎docs/plutarch/hie.yaml

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,2 @@
1+
cradle:
2+
cabal:

‎docs/plutarch/plutarch-example.cabal

Lines changed: 98 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,98 @@
1+
cabal-version: 3.0
2+
name: plutarch-example
3+
version: 0.1.0.0
4+
synopsis: LambdaBuffers Plutarch example
5+
author: Drazen Popovic
6+
maintainer: [email protected]
7+
8+
flag dev
9+
description: Enable non-strict compilation for development
10+
manual: True
11+
12+
common common-language
13+
ghc-options:
14+
-Wall -Wcompat -fprint-explicit-foralls -fprint-explicit-kinds
15+
-fwarn-missing-import-lists -Weverything -Wno-unsafe
16+
-Wno-missing-safe-haskell-mode -Wno-implicit-prelude
17+
-Wno-missing-kind-signatures -Wno-all-missed-specializations
18+
19+
if !flag(dev)
20+
ghc-options: -Werror
21+
22+
default-extensions:
23+
NoStarIsType
24+
BangPatterns
25+
BinaryLiterals
26+
ConstrainedClassMethods
27+
ConstraintKinds
28+
DataKinds
29+
DeriveAnyClass
30+
DeriveDataTypeable
31+
DeriveFoldable
32+
DeriveFunctor
33+
DeriveGeneric
34+
DeriveLift
35+
DeriveTraversable
36+
DerivingStrategies
37+
DerivingVia
38+
DoAndIfThenElse
39+
DuplicateRecordFields
40+
EmptyCase
41+
EmptyDataDecls
42+
EmptyDataDeriving
43+
ExistentialQuantification
44+
ExplicitForAll
45+
ExplicitNamespaces
46+
FlexibleContexts
47+
FlexibleInstances
48+
ForeignFunctionInterface
49+
GADTSyntax
50+
GeneralizedNewtypeDeriving
51+
HexFloatLiterals
52+
ImportQualifiedPost
53+
InstanceSigs
54+
KindSignatures
55+
LambdaCase
56+
MonomorphismRestriction
57+
MultiParamTypeClasses
58+
NamedFieldPuns
59+
NamedWildCards
60+
NumericUnderscores
61+
OverloadedLabels
62+
OverloadedStrings
63+
PartialTypeSignatures
64+
PatternGuards
65+
PolyKinds
66+
PostfixOperators
67+
RankNTypes
68+
RecordWildCards
69+
RelaxedPolyRec
70+
ScopedTypeVariables
71+
StandaloneDeriving
72+
StandaloneKindSignatures
73+
TemplateHaskell
74+
TraditionalRecordSyntax
75+
TupleSections
76+
TypeApplications
77+
TypeFamilies
78+
TypeOperators
79+
TypeSynonymInstances
80+
ViewPatterns
81+
82+
default-language: Haskell2010
83+
84+
executable plutarch-example
85+
import: common-language
86+
build-depends:
87+
, base >=4.16
88+
, lbf-plutarch-example-api
89+
, lbf-plutus-plutarch
90+
, lbf-prelude-plutarch
91+
, lbr-plutarch
92+
, plutarch
93+
, plutarch-extra
94+
, text >=1.2
95+
96+
hs-source-dirs: app
97+
exposed-modules: Main
98+
main-is: Example.hs

‎flake.nix

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -31,6 +31,7 @@
3131
./pre-commit.nix
3232
./hercules-ci.nix
3333
./docs/build.nix
34+
./docs/plutarch/build.nix
3435
./extras/build.nix
3536
./extras/lbf-nix/build.nix
3637
./libs/build.nix

0 commit comments

Comments
 (0)