diff --git a/404.html b/404.html index ee9116dc..47a1540b 100644 --- a/404.html +++ b/404.html @@ -84,7 +84,7 @@ diff --git a/api.html b/api.html index d28840c7..ab425e3d 100644 --- a/api.html +++ b/api.html @@ -83,7 +83,7 @@ diff --git a/codegen.html b/codegen.html index ac477a7a..71776360 100644 --- a/codegen.html +++ b/codegen.html @@ -83,7 +83,7 @@ diff --git a/command-line-interface.html b/command-line-interface.html index 511bf4cc..ddf9aeec 100644 --- a/command-line-interface.html +++ b/command-line-interface.html @@ -83,7 +83,7 @@ diff --git a/comparison-matrix.html b/comparison-matrix.html index 52f206e6..5176183c 100644 --- a/comparison-matrix.html +++ b/comparison-matrix.html @@ -83,7 +83,7 @@ diff --git a/compiler.html b/compiler.html index 99b87dea..652617f2 100644 --- a/compiler.html +++ b/compiler.html @@ -83,7 +83,7 @@ diff --git a/design.html b/design.html index b0b58a04..8142864b 100644 --- a/design.html +++ b/design.html @@ -83,7 +83,7 @@ diff --git a/getting-started.html b/getting-started.html index 86a9792e..3c9677d7 100644 --- a/getting-started.html +++ b/getting-started.html @@ -83,7 +83,7 @@ diff --git a/haskell.html b/haskell.html index 5b306ec8..edf672df 100644 --- a/haskell.html +++ b/haskell.html @@ -83,7 +83,7 @@ diff --git a/index.html b/index.html index 90c4ec82..63da1f49 100644 --- a/index.html +++ b/index.html @@ -83,7 +83,7 @@ diff --git a/introduction.html b/introduction.html index 90c4ec82..63da1f49 100644 --- a/introduction.html +++ b/introduction.html @@ -83,7 +83,7 @@ diff --git a/plutarch/.envrc b/plutarch/.envrc new file mode 100644 index 00000000..015c0dde --- /dev/null +++ b/plutarch/.envrc @@ -0,0 +1 @@ +use flake ..#dev-plutarch-example diff --git a/plutarch/api/Example.lbf b/plutarch/api/Example.lbf new file mode 100644 index 00000000..eda7a840 --- /dev/null +++ b/plutarch/api/Example.lbf @@ -0,0 +1,54 @@ +module Example + +import Prelude +import Plutus.V1 (PlutusData) +import qualified Plutus.V1 (Bytes, AssetClass, POSIXTime) + +-- Reference a UTxO or an entity using its unique asset class. +prod Ref a = Plutus.V1.AssetClass + +derive Eq (Ref a) +derive Json (Ref a) +derive PlutusData (Ref a) + +-- User has a name, some friends and a status +record User = { + name : Plutus.V1.Bytes, + status : Status, + friends : List (Ref User) +} + +derive Eq User +derive Json User +derive PlutusData User + +sum Status = Active Plutus.V1.POSIXTime | Inactive Plutus.V1.POSIXTime + +derive Eq Status +derive Json Status +derive PlutusData Status + +-- Message can be exchanged between users. +record Message = { + time : Plutus.V1.POSIXTime, + from : Ref User, + to : Ref User, + content : Content +} + +derive Eq Message +derive Json Message +derive PlutusData Message + +sum Content = Text Plutus.V1.Bytes | Emoji Emoji + +derive Eq Content +derive Json Content +derive PlutusData Content + +sum Emoji = ThumbsUp | ThumbsDown | NoThumbs + +derive Eq Emoji +derive Json Emoji +derive PlutusData Emoji + diff --git a/plutarch/app/Example.hs b/plutarch/app/Example.hs new file mode 100644 index 00000000..3fe3802a --- /dev/null +++ b/plutarch/app/Example.hs @@ -0,0 +1,116 @@ +module Main (main) where + +import Data.Text (Text) +import Data.Text.Encoding qualified as Text +import LambdaBuffers.Example.Plutarch ( + Content (Content'Text), + Message (Message), + Ref (Ref), + Status (Status'Active), + User (User), + ) +import LambdaBuffers.Plutus.V1.Plutarch (Bytes, POSIXTime) +import LambdaBuffers.Prelude.Plutarch () +import LambdaBuffers.Runtime.Plutarch (PList (PList)) +import LambdaBuffers.Runtime.Plutarch qualified as Lb +import Plutarch (ClosedTerm, Config (Config), PlutusType, Term, TracingMode (DoTracingAndBinds), compile, pcon, perror, plam, pmatch, unTermCont, (#), (:-->)) +import Plutarch.Api.V1 (PCurrencySymbol (PCurrencySymbol), PTokenName (PTokenName), ptuple) +import Plutarch.Api.V1.Time (PPOSIXTime (PPOSIXTime)) +import Plutarch.ByteString (PByteString) +import Plutarch.Evaluate (evalScript) +import Plutarch.Extra.TermCont (pletC, pmatchC) +import Plutarch.Maybe qualified as Scott +import Plutarch.Prelude (PAsData, PBool (PFalse, PTrue), PBuiltinList, PEq ((#==)), PIsData, pconstant, pdata, pfind, pfromData, pif, pshow, ptrace, (#&&)) + +userRef :: Text -> Term s (Ref User) +userRef userName = userRef' (pfromData $ name userName) + +userRef' :: Term s Bytes -> Term s (Ref User) +userRef' userName = pcon $ Ref (pdata $ ptuple # pcon' (PCurrencySymbol (pconstant "users")) # pcon' (PTokenName userName)) + +activeUser :: Text -> [Term s (Ref User)] -> Integer -> Term s User +activeUser n friends since = pcon $ User (name n) (pdata $ activeSince since) (pdata $ Lb.plistFrom friends) + +activeSince :: Integer -> Term s Status +activeSince since = pcon (Status'Active (pcon' $ PPOSIXTime (pconstant since))) + +name :: Text -> Term s (PAsData PByteString) +name = textToBytes + +message :: Term s POSIXTime -> Term s (Ref User) -> Term s (Ref User) -> Term s Content -> Term s Message +message at from to content = pcon $ Message (pdata at) (pdata from) (pdata to) (pdata content) + +-- | `isFriendly users msg` checks whether a "'sup" message is exchanged between friends. +isFriendly :: Term s (Lb.PList User :--> Message :--> PBool) +isFriendly = plam $ \users msg -> unTermCont $ do + Message _at from to content <- pmatchC msg + PList users' <- pmatchC users + User fromName _ fromFriends <- pmatchC (pfromData $ findUserOrError # users' # pfromData from) + User toName _ toFriends <- pmatchC (pfromData $ findUserOrError # users' # pfromData to) + pletC $ + pif + ( (isFriend # fromFriends # toName) + #== (isFriend # toFriends # fromName) + #&& (content #== pcon' (Content'Text (textToBytes "'sup"))) + ) + (pcon PTrue) + (ptrace ("This wasn't a friendly message :(" <> pshow msg) perror) + where + findUser :: Term s (PBuiltinList (PAsData User) :--> Ref User :--> Scott.PMaybe (PAsData User)) + findUser = plam $ + \users uRef -> + pfind + # plam (\u -> pmatch (pfromData u) (\(User userName _userActiveSince _userFriends) -> userRef' (pfromData userName) #== uRef)) + # users + + findUserOrError :: Term s (PBuiltinList (PAsData User) :--> Ref User :--> PAsData User) + findUserOrError = plam $ + \users uRef -> + pmatch + (findUser # users # uRef) + $ \case + Scott.PJust uName -> uName + Scott.PNothing -> ptrace ("Error while finding a user with reference " <> pshow uRef <> " amongst given users " <> pshow users) perror + + isFriend :: Term s (PAsData (Lb.PList (Ref User)) :--> (PAsData Bytes :--> PBool)) + isFriend = plam $ \friends uname -> + pmatch + (pfind # plam (\friendRef -> pdata (userRef' (pfromData uname)) #== friendRef) # (toBuiltinList # pfromData friends)) + ( \case + Scott.PJust _ -> pcon PTrue + _ -> pcon PFalse + ) + +-- | Utils +pcon' :: PIsData a => PlutusType a => a s -> Term s (PAsData a) +pcon' = pdata . pcon + +textToBytes :: Text -> Term s (PAsData PByteString) +textToBytes = pdata . pconstant . Text.encodeUtf8 + +toBuiltinList :: Term s (Lb.PList a :--> PBuiltinList (PAsData a)) +toBuiltinList = plam $ \xs -> pmatch xs (\(Lb.PList xs') -> xs') + +evalBool :: ClosedTerm PBool -> IO () +evalBool t = + case Plutarch.compile (Config DoTracingAndBinds) (pif t (pcon PTrue) (ptrace "Term evaluated to False" perror)) of + Left err -> print ("Error while compiling a Plutarch Term" :: String, err) + Right script -> case evalScript script of + (Left err, _, trace) -> print ("Not a friendly message it seems" :: String, err, trace) + _ -> print ("Friends, peace and love!!!" :: String) + +-- | Main program +drazen :: Term s User +drazen = activeUser "Drazen Popovic" [userRef "Gergely Szabó", userRef "Jared Pon"] 0 + +gergo :: Term s User +gergo = activeUser "Gergely Szabó" [userRef "Jared Pon", userRef "Drazen Popovic"] 1 + +jared :: Term s User +jared = activeUser "Jared Pon" [userRef "Gergely Szabó", userRef "Drazen Popovic"] 2 + +supJaredSaidGergo :: Term s Message +supJaredSaidGergo = message (pcon $ PPOSIXTime (pconstant 10)) (userRef "Gergely Szabó") (userRef "Jared Pon") (pcon $ Content'Text (textToBytes "'sup")) + +main :: IO () +main = evalBool $ isFriendly # Lb.plistFrom [drazen, gergo, jared] # supJaredSaidGergo diff --git a/plutarch/build.nix b/plutarch/build.nix new file mode 100644 index 00000000..e5e76404 --- /dev/null +++ b/plutarch/build.nix @@ -0,0 +1,77 @@ +{ inputs, ... }: +{ + perSystem = { pkgs, config, ... }: + let + project = { lib, ... }: { + src = ./.; + + name = "plutarch-example"; + + inherit (config.settings.haskell) index-state compiler-nix-name; + + extraHackage = [ + # Load Plutarch support + "${config.packages.lbf-prelude-plutarch}" + "${config.packages.lbf-plutus-plutarch}" + "${config.packages.lbr-plutarch-src}" + # Api + "${config.packages.lbf-plutus-golden-api-plutarch}" + "${config.packages.lbf-plutarch-example-api}" + # Plutarch itself + "${inputs.plutarch}" + "${inputs.plutarch}/plutarch-extra" + ]; + + modules = [ + (_: { + packages = { + allComponent.doHoogle = true; + allComponent.doHaddock = true; + + # Enable strict compilation + plutarch-example.configureFlags = [ "-f-dev" ]; + }; + }) + ]; + + shell = { + + withHoogle = true; + + exactDeps = true; + + nativeBuildInputs = config.settings.shell.tools ++ [ config.packages.lbf-plutus-to-plutarch ]; + + tools = { + cabal = { }; + haskell-language-server = { }; + }; + + shellHook = lib.mkForce config.settings.shell.hook; + }; + }; + hsNixFlake = (pkgs.haskell-nix.cabalProject' [ + inputs.mlabs-tooling.lib.mkHackageMod + inputs.mlabs-tooling.lib.moduleMod + project + ]).flake { }; + + in + + { + devShells.dev-plutarch-example = hsNixFlake.devShell; + + packages = { + plutarch-example-cli = hsNixFlake.packages."plutarch-example:exe:plutarch-example"; + + lbf-plutarch-example-api = config.overlayAttrs.lbf-nix.lbfPlutarch { + name = "lbf-plutarch-example-api"; + src = ./api; + files = [ "Example.lbf" ]; + }; + + }; + + + }; +} diff --git a/plutarch/cabal.project b/plutarch/cabal.project new file mode 100644 index 00000000..bd0d96f4 --- /dev/null +++ b/plutarch/cabal.project @@ -0,0 +1,3 @@ +packages: ./. + +tests: true diff --git a/plutarch/hie.yaml b/plutarch/hie.yaml new file mode 100644 index 00000000..04cd2439 --- /dev/null +++ b/plutarch/hie.yaml @@ -0,0 +1,2 @@ +cradle: + cabal: diff --git a/plutarch/plutarch-example.cabal b/plutarch/plutarch-example.cabal new file mode 100644 index 00000000..27db1519 --- /dev/null +++ b/plutarch/plutarch-example.cabal @@ -0,0 +1,97 @@ +cabal-version: 3.0 +name: plutarch-example +version: 0.1.0.0 +synopsis: LambdaBuffers Plutarch example +author: Drazen Popovic +maintainer: bladyjoker@gmail.com + +flag dev + description: Enable non-strict compilation for development + manual: True + +common common-language + ghc-options: + -Wall -Wcompat -fprint-explicit-foralls -fprint-explicit-kinds + -fwarn-missing-import-lists -Weverything -Wno-unsafe + -Wno-missing-safe-haskell-mode -Wno-implicit-prelude + -Wno-missing-kind-signatures -Wno-all-missed-specializations + + if !flag(dev) + ghc-options: -Werror + + default-extensions: + NoStarIsType + BangPatterns + BinaryLiterals + ConstrainedClassMethods + ConstraintKinds + DataKinds + DeriveAnyClass + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + DerivingVia + DoAndIfThenElse + DuplicateRecordFields + EmptyCase + EmptyDataDecls + EmptyDataDeriving + ExistentialQuantification + ExplicitForAll + ExplicitNamespaces + FlexibleContexts + FlexibleInstances + ForeignFunctionInterface + GADTSyntax + GeneralizedNewtypeDeriving + HexFloatLiterals + ImportQualifiedPost + InstanceSigs + KindSignatures + LambdaCase + MonomorphismRestriction + MultiParamTypeClasses + NamedFieldPuns + NamedWildCards + NumericUnderscores + OverloadedLabels + OverloadedStrings + PartialTypeSignatures + PatternGuards + PolyKinds + PostfixOperators + RankNTypes + RecordWildCards + RelaxedPolyRec + ScopedTypeVariables + StandaloneDeriving + StandaloneKindSignatures + TemplateHaskell + TraditionalRecordSyntax + TupleSections + TypeApplications + TypeFamilies + TypeOperators + TypeSynonymInstances + ViewPatterns + + default-language: Haskell2010 + +executable plutarch-example + import: common-language + build-depends: + , base >=4.16 + , lbf-plutarch-example-api + , lbf-plutus-plutarch + , lbf-prelude-plutarch + , lbr-plutarch + , plutarch + , plutarch-extra + , text >=1.2 + + hs-source-dirs: app + main-is: Example.hs diff --git a/print.html b/print.html index 5e31060a..0373976c 100644 --- a/print.html +++ b/print.html @@ -84,7 +84,7 @@ @@ -468,6 +468,130 @@
Also like with product types, the constructor has the same name as the type.
+Let's take a look at how LambdaBuffers modules map into Purescript modules and how +LambdaBuffers type definitions map into Purescript type definitions.
+We'll use the lbf-prelude-to-purescript
CLI tool which is just a convenient wrapper over
+the raw lbf
CLI. We can get this tool by either loading the LambdaBuffers Nix
+environment that comes packaged with all the CLI tools:
$ nix develop github:mlabs-haskell/lambda-buffers#lb
+$ lbf<tab>
+lbf lbf-plutus-to-purescript lbf-prelude-to-purescript
+lbf-plutus-to-haskell lbf-prelude-to-haskell
+
+Or we can simply just refer directly to the lbf-prelude-to-purescript
CLI by nix run github:mlabs-haskell/lambda-buffers#lbf-prelude-to-purescript
.
In this chapter, we're going to use the latter option.
+Let's now use lbf-prelude-to-purescript
to process the Document.lbf schema
module Document
+
+-- Importing types
+import Prelude (Text, List, Set, Bytes)
+
+-- Author
+sum Author = Ivan | Jovan | Savo
+
+-- Reviewer
+sum Reviewer = Bob | Alice
+
+-- Document
+record Document a = {
+ author : Author,
+ reviewers : Set Reviewer,
+ content : Chapter a
+ }
+
+-- Chapter
+record Chapter a = {
+ content : a,
+ subChapters : List (Chapter a)
+ }
+
+-- Some actual content
+sum RichContent = Image Bytes | Gif Bytes | Text Text
+
+-- Rich document
+prod RichDocument = (Document RichContent)
+
+$ nix run github:mlabs-haskell/lambda-buffers#lbf-prelude-to-purescript -- Document.lbf
+$ find autogen/
+autogen/
+autogen/build.json
+autogen/LambdaBuffers
+autogen/LambdaBuffers/Document.purs
+
+As we can see the autogen
directory has been created that contains the generated Purescript modules.
+Note the autogen/build.json
file as it contains all the necessary dependencies the generated module needs in order to be properly compiled by purs
compiler.
The outputted Purescript module in autogen/LambdaBuffers/Document.hs
:
module LambdaBuffers.Document (Author(..)
+ , Chapter(..)
+ , Document(..)
+ , Reviewer(..)
+ , RichContent(..)
+ , RichDocument(..)) where
+
+import LambdaBuffers.Prelude as LambdaBuffers.Prelude
+import Data.Generic.Rep as Data.Generic.Rep
+import Data.Newtype as Data.Newtype
+import Data.Show as Data.Show
+import Data.Show.Generic as Data.Show.Generic
+
+
+data Author = Author'Ivan | Author'Jovan | Author'Savo
+derive instance Data.Generic.Rep.Generic Author _
+instance Data.Show.Show Author where
+ show = Data.Show.Generic.genericShow
+
+newtype Chapter a = Chapter { content :: a
+ , subChapters :: LambdaBuffers.Prelude.List (Chapter a)}
+derive instance Data.Newtype.Newtype (Chapter a) _
+derive instance Data.Generic.Rep.Generic (Chapter a) _
+instance (Data.Show.Show a) => Data.Show.Show (Chapter a) where
+ show = Data.Show.Generic.genericShow
+
+newtype Document a = Document { author :: Author
+ , reviewers :: LambdaBuffers.Prelude.Set Reviewer
+ , content :: Chapter a}
+derive instance Data.Newtype.Newtype (Document a) _
+derive instance Data.Generic.Rep.Generic (Document a) _
+instance (Data.Show.Show a) => Data.Show.Show (Document a) where
+ show = Data.Show.Generic.genericShow
+
+data Reviewer = Reviewer'Bob | Reviewer'Alice
+derive instance Data.Generic.Rep.Generic Reviewer _
+instance Data.Show.Show Reviewer where
+ show = Data.Show.Generic.genericShow
+
+data RichContent = RichContent'Image LambdaBuffers.Prelude.Bytes
+ | RichContent'Gif LambdaBuffers.Prelude.Bytes
+ | RichContent'Text LambdaBuffers.Prelude.Text
+derive instance Data.Generic.Rep.Generic RichContent _
+instance Data.Show.Show RichContent where
+ show = Data.Show.Generic.genericShow
+
+newtype RichDocument = RichDocument (Document RichContent)
+derive instance Data.Newtype.Newtype RichDocument _
+derive instance Data.Generic.Rep.Generic RichDocument _
+instance Data.Show.Show RichDocument where
+ show = Data.Show.Generic.genericShow
+
+The types Author
, Reviewer
, and RichContent
have been declared as sum types in the LamdaBuffers schema using the sum
keyword.
As we can see, nothing too surprising here, all the sum
types become data
+in Purescript.
The only thing to notice is that the type name was prepended with '
(single
+quote) to the defined constructor names as to make sure they are unique.
The type RichDocument
have been declared as a product type in the
+LamdaBuffers schema using the prod
keyword.
They become Purescript newtype
if they have a single type in their body, otherwise they are data
.
Note that the constructor has the same name as the type.
+The types Document
and Chapter
have been declared as record types in the
+LamdaBuffers schema using the record
keyword.
They always become Purescript newtype
, and wrapped within is a Purescript
+record type with the fields named exactly like they are named in the
+LambdaBuffers source module.
Also like with product types, the constructor has the same name as the type.
The goal of the LambdaBuffers project is to enable software developers to specify their application types in a common format that can be conveniently @@ -2061,14 +2185,14 @@
Types of the form Time = Present | Past | Future
, which allow a type do be
constructed by one of many variants. Think Rust's enums
.
Types of the form Person = MkPerson Age Name
, where MkPerson
is of Kind
Type->Type->Type
. Product types combine multiple elements into one data type
without tagging the elements.
Types of the form Person = MkPerson { age :: Age, name :: Name }
. Record types
are similar to structs
in most programming languages.