Codegen: Purescript module

docs/compiler-api.md

@@ -126,13 +126,15 @@ other type class. Concretely, if we wish to provide JSON serialization for
 LambdaBuffers types, we declare such a type class and provide desired
 semantic rules:
 
-```lbf module Foo
+```lbf
+module Foo
 
 class JSON a
 
 sum Foo a b = Bar a | Baz b
 
-derive JSON (Foo a b) ```
+derive JSON (Foo a b)
+```
 
 Note that for each type class introduced, the Codegen machinery must be
 updated to support said type class. In other words, it doesn't come for free

experimental/ctl-env/Makefile

@@ -0,0 +1,11 @@
+demo:
+	rm -fr .work-dir
+	mkdir .work-dir
+	lbf compile --debug --compiler `which lbc` -w .work-dir -i lbf-base -i api/ -f api/Demo.lbf
+	lbg gen-purescript --debug -i .work-dir/compiler-input.textproto -o .work-dir/codegen-output.textproto -p autogen
+
+coop:
+	rm -fr .work-dir
+	mkdir .work-dir
+	lbf compile --debug --compiler `which lbc` -w .work-dir -i lbf-base -i api/ -f api/Coop.lbf
+	lbg gen-purescript --debug -i .work-dir/compiler-input.textproto -o .work-dir/codegen-output.textproto -p autogen

experimental/ctl-env/api/Coop.lbf

@@ -0,0 +1,46 @@
+module Coop
+
+import Prelude (Eq)
+import Plutus (PlutusData)
+import Plutus.V1
+
+record FsDatum = {
+  fact : FactStatement,
+  id : FactStatementId,
+  retireAfter : Extended POSIXTime,
+  submitter : PubKeyHash
+ }
+derive Eq FsDatum
+derive PlutusData FsDatum
+
+prod FactStatementId = Bytes
+derive Eq FactStatementId
+derive PlutusData FactStatementId
+
+prod FactStatement = PlutusData
+derive Eq FactStatement
+derive PlutusData FactStatement
+
+record CertDatum = {
+  id : AuthBatchId,
+  validity : POSIXTimeRange,
+  redeemer : AssetClass
+ }
+derive Eq CertDatum
+derive PlutusData CertDatum
+
+prod AuthBatchId = Bytes
+derive Eq AuthBatchId
+derive PlutusData AuthBatchId
+
+sum CertMpRedeemer = Burn | Mint
+derive Eq CertMpRedeemer
+derive PlutusData CertMpRedeemer
+
+sum AuthMpRedeemer = Burn | Mint
+derive Eq AuthMpRedeemer
+derive PlutusData AuthMpRedeemer
+
+sum FpMpRedeemer = Burn | Mint
+derive Eq FpMpRedeemer
+derive PlutusData FpMpRedeemer

experimental/ctl-env/api/Demo.lbf

@@ -0,0 +1,22 @@
+module Demo
+
+import Prelude
+
+record User = {
+  firstName : Text,
+  lastName : Text,
+  id : NationalId
+ }
+derive Eq User
+
+sum NationalId = CroatianPassport CroatianOIB Picture | CroatianIdCard CroatianOIB | SwissVis SwissVisaType
+derive Eq NationalId
+
+prod CroatianOIB = Integer
+derive Eq CroatianOIB
+
+prod Picture = Text
+derive Eq Picture
+
+sum SwissVisaType = L | B | C
+derive Eq SwissVisaType

experimental/ctl-env/build.nix

@@ -1,4 +1,4 @@
-{ system, nixpkgs, ctl, lbf, lbc, lbg }:
+{ system, nixpkgs, ctl, lbf, lbc, lbg, lbf-base }:
 let
   nixpkgsFor = system: import nixpkgs {
     inherit system;
@@ -20,8 +20,6 @@ in
     packages = with pkgs; [
       bashInteractive
       fd
-      nodePackages.eslint
-      nodePackages.prettier
       lbf
       lbc
       lbg
@@ -31,6 +29,8 @@ in
         export LC_CTYPE=C.UTF-8
         export LC_ALL=C.UTF-8
         export LANG=C.UTF-8
+        rm -f lbf-base
+        ln -s ${lbf-base} lbf-base
       '';
   };
 }).devShell

experimental/ctl-env/runtime/LambdaBuffers/Runtime/PlutusLedgerApi.purs

@@ -0,0 +1,7 @@
+module LambdaBuffers.Runtime.PlutusLedgerApi (AssetClass) where
+
+import Ctl.Internal.Plutus.Types.CurrencySymbol (CurrencySymbol)
+import Ctl.Internal.Types.TokenName (TokenName)
+import Data.Tuple.Nested (type (/\))
+
+type AssetClass = CurrencySymbol /\ TokenName

