diff --git a/c2uplc.cabal b/c2uplc.cabal index 96d09f1..cd7284d 100644 --- a/c2uplc.cabal +++ b/c2uplc.cabal @@ -1,20 +1,20 @@ -cabal-version: 3.0 -name: c2uplc -version: 1.0.0 -synopsis: UPLC code generator for Covenant IR +cabal-version: 3.0 +name: c2uplc +version: 1.0.0 +synopsis: UPLC code generator for Covenant IR description: An executable converting valid Covenant IR serial forms into UPLC code. -homepage: https://github.com/mlabs-haskell/c2uplc -license: Apache-2.0 -license-file: LICENSE -author: Koz Ross, Sean Hunter -maintainer: koz@mlabs.city, sean@mlabs.city -bug-reports: https://github.com/mlabs-haskell/c2uplc/issues -copyright: (C) MLabs 2025 -category: Covenant -tested-with: ghc ==9.8.4 -build-type: Simple +homepage: https://github.com/mlabs-haskell/c2uplc +license: Apache-2.0 +license-file: LICENSE +author: Koz Ross, Sean Hunter +maintainer: koz@mlabs.city, sean@mlabs.city +bug-reports: https://github.com/mlabs-haskell/c2uplc/issues +copyright: (C) MLabs 2025 +category: Covenant +tested-with: GHC ==9.8.4 +build-type: Simple extra-source-files: CHANGELOG.md README.md @@ -22,16 +22,13 @@ extra-source-files: -- Common sections common lang ghc-options: - -Wall - -Wcompat - -Wredundant-bang-patterns - -Wredundant-strictness-flags - -Wmissing-deriving-strategies - -Woperator-whitespace - -Wambiguous-fields - -Wmisplaced-pragmas - -Wmissing-export-lists - -Wmissing-import-lists + -Wcompat -Wredundant-bang-patterns -Wredundant-strictness-flags + -Wmissing-deriving-strategies -Woperator-whitespace + -Wambiguous-fields -Wmisplaced-pragmas + + -- -Wall + -- -Wmissing-export-lists + -- -Wmissing-import-lists default-extensions: BangPatterns @@ -65,40 +62,44 @@ common lang UndecidableInstances build-depends: - base >=4.19.0.0 && <5, - covenant ==1.3.0, + , base >=4.19.0.0 && <5 + , containers + , covenant ==1.3.0 + , mtl + , optics-core + , optics-extra + , text + , transformers + , vector - default-language: Haskell2010 + default-language: Haskell2010 common test-lang - import: lang - ghc-options: - -O2 - -threaded - -rtsopts - -with-rtsopts=-N - + import: lang + ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N build-depends: - QuickCheck ==2.15.0.1, - c2uplc, - containers >=0.6.8 && <0.8, - prettyprinter ==1.7.1, - tasty ==1.5.3, - tasty-expected-failure ==0.12.3, - tasty-hunit ==0.10.2, - tasty-quickcheck ==0.11.1, + , c2uplc + , containers >=0.6.8 && <0.8 + , prettyprinter ==1.7.1 + , QuickCheck ==2.15.0.1 + , tasty ==1.5.3 + , tasty-expected-failure ==0.12.3 + , tasty-hunit ==0.10.2 + , tasty-quickcheck ==0.11.1 -- Executable executable c2uplc - import: lang - main-is: Main.hs + import: lang + main-is: Main.hs hs-source-dirs: app build-depends: - filepath ==1.4.301.0, - optparse-applicative ==0.19.0.0, + , filepath ==1.4.301.0 + , optparse-applicative ==0.19.0.0 -- Primary library library - import: lang - exposed-modules: Covenant.Codegen - hs-source-dirs: src + import: lang + exposed-modules: Covenant.CodeGen + other-modules: Covenant.MockPlutus + hs-source-dirs: src + build-depends: plutus-core ==1.51.0.0 diff --git a/cabal.project b/cabal.project index 431c720..ec401dd 100644 --- a/cabal.project +++ b/cabal.project @@ -56,13 +56,13 @@ allow-newer: , inline-r:bytestring , inline-r:containers , inline-r:primitive - -allow-newer: + , covenant:QuickCheck + , covenant:quickcheck-instances -- https://github.com/phadej/vec/issues/121 - ral:QuickCheck, - fin:QuickCheck, - bin:QuickCheck, + , ral:QuickCheck + , fin:QuickCheck + , bin:QuickCheck + -- https://github.com/IntersectMBO/plutus/pull/7236 + , turtle:optparse-applicative --- https://github.com/IntersectMBO/plutus/pull/7236 constraints: setup.optparse-applicative >=0.19.0.0 -allow-newer: turtle:optparse-applicative diff --git a/flake.nix b/flake.nix index 7e197d5..22c8a76 100644 --- a/flake.nix +++ b/flake.nix @@ -77,7 +77,6 @@ cabal = { }; haskell-language-server = { }; hlint = { }; - cabal-fmt = { }; fourmolu = { }; hspec-discover = { }; markdown-unlit = { }; diff --git a/src/Covenant/CodeGen.hs b/src/Covenant/CodeGen.hs index c1612ea..a1a8a70 100644 --- a/src/Covenant/CodeGen.hs +++ b/src/Covenant/CodeGen.hs @@ -1,2 +1,176 @@ + module Covenant.CodeGen where +import Covenant.Type +import Covenant.Type qualified as T +import Covenant.ASG +import Covenant.Data +import Covenant.Constant +import Covenant.Prim (OneArgFunc(..),TwoArgFunc(..),ThreeArgFunc(..),SixArgFunc(..)) + +import Control.Monad.Trans.Except +import Control.Monad.Trans.RWS (RWS) +import Control.Monad.Reader.Class (MonadReader, asks) +import Control.Monad.State.Class (MonadState, modify, gets) +import Control.Monad.Error.Class + +import Data.Foldable (foldl') + +import Data.Kind(Type) + +import Data.Map (Map) +import Data.Map qualified as M + +import Data.Word (Word64) + +import Data.Vector (Vector) +import Data.Vector qualified as Vector + +import Data.Text (Text) + +import Optics.Core (set, over, view, (%)) + +import Covenant.MockPlutus + +data CodeGenError + = NoASG + | TermNotInContext Id + | NoDatatype TyName + | ConstructorNotInDatatype TyName ConstructorName + | InvalidOpaqueEncoding Text + + + +newtype CodeGenM a = CodeGenM (ExceptT CodeGenError (RWS (Map TyName (DatatypeInfo AbstractTy)) () (Map Id PlutusTerm)) a) + deriving + ( Functor, + Applicative, + Monad, + MonadReader (Map TyName (DatatypeInfo AbstractTy)), + MonadState (Map Id PlutusTerm), + MonadError CodeGenError + ) via (ExceptT CodeGenError (RWS (Map TyName (DatatypeInfo AbstractTy)) () (Map Id PlutusTerm))) + +lookupTerm :: Id -> CodeGenM PlutusTerm +lookupTerm i = gets (M.lookup i) >>= \case + Nothing -> throwError $ TermNotInContext i + Just term -> pure term + +lookupDatatype :: TyName -> CodeGenM (DatatypeInfo AbstractTy) +lookupDatatype tn = asks (M.lookup tn) >>= \case + Nothing -> throwError $ NoDatatype tn + +generatePLC :: [(Id,ASGNode)] -> CodeGenM PlutusTerm +generatePLC = \case + [] -> throwError NoASG + ((i,n):rest) -> go i n rest + where + go :: Id -> ASGNode -> [(Id,ASGNode)] -> CodeGenM PlutusTerm + go i node rest = case rest of + [] -> nodeToTerm node + ((i',node'):rest') -> do + let letBindable = countOccurs i (node:map snd rest) > 1 + thisTerm <- nodeToTerm node + if letBindable + then do + modify $ M.insert i thisTerm + go i' node' rest' + else do + let iName = idName i + let iVar = pVar iName + modify $ M.insert i iVar + termInner <- go i' node' rest' + pure $ pLam iName termInner `pApp` thisTerm + + +nodeToTerm :: ASGNode -> CodeGenM PlutusTerm +nodeToTerm = \case + ACompNode compTy compNodeInfo -> case compNodeInfo of + Builtin1 bi1 -> pure $ pBuiltin (SomeBuiltin1 bi1) + Builtin2 bi2 -> pure $ pBuiltin (SomeBuiltin2 bi2) + Builtin3 bi3 -> pure $ pBuiltin (SomeBuiltin3 bi3) + Builtin6 bi6 -> pure $ pBuiltin (SomeBuiltin6 bi6) + Force r -> forceToTerm r + Lam r -> lamToTerm compTy r + AValNode valT valNodeInfo -> case valNodeInfo of + Lit aConstant -> litToTerm aConstant + App i args _ -> do + fTerm <- lookupTerm i + resolvedArgs <- traverse refToTerm args + pure $ foldl' pApp fTerm resolvedArgs + Thunk i -> thunkToTerm i + Cata alg val -> cataToTerm alg val + DataConstructor tn cn fields -> dataConToTerm tn cn fields + Match scrut handlers -> matchToTerm scrut handlers + +matchToTerm :: Ref -> Vector Ref -> CodeGenM PlutusTerm +matchToTerm = undefined + +dataConToTerm :: TyName -> ConstructorName -> Vector Ref -> CodeGenM PlutusTerm +dataConToTerm tn cn@(ConstructorName rawCName) args = do + dtInfo <- lookupDatatype tn + case view #originalDecl dtInfo of + -- We assume the opaque encoding has been checked + OpaqueData {} -> case rawCName of + "PlutusI" -> iData <$> refToTerm (args Vector.! 0) + "PlutusB" -> bData <$> refToTerm (args Vector.! 0) + "PlutusConstr" -> do + termified <- traverse refToTerm args + let cIx = termified Vector.! 0 + cArgs = termified Vector.! 1 + pure $ constrData cIx cArgs + "PlutusList" -> listData <$> traverse refToTerm args + "PlutusMap" -> mapData <$> traverse refToTerm args + other -> throwError $ InvalidOpaqueEncoding other + DataDeclaration _ _ ctors encoding -> case encoding of + SOP -> do + ctorIx <- getConstructorIndex tn cn ctors + resolvedArgs <- traverse refToTerm args + pure $ pConstr ctorIx resolvedArgs + PlutusData strat -> -- We are going to assume that the strategy has been checked + case strat of + EnumData -> plutus_I <$> getConstructorIndex tn cn ctors + ProductListData -> pDataList <$> traverse refToTerm args + T.ConstrData -> do + cIx <- getConstructorIndex tn cn ctors + plutus_ConstrData cIx <$> traverse refToTerm args + NewtypeData -> refToTerm (Vector.head args) + + +getEncoding :: DatatypeInfo AbstractTy -> DataEncoding +getEncoding = view (#originalDecl % #datatypeEncoding) + +getConstructorIndex :: forall (n :: Type) + . Num n + => TyName + -> ConstructorName + -> Vector (Constructor AbstractTy) + -> CodeGenM n +getConstructorIndex tn cn ctors = case Vector.findIndex (\x -> view #constructorName x == cn) ctors of + Nothing -> throwError $ ConstructorNotInDatatype tn cn + Just cIx -> pure $ fromIntegral cIx + +cataToTerm :: Ref -> Ref -> CodeGenM PlutusTerm +cataToTerm = undefined + +thunkToTerm :: Id -> CodeGenM PlutusTerm +thunkToTerm = undefined + +litToTerm :: AConstant -> CodeGenM PlutusTerm +litToTerm = undefined + +lamToTerm :: CompT AbstractTy -> Ref -> CodeGenM PlutusTerm +lamToTerm = undefined + +forceToTerm :: Ref -> CodeGenM PlutusTerm +forceToTerm = undefined + + + +-- NOTE: I am not sure that we can write this function as things currently stand. +-- We need some kind of naming scheme for arguments (which otherwise don't have name) +refToTerm :: Ref -> CodeGenM PlutusTerm +refToTerm = undefined + +countOccurs :: Id -> [ASGNode] -> Int +countOccurs = undefined diff --git a/src/Covenant/MockPlutus.hs b/src/Covenant/MockPlutus.hs new file mode 100644 index 0000000..cad0cf3 --- /dev/null +++ b/src/Covenant/MockPlutus.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE GADTs #-} + +module Covenant.MockPlutus where + +import Covenant.Constant (AConstant) +import Data.Vector (Vector) +import Covenant.Prim (OneArgFunc, TwoArgFunc, ThreeArgFunc, SixArgFunc) +import Data.Word (Word64) +import Covenant.ASG (Id) + +-- mock Plutus types and placeholder helpers +data PlutusTerm + +data Name + +pVar :: Name -> PlutusTerm +pVar = undefined + +pLam :: Name -> PlutusTerm -> PlutusTerm +pLam = undefined + +pApp :: PlutusTerm -> PlutusTerm -> PlutusTerm +pApp = undefined + +pForce :: PlutusTerm -> PlutusTerm +pForce = undefined + +pDelay :: PlutusTerm -> PlutusTerm +pDelay = undefined + +pConstant :: AConstant -> PlutusTerm +pConstant = undefined + +-- NOTE: I totally forget how you construct data values with PLC functions... +plutus_I :: Integer -> PlutusTerm +plutus_I = undefined + + +-- Fill in w/ whatever makes the `Constr` branch of PlutusData +plutus_ConstrData :: Integer -> Vector PlutusTerm -> PlutusTerm +plutus_ConstrData = undefined + +-- The terms should be data-encoded things +pDataList :: Vector PlutusTerm -> PlutusTerm +pDataList = undefined + +-- these _Data functions probably correspond to builtins, I'll look up their names later +-- NOTE: I guess we could do these in the ASG by applying a builtin function. +-- That might be easier than doing it in Plutus. Not sure. +-- 'I' +iData :: PlutusTerm -> PlutusTerm +iData = undefined + +-- 'B' +bData :: PlutusTerm -> PlutusTerm +bData = undefined + +-- 'Constr' (The data one ) +constrData :: PlutusTerm -> PlutusTerm -> PlutusTerm +constrData = undefined + +listData :: Vector PlutusTerm -> PlutusTerm +listData = undefined + +mapData :: Vector PlutusTerm -> PlutusTerm +mapData = undefined + +data SomeBuiltin where + SomeBuiltin1 :: OneArgFunc -> SomeBuiltin + SomeBuiltin2 :: TwoArgFunc -> SomeBuiltin + SomeBuiltin3 :: ThreeArgFunc -> SomeBuiltin + SomeBuiltin6 :: SixArgFunc -> SomeBuiltin + +pBuiltin :: SomeBuiltin -> PlutusTerm +pBuiltin = undefined + +pError :: PlutusTerm +pError = undefined + +pConstr :: Word64 -> Vector PlutusTerm -> PlutusTerm +pConstr = undefined + +pCase :: PlutusTerm -> Vector PlutusTerm -> PlutusTerm +pCase = undefined + +idName :: Id -> Name +idName = undefined