experimental/ctl-env/spago.dhall

@@ -34,5 +34,5 @@ You can edit this file as you like.
   , "uint"
   ]
 , packages = ./packages.dhall
-, sources = [ "src/**/*.purs", "exe/**/*.purs", "test/**/*.purs" ]
+, sources = [ "runtime/**/*.purs", "autogen/**/*.purs" ]
 }

experimental/lbf-base/Plutus/V1.lbf

@@ -23,11 +23,6 @@ opaque PubKeyHash
 instance PlutusData PubKeyHash
 instance Eq PubKeyHash
 
--- PlutusLedgerApi.V1.DCert
-opaque DCert
-instance PlutusData DCert
-instance Eq DCert
-
 -- PlutusLedgerApi.V1.Bytes
 opaque Bytes
 instance PlutusData Bytes
@@ -97,33 +92,11 @@ opaque ScriptHash
 instance PlutusData ScriptHash
 instance Eq ScriptHash
 
--- PlutusLedgerApi.V1.Contexts
-opaque ScriptContext
-instance PlutusData ScriptContext
-instance Eq ScriptContext
-
-opaque ScriptPurpose
-instance PlutusData ScriptPurpose
-instance Eq ScriptPurpose
-
-opaque TxInInfo
-instance PlutusData TxInInfo
-instance Eq TxInInfo
-
-opaque TxInfo
-instance PlutusData TxInfo
-instance Eq TxInfo
-
-
 -- PlutusLedgerApi.V1.Tx
 opaque TxId
 instance PlutusData TxId
 instance Eq TxId
 
-opaque TxOut
-instance PlutusData TxOut
-instance Eq TxOut
-
 opaque TxOutRef
 instance PlutusData TxOutRef
 instance Eq TxOutRef

experimental/lbf-base/Plutus/V1/Todo.lbf

@@ -0,0 +1,31 @@
+module Plutus.V1.Todo
+
+import Plutus
+import Prelude
+
+-- PlutusLedgerApi.V1.DCert
+opaque DCert
+instance PlutusData DCert
+instance Eq DCert
+
+-- PlutusLedgerApi.V1.Contexts
+opaque ScriptContext
+instance PlutusData ScriptContext
+instance Eq ScriptContext
+
+opaque ScriptPurpose
+instance PlutusData ScriptPurpose
+instance Eq ScriptPurpose
+
+opaque TxInInfo
+instance PlutusData TxInInfo
+instance Eq TxInInfo
+
+opaque TxInfo
+instance PlutusData TxInfo
+instance Eq TxInfo
+
+-- PlutusLedgerApi.V1.Tx
+opaque TxOut
+instance PlutusData TxOut
+instance Eq TxOut

experimental/lbf-base/Prelude.lbf

@@ -10,38 +10,10 @@ opaque Integer
 
 instance Eq Integer
 
-opaque Int8
-
-instance Eq Int8
-
-opaque Int16
-
-instance Eq Int16
-
 opaque Int32
 
 instance Eq Int32
 
-opaque Int64
-
-instance Eq Int64
-
-opaque UInt8
-
-instance Eq UInt8
-
-opaque UInt16
-
-instance Eq UInt16
-
-opaque UInt32
-
-instance Eq UInt32
-
-opaque UInt64
-
-instance Eq UInt64
-
 opaque Bytes
 
 instance Eq Bytes

flake.nix

@@ -121,6 +121,7 @@
           ctlShell = import ./experimental/ctl-env/build.nix {
             inherit system; inherit (inputs) nixpkgs ctl;
             inherit (clis) lbf lbc lbg;
+            lbf-base = ./experimental/lbf-base;
           };
           # Purescript/cardano-transaction-lib shell
           plutusTxShell = import ./experimental/plutustx-env/build.nix {

lambda-buffers-codegen/app/LambdaBuffers/Codegen/Cli/GenPurescript.hs

@@ -0,0 +1,31 @@
+module LambdaBuffers.Codegen.Cli.GenPurescript (GenOpts (..), gen) where
+
+import Control.Lens (makeLenses, (^.))
+import Data.Aeson (decodeFileStrict)
+import LambdaBuffers.Codegen.Cli.Gen qualified as Gen
+import LambdaBuffers.Codegen.Purescript (runPrint)
+import LambdaBuffers.Codegen.Purescript.Config qualified as H
+import Paths_lambda_buffers_codegen qualified as Paths
+
+data GenOpts = MkGenOpts
+  { _common :: Gen.GenOpts
+  , _config :: Maybe FilePath
+  }
+
+makeLenses 'MkGenOpts
+
+gen :: GenOpts -> IO ()
+gen opts = do
+  cfgFp <- maybe (Paths.getDataFileName "data/purescript.json") pure (opts ^. config)
+  cfg <- readPurescriptConfig cfgFp
+
+  Gen.gen
+    (opts ^. common)
+    (\ci -> runPrint cfg ci <$> ci ^. #modules)
+
+readPurescriptConfig :: FilePath -> IO H.Config
+readPurescriptConfig f = do
+  mayCfg <- decodeFileStrict f
+  case mayCfg of
+    Nothing -> error $ "Invalid Purescript configuration file " <> f
+    Just cfg -> return cfg

lambda-buffers-codegen/app/Main.hs

@@ -3,6 +3,7 @@ module Main (main) where
 import Control.Applicative (optional, (<**>))
 import LambdaBuffers.Codegen.Cli.Gen (GenOpts (GenOpts))
 import LambdaBuffers.Codegen.Cli.GenHaskell qualified as Haskell
+import LambdaBuffers.Codegen.Cli.GenPurescript qualified as Purescript
 import Options.Applicative (
   Parser,
   ParserInfo,
@@ -26,8 +27,9 @@ import Options.Applicative (
   value,
  )
 
-newtype Command
+data Command
   = GenHaskell Haskell.GenOpts
+  | GenPurescript Purescript.GenOpts
 
 genOptsP :: Parser GenOpts
 genOptsP =
@@ -73,12 +75,28 @@ haskellGenOptsP =
           )
       )
 
+purescriptGenOptsP :: Parser Purescript.GenOpts
+purescriptGenOptsP =
+  Purescript.MkGenOpts
+    <$> genOptsP
+    <*> optional
+      ( strOption
+          ( long "config"
+              <> short 'c'
+              <> metavar "FILEPATH"
+              <> help "Configuration file for the Purescript codegen module"
+          )
+      )
+
 optionsP :: Parser Command
 optionsP =
   subparser $
     command
       "gen-haskell"
       (info (GenHaskell <$> haskellGenOptsP <* helper) (progDesc "Generate Haskell code from a compiled LambdaBuffers schema"))
+      <> command
+        "gen-purescript"
+        (info (GenPurescript <$> purescriptGenOptsP <* helper) (progDesc "Generate Purescript code from a compiled LambdaBuffers schema"))
 
 parserInfo :: ParserInfo Command
 parserInfo = info (optionsP <**> helper) (fullDesc <> progDesc "LambdaBuffers Codegen command-line interface tool")
@@ -88,3 +106,4 @@ main = do
   cmd <- customExecParser (prefs (showHelpOnEmpty <> showHelpOnError)) parserInfo
   case cmd of
     GenHaskell opts -> Haskell.gen opts
+    GenPurescript opts -> Purescript.gen opts

lambda-buffers-codegen/data/goldens/autogen/LambdaBuffers/Prelude.hs → lambda-buffers-codegen/data/goldens/haskell-autogen/LambdaBuffers/Prelude.hs

@@ -2,46 +2,31 @@ module LambdaBuffers.Prelude (Bool(..)
                              , Bytes(..)
                              , Char(..)
                              , Either(..)
-                             , Int16(..)
                              , Int32(..)
-                             , Int64(..)
-                             , Int8(..)
                              , Integer(..)
                              , List(..)
                              , Map(..)
                              , Maybe(..)
                              , Set(..)
-                             , Text(..)
-                             , UInt16(..)
-                             , UInt32(..)
-                             , UInt64(..)
-                             , UInt8(..)) where
+                             , Text(..)) where
 
 import qualified Data.ByteString
 import qualified Data.Int
 import qualified Data.Map
 import qualified Data.Set
 import qualified Data.Text
-import qualified Data.Word
 import qualified LambdaBuffers.Runtime.Haskell
 import qualified Prelude
 
 type Bool = Prelude.Bool
 type Bytes = Data.ByteString.ByteString
 type Char = Prelude.Char
 type Either a b = Prelude.Either a b
-type Int16 = Data.Int.Int16
 type Int32 = Data.Int.Int32
-type Int64 = Data.Int.Int64
-type Int8 = Data.Int.Int8
 type Integer = Prelude.Integer
 type List a = LambdaBuffers.Runtime.Haskell.List a
 type Map a b = Data.Map.Map a b
 type Maybe a = Prelude.Maybe a
 type Set a = Data.Set.Set a
 type Text = Data.Text.Text
-type UInt16 = Data.Word.Word16
-type UInt32 = Data.Word.Word32
-type UInt64 = Data.Word.Word64
-type UInt8 = Data.Word.Word8