From 1515173afb9f785014d73ce72ac3093366bdd5bf Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Wed, 8 Oct 2025 13:12:45 +1300 Subject: [PATCH 1/5] Break --- c2uplc.cabal | 84 ++++++++++++++++++----------------------- cabal.project | 14 +++---- flake.nix | 1 - src/Covenant/CodeGen.hs | 10 ++++- 4 files changed, 53 insertions(+), 56 deletions(-) diff --git a/c2uplc.cabal b/c2uplc.cabal index 5981d4e..181bd76 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,10 @@ 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 + -Wall -Wcompat -Wredundant-bang-patterns + -Wredundant-strictness-flags -Wmissing-deriving-strategies + -Woperator-whitespace -Wambiguous-fields -Wmisplaced-pragmas + -Wmissing-export-lists -Wmissing-import-lists default-extensions: BangPatterns @@ -65,37 +59,33 @@ common lang UndecidableInstances build-depends: - base >=4.19.0.0 && <5, - covenant ==1.3.0, + , base >=4.19.0.0 && <5 + , covenant ==1.3.0 - 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 -- Primary library library - import: lang - exposed-modules: Covenant.Codegen - hs-source-dirs: src + import: lang + exposed-modules: Covenant.CodeGen + 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..1724188 100644 --- a/src/Covenant/CodeGen.hs +++ b/src/Covenant/CodeGen.hs @@ -1,2 +1,10 @@ -module Covenant.CodeGen where +module Covenant.CodeGen ( + oneArgFuncToPlutus, +) +where +import Covenant.Prim (OneArgFunc) +import PlutusCore.Default.Builtins () + +oneArgFuncToPlutus :: OneArgFunc -> DefaultFun +oneArgFuncToPlutus = _ From f84ec83ee06bc41a6bf662ec810b8696b074da79 Mon Sep 17 00:00:00 2001 From: gnumonik Date: Wed, 8 Oct 2025 01:49:13 -0400 Subject: [PATCH 2/5] Mock Plutus functions, CodeGen monad, wrote the generator for datatype introductions --- c2uplc.cabal | 16 +++- src/Covenant/CodeGen.hs | 174 +++++++++++++++++++++++++++++++++++++ src/Covenant/MockPlutus.hs | 87 +++++++++++++++++++ 3 files changed, 273 insertions(+), 4 deletions(-) create mode 100644 src/Covenant/MockPlutus.hs diff --git a/c2uplc.cabal b/c2uplc.cabal index 96d09f1..a9977a1 100644 --- a/c2uplc.cabal +++ b/c2uplc.cabal @@ -22,7 +22,7 @@ extra-source-files: -- Common sections common lang ghc-options: - -Wall + -- -Wall -Wcompat -Wredundant-bang-patterns -Wredundant-strictness-flags @@ -30,8 +30,8 @@ common lang -Woperator-whitespace -Wambiguous-fields -Wmisplaced-pragmas - -Wmissing-export-lists - -Wmissing-import-lists + -- -Wmissing-export-lists + -- -Wmissing-import-lists default-extensions: BangPatterns @@ -67,6 +67,13 @@ common lang build-depends: base >=4.19.0.0 && <5, covenant ==1.3.0, + mtl, + optics-core, + optics-extra, + transformers, + containers, + text, + vector default-language: Haskell2010 @@ -100,5 +107,6 @@ executable c2uplc -- Primary library library import: lang - exposed-modules: Covenant.Codegen + exposed-modules: Covenant.CodeGen + other-modules: Covenant.MockPlutus hs-source-dirs: src 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 From 90567daacdbc3ec8c52992a65370dd1091582b38 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Thu, 9 Oct 2025 12:38:32 +1300 Subject: [PATCH 3/5] Plutus deps --- c2uplc.cabal | 105 +++++++++++++++++++++++--------------------------- cabal.project | 14 +++---- flake.nix | 1 - 3 files changed, 56 insertions(+), 64 deletions(-) diff --git a/c2uplc.cabal b/c2uplc.cabal index a9977a1..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,48 +62,44 @@ common lang UndecidableInstances build-depends: - base >=4.19.0.0 && <5, - covenant ==1.3.0, - mtl, - optics-core, - optics-extra, - transformers, - containers, - text, - vector + , 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 + import: lang exposed-modules: Covenant.CodeGen - other-modules: Covenant.MockPlutus - hs-source-dirs: src + 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 = { }; From a62424f2b6679985326743729172dc4bbfc0243b Mon Sep 17 00:00:00 2001 From: gnumonik Date: Mon, 20 Oct 2025 22:44:16 -0400 Subject: [PATCH 4/5] appease stupid spell checker --- .pre-commit-config.yaml | 2 +- c2uplc.cabal | 26 ++- cabal.project | 4 +- flake.lock | 42 ++-- src/Covenant/ArgDict.hs | 104 ++++++++++ src/Covenant/CodeGen.hs | 383 ++++++++++++++++++++++++------------- src/Covenant/MockPlutus.hs | 82 +++++--- 7 files changed, 455 insertions(+), 188 deletions(-) create mode 100644 src/Covenant/ArgDict.hs diff --git a/.pre-commit-config.yaml b/.pre-commit-config.yaml index 13cd8f0..a5df918 120000 --- a/.pre-commit-config.yaml +++ b/.pre-commit-config.yaml @@ -1 +1 @@ -/nix/store/dfy3nfvlb9iznhv8844mlgbxyklfq2i3-pre-commit-config.json \ No newline at end of file +/nix/store/ccvqzyflrv09cnr6r73sjczxkld8w2mq-pre-commit-config.json \ No newline at end of file diff --git a/c2uplc.cabal b/c2uplc.cabal index 3660265..0421ad6 100644 --- a/c2uplc.cabal +++ b/c2uplc.cabal @@ -22,10 +22,10 @@ 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 + -Woperator-whitespace -Wambiguous-fields -Wmisplaced-pragmas -Wall + -Wcompat -Wredundant-bang-patterns -Wmissing-export-lists + -Wmissing-import-lists default-extensions: BangPatterns @@ -76,13 +76,17 @@ common test-lang ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N build-depends: , c2uplc - , containers >=0.6.8 && <0.8 + , containers >=0.6.8 && <0.8 + , covenant ==1.3.0 , prettyprinter ==1.7.1 - , QuickCheck ==2.15.0.1 + , QuickCheck , tasty ==1.5.3 , tasty-expected-failure ==0.12.3 , tasty-hunit ==0.10.2 , tasty-quickcheck ==0.11.1 + , text + , transformers + , vector -- Executable executable c2uplc @@ -96,7 +100,17 @@ executable c2uplc -- Primary library library import: lang - exposed-modules: Covenant.CodeGen + exposed-modules: + Covenant.ArgDict + Covenant.CodeGen + other-modules: Covenant.MockPlutus hs-source-dirs: src build-depends: plutus-core ==1.51.0.0 + +test-suite arg-resolution + import: test-lang + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test/arg-resolution + build-depends: plutus-core ==1.51.0.0 diff --git a/cabal.project b/cabal.project index ec401dd..8633213 100644 --- a/cabal.project +++ b/cabal.project @@ -10,8 +10,8 @@ package c2uplc source-repository-package type: git location: https://github.com/mlabs-haskell/covenant - tag: aa296816ab093700cc00c7613d428e7a779050ce - --sha256: 0csgnxxa04510giglwvqj80gfyphf77mz75zr7jffa9f36sidmbs + tag: ec9d40e14c68075cc196ef5524ec81f8a27b79f5 + sha256: 0nlm4i554h4h8x112hrjfayijca6ls5hzbiaqk9a51whmw3h79v0 -- Note (Koz, 15/08/2025): For the next person who needs to bump Plutus -- dependencies, this is the order of operations: diff --git a/flake.lock b/flake.lock index d403d4d..7843371 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1759837865, - "narHash": "sha256-g8SMcVN1v51Muz6a+xJkB92mPx1jsg+sjHKvQ3Wj/jY=", + "lastModified": 1760467636, + "narHash": "sha256-EA7jPm7AmNNm8/ggK8aEIgczw49/vXxYPOp8mPy/dyg=", "owner": "intersectmbo", "repo": "cardano-haskell-packages", - "rev": "9a46cacd941c108492cd4cee5d29735e8cd8ee65", + "rev": "5311e0cc3a8bee834718170af30ecd55592f6ea2", "type": "github" }, "original": { @@ -384,11 +384,11 @@ "hackage": { "flake": false, "locked": { - "lastModified": 1759796743, - "narHash": "sha256-i4ZuJtQOjZmA4/10eyPGMt4jPrci3P+InqG7V4PfmbQ=", + "lastModified": 1760401501, + "narHash": "sha256-9OHoxOoHLi/ucvi4k3M/li1HhBWY5Xn4VAi4+6cmskQ=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "82a911591b89e1192e18b2cf91a73643aba67302", + "rev": "8a529b6761743b2d582d1ecaca0df1454a729168", "type": "github" }, "original": { @@ -400,11 +400,11 @@ "hackage-for-stackage": { "flake": false, "locked": { - "lastModified": 1759796733, - "narHash": "sha256-lYaywC/nPR2BocJeqrRWxzhB/F0SHYh5sODS+y/SfS8=", + "lastModified": 1760401490, + "narHash": "sha256-23yoe4d68cmiLV+f+NeU2ZIdVRUEF/m4tfysliCp0Vc=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "1c8a6c0c38ac6cfd1edd1a677445179e1dd71947", + "rev": "19dfc080114658671e820e460da77a68e34662e5", "type": "github" }, "original": { @@ -486,11 +486,11 @@ "stackage": "stackage" }, "locked": { - "lastModified": 1759798323, - "narHash": "sha256-cy2EbqVzvGVgeDmz6O7ESahwMz8OvgtX1saUy+NrHF0=", + "lastModified": 1760403127, + "narHash": "sha256-Nx7bintaRzBarcV3S92xw5P68CdE+9/KkwjWibThd/M=", "owner": "input-output-hk", "repo": "haskell.nix", - "rev": "17cc2e9e95aa6946bfcccc5a529cb7e9d78fe901", + "rev": "8244bb25bacd06f80fb7d79537eede0d6449faf6", "type": "github" }, "original": { @@ -1438,11 +1438,11 @@ }, "nixpkgs_4": { "locked": { - "lastModified": 1759866883, - "narHash": "sha256-GDF8mf+opMUaThH9YZcD9apToXcldy/cVmolYHgck0s=", + "lastModified": 1760484878, + "narHash": "sha256-gMF9qyxNaeH5kY0xs4qEMllzYKAJ2SZe5Ov+CflJOm4=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "e6de9bc8f32f443b3ca2105b13d7c25cad218037", + "rev": "f3b9a7704dd24531799f16407a17053e318cbfcb", "type": "github" }, "original": { @@ -1508,11 +1508,11 @@ "nixpkgs": "nixpkgs_5" }, "locked": { - "lastModified": 1759523803, - "narHash": "sha256-PTod9NG+i3XbbnBKMl/e5uHDBYpwIWivQ3gOWSEuIEM=", + "lastModified": 1760392170, + "narHash": "sha256-WftxJgr2MeDDFK47fQKywzC72L2jRc/PWcyGdjaDzkw=", "owner": "cachix", "repo": "pre-commit-hooks.nix", - "rev": "cfc9f7bb163ad8542029d303e599c0f7eee09835", + "rev": "46d55f0aeb1d567a78223e69729734f3dca25a85", "type": "github" }, "original": { @@ -1570,11 +1570,11 @@ "stackage": { "flake": false, "locked": { - "lastModified": 1759795950, - "narHash": "sha256-+fWjEzNb8I8PX6KxQeJh6x8DM8hAhwu7WDkkEnEUR4I=", + "lastModified": 1760400715, + "narHash": "sha256-IrQRC0CiNrA71Rq40fWdTwBWGtXramBevsU/OEVcCtI=", "owner": "input-output-hk", "repo": "stackage.nix", - "rev": "8e715bc7826d20573142b3b74256f5b56d356695", + "rev": "c9ed9ca5d8b9820d021c556481d2006319d143d4", "type": "github" }, "original": { diff --git a/src/Covenant/ArgDict.hs b/src/Covenant/ArgDict.hs new file mode 100644 index 0000000..9523d49 --- /dev/null +++ b/src/Covenant/ArgDict.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- HLINT ignore "Use <$>" -} +-- Seriously WTF this makes things so much uglier! +module Covenant.ArgDict (preprocess, idToName) where + +import Data.Word (Word64) + +import Data.Kind (Type) + +import Data.Map (Map) +import Data.Map qualified as M + +import Data.Text qualified as T + +import Data.Vector (Vector) +import Data.Vector qualified as Vector + +import Control.Monad.RWS.Strict (RWS, ask, evalRWS, get, local, modify) + +import Covenant.ASG ( + ASG, + ASGNode (ACompNode, AValNode, AnError), + CompNodeInfo (Force, Lam), + Id, + Ref (AnArg, AnId), + ValNodeInfo (App, Cata, DataConstructor, Lit, Match, Thunk), + nodeAt, + topLevelId, + ) +import Covenant.Type (AbstractTy, CompT (CompN), CompTBody (ArgsAndResult)) + +import PlutusCore.Name.Unique (Name (Name), Unique (Unique)) + +preprocess :: ASG -> Map Id (Either (Vector Name) (Vector Id)) +preprocess asg = fst $ evalRWS (mkArgResolutionDict asg (topLevelId asg)) mempty (succ . fromEnum . topLevelId $ asg) + +mkArgResolutionDict :: + ASG -> + Id -> -- needs to be the source node for top level calls of this fn + RWS (Vector Id) () Int (Map Id (Either (Vector Name) (Vector Id))) +mkArgResolutionDict asg i = case nodeAt i asg of + AnError -> notALambda $ pure M.empty + ACompNode compT compNode -> case compNode of + Lam bodyRef -> do + let numVarsBoundHere = compTArgs compT + idW = idToWord i + names <- Vector.fromList <$> traverse (lamArgName idW) [0 .. numVarsBoundHere] + case bodyRef of + AnId child -> local (Vector.cons i) $ do + res <- mkArgResolutionDict asg child + pure $ safeInsert i (Left names) res + AnArg _ -> pure $ M.singleton i (Left names) + Force fRef -> notALambda $ goRef fRef + _someBuiltin -> notALambda $ pure M.empty + AValNode _valT valNode -> case valNode of + Lit _ -> notALambda $ pure M.empty + App fn args _ -> notALambda $ do + fnDict <- mkArgResolutionDict asg fn + argsDicts <- mconcat <$> traverse goRef (Vector.toList args) + pure $ fnDict <> argsDicts + Thunk child -> notALambda $ mkArgResolutionDict asg child + Cata alg arg -> notALambda $ (<>) <$> goRef alg <*> goRef arg + DataConstructor _tn _cn args -> notALambda $ mconcat <$> traverse goRef (Vector.toList args) + Match scrut handlers -> notALambda $ mconcat <$> traverse goRef (scrut : Vector.toList handlers) + where + safeInsert :: forall (k :: Type) (v :: Type). (Ord k) => k -> v -> Map k v -> Map k v + safeInsert k v = M.alter (\case Nothing -> Just v; other -> other) k + + lamArgName :: Word64 -> Int -> RWS (Vector Id) () Int Name + lamArgName i' argPos = do + let txtPart = "arg_" <> T.pack (show i') <> "_" <> T.pack (show argPos) + uniquePart <- nextArgUnique + pure $ Name txtPart (Unique uniquePart) + + nextArgUnique :: RWS (Vector Id) () Int Int + nextArgUnique = do + n <- get + modify (+ 1) + pure n + + goRef :: Ref -> RWS (Vector Id) () Int (Map Id (Either (Vector Name) (Vector Id))) + goRef = \case + AnArg _ -> pure M.empty + AnId anId -> mkArgResolutionDict asg anId + + notALambda :: + RWS (Vector Id) () Int (Map Id (Either (Vector Name) (Vector Id))) -> + RWS (Vector Id) () Int (Map Id (Either (Vector Name) (Vector Id))) + notALambda act = do + here <- Right <$> ask + there <- act + pure . safeInsert i here $ there + +compTArgs :: CompT AbstractTy -> Int +compTArgs = \case + CompN _ (ArgsAndResult args _) -> Vector.length args - 1 + +-- We really should have a better way of doing this. +idToWord :: Id -> Word64 +idToWord = toEnum . fromEnum + +idToName :: Id -> Name +idToName i = Name ("x_" <> T.pack (show $ fromEnum i)) (Unique (fromEnum i)) diff --git a/src/Covenant/CodeGen.hs b/src/Covenant/CodeGen.hs index a1a8a70..6ace2f1 100644 --- a/src/Covenant/CodeGen.hs +++ b/src/Covenant/CodeGen.hs @@ -1,154 +1,234 @@ - -module Covenant.CodeGen where - -import Covenant.Type +module Covenant.CodeGen (generatePLC) where + +import Covenant.ASG ( + ASGNode (ACompNode, AValNode, AnError), + Arg (UnArg), + CompNodeInfo (Builtin1, Builtin2, Builtin3, Builtin6, Force, Lam), + Id, + Ref (AnArg, AnId), + ValNodeInfo (App, Cata, DataConstructor, Lit, Match, Thunk), + ) +import Covenant.Constant (AConstant) +import Covenant.Data (DatatypeInfo) +import Covenant.Type ( + AbstractTy, + CompT, + Constructor, + ConstructorName (ConstructorName), + DataDeclaration (DataDeclaration, OpaqueData), + DataEncoding (BuiltinStrategy, PlutusData, SOP), + PlutusDataStrategy ( + EnumData, + NewtypeData, + ProductListData + ), + TyName, + ) + +-- N.B. *WE* have two different things called `ConstrData` 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.Error.Class (MonadError, throwError) import Control.Monad.Reader.Class (MonadReader, asks) -import Control.Monad.State.Class (MonadState, modify, gets) -import Control.Monad.Error.Class +import Control.Monad.State.Class (MonadState, gets, modify) +import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.Trans.RWS (RWS) import Data.Foldable (foldl') -import Data.Kind(Type) +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 +import Optics.Core (review, view) + +import Covenant.DeBruijn (DeBruijn, asInt) +import Covenant.Index (intIndex) +import Covenant.MockPlutus ( + PlutusTerm, + SomeBuiltin (SomeBuiltin1, SomeBuiltin2, SomeBuiltin3, SomeBuiltin6), + bData, + constrData, + iData, + idName, + listData, + mapData, + pApp, + pBuiltin, + pConstr, + pDataList, + pError, + pLam, + pVar, + plutus_ConstrData, + plutus_I, + ) + +import Covenant.ArgDict (idToName) + +import PlutusCore (Name) data CodeGenError - = NoASG - | TermNotInContext Id - | NoDatatype TyName - | ConstructorNotInDatatype TyName ConstructorName - | InvalidOpaqueEncoding Text - - + = NoASG + | TermNotInContext Id + | NoDatatype TyName + | ConstructorNotInDatatype TyName ConstructorName + | InvalidOpaqueEncoding Text + | ArgResolutionFail ArgResolutionFailReason + deriving stock (Show, Eq) + +data ArgResolutionFailReason + = {- | We got @Nothing@ when we tried to look up the context corresponding to the + @Id@ of the parent node where the arg was found. + -} + ParentIdLookupFailed Id + | {- | The @Id@ of the parent node of the arg we are examining should index a @Vector Id@ but instead + indexes a @Vector Name@. + -} + ParentIdPointsAtNames Id + | -- | The @DeBruijn@ index of the arg points to an out of bounds lambda. + DBIndexOutOfBounds DeBruijn + | {- | The @Id@ of the lambda corresponding to the @DeBruijn@ index does not correspond to anything in our + argument resolution dictionary. + -} + NoBindingContext Id + | {- | The @Id@ of the Lambda that the DeBruijn points at corresponds to an entry in our + argument resolution diciontary, but that entry is a @Vector Id@ and not the @Vector Name@ + that we need + -} + LamIdPointsAtContext Id + deriving stock (Show, Eq) 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))) + 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 +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 +lookupDatatype tn = + asks (M.lookup tn) >>= \case + Nothing -> throwError $ NoDatatype tn + Just info -> pure info + +generatePLC :: + Map Id (Either (Vector Name) (Vector Id)) -> + [(Id, ASGNode)] -> + CodeGenM PlutusTerm +generatePLC argDict = \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 i argDict node + ((i', node') : rest') -> do + let letBindable = countOccurs i (node : map snd rest) > 1 + thisTerm <- nodeToTerm i argDict 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 :: + Id -> -- The Id of *THIS* node. Needed for arg resolution + Map Id (Either (Vector Name) (Vector Id)) -> + ASGNode -> + CodeGenM PlutusTerm +nodeToTerm i argDict = \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 i' argDict) args + pure $ foldl' pApp fTerm resolvedArgs + Thunk i' -> thunkToTerm i' + Cata alg val -> cataToTerm alg val + DataConstructor tn cn fields -> dataConToTerm i argDict tn cn fields + Match scrut handlers -> matchToTerm scrut handlers + AnError -> pure pError 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 +dataConToTerm :: + Id -> -- the ID of *this* node + Map Id (Either (Vector Name) (Vector Id)) -> + TyName -> + ConstructorName -> + Vector Ref -> + CodeGenM PlutusTerm +dataConToTerm i argDict 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 i argDict (args Vector.! 0) + "PlutusB" -> bData <$> refToTerm i argDict (args Vector.! 0) + "PlutusConstr" -> do + termified <- traverse (refToTerm i argDict) args + let cIx = termified Vector.! 0 + cArgs = termified Vector.! 1 + pure $ constrData cIx cArgs + "PlutusList" -> listData <$> traverse (refToTerm i argDict) args + "PlutusMap" -> mapData <$> traverse (refToTerm i argDict) args + other -> throwError $ InvalidOpaqueEncoding other + DataDeclaration _ _ ctors encoding -> case encoding of + SOP -> do + ctorIx <- getConstructorIndex tn cn ctors + resolvedArgs <- traverse (refToTerm i argDict) args + pure $ pConstr ctorIx resolvedArgs + PlutusData strategy -> + -- We are going to assume that the strategy has been checked + case strategy of + EnumData -> plutus_I <$> getConstructorIndex tn cn ctors + ProductListData -> pDataList <$> traverse (refToTerm i argDict) args + T.ConstrData -> do + cIx <- getConstructorIndex tn cn ctors + plutus_ConstrData cIx <$> traverse (refToTerm i argDict) args + NewtypeData -> refToTerm i argDict (Vector.head args) + BuiltinStrategy{} -> error "TODO Implement datacon term generator for builtins" + +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 @@ -165,12 +245,53 @@ 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 +idToVar :: Id -> PlutusTerm +idToVar = pVar . idToName + +refToTerm :: + Id -> -- This is the Id of the *immediate parent node*. We need that for this to work bottom up + Map Id (Either (Vector Name) (Vector Id)) -> -- The resolution dictory for args (tells us which names correspond to them) + Ref -> + CodeGenM PlutusTerm +refToTerm parentId argDict = \case + AnId i -> pure $ idToVar i + AnArg (UnArg db ix) -> do + let dbInt = review asInt db + ixInt = review intIndex ix + case M.lookup parentId argDict of + Nothing -> throwError $ ArgResolutionFail (ParentIdLookupFailed parentId) + Just cxt -> case cxt of + Left _names -> throwError $ ArgResolutionFail (ParentIdPointsAtNames parentId) + Right idCxt -> case idCxt Vector.!? dbInt of + Nothing -> throwError $ ArgResolutionFail (DBIndexOutOfBounds db) + Just bindingLamId -> case M.lookup bindingLamId argDict of + Nothing -> throwError $ ArgResolutionFail (NoBindingContext bindingLamId) + Just hopefullyNames -> case hopefullyNames of + Left namesForReal -> pure . pVar $ namesForReal Vector.! ixInt + Right _ -> throwError $ ArgResolutionFail (LamIdPointsAtContext bindingLamId) countOccurs :: Id -> [ASGNode] -> Int -countOccurs = undefined +countOccurs i = foldl' go 0 + where + countId :: Id -> Int + countId i' = if i == i' then 1 else 0 + + countRef :: Ref -> Int + countRef = \case + AnId i' -> if i == i' then 1 else 0 + AnArg _ -> 0 + + go :: Int -> ASGNode -> Int + go n = \case + ACompNode _compTy compNodeInfo -> case compNodeInfo of + Force r -> n + countRef r + Lam r -> n + countRef r + _other -> n + AValNode _valT valNodeInfo -> case valNodeInfo of + Lit _aConstant -> n + App fn args _ -> n + countId fn + sum (countRef <$> args) + Thunk i' -> n + countId i' + Cata alg val -> n + countRef alg + countRef val + DataConstructor _tn _cn fields -> n + sum (countRef <$> fields) + Match scrut handlers -> n + countRef scrut + sum (countRef <$> handlers) + AnError{} -> n diff --git a/src/Covenant/MockPlutus.hs b/src/Covenant/MockPlutus.hs index cad0cf3..4c258a1 100644 --- a/src/Covenant/MockPlutus.hs +++ b/src/Covenant/MockPlutus.hs @@ -1,41 +1,78 @@ {-# LANGUAGE GADTs #-} -module Covenant.MockPlutus where +{- HLINT ignore "Use camelCase" -} + +module Covenant.MockPlutus ( + PlutusTerm, + pVar, + pLam, + pApp, + pForce, + pDelay, + pError, + pConstant, + pConstr, + plutus_I, + plutus_ConstrData, + pDataList, + iData, + bData, + constrData, + listData, + mapData, + SomeBuiltin (..), + pBuiltin, + pCase, + idName, +) where import Covenant.Constant (AConstant) +import Covenant.Prim (OneArgFunc, SixArgFunc, ThreeArgFunc, TwoArgFunc) +import Covenant.Test (Id (UnsafeId)) import Data.Vector (Vector) -import Covenant.Prim (OneArgFunc, TwoArgFunc, ThreeArgFunc, SixArgFunc) +import Data.Vector qualified as Vector import Data.Word (Word64) -import Covenant.ASG (Id) +import PlutusCore (Name) +import PlutusCore.Default (Some, ValueOf) +import UntypedPlutusCore (DefaultFun, DefaultUni, Term (Apply, Constant, Constr, Delay, Error, Force, LamAbs, Var)) -- mock Plutus types and placeholder helpers -data PlutusTerm - -data Name +type PlutusTerm = Term Name DefaultUni DefaultFun () pVar :: Name -> PlutusTerm -pVar = undefined +pVar = Var () pLam :: Name -> PlutusTerm -> PlutusTerm -pLam = undefined +pLam = LamAbs () pApp :: PlutusTerm -> PlutusTerm -> PlutusTerm -pApp = undefined +pApp = Apply () pForce :: PlutusTerm -> PlutusTerm -pForce = undefined +pForce = Force () pDelay :: PlutusTerm -> PlutusTerm -pDelay = undefined +pDelay = Delay () + +pError :: PlutusTerm +pError = Error () + +pCase :: PlutusTerm -> Vector PlutusTerm -> PlutusTerm +pCase = undefined pConstant :: AConstant -> PlutusTerm -pConstant = undefined +pConstant = Constant () . constantHelper + where + constantHelper :: AConstant -> Some (ValueOf DefaultUni) + constantHelper = error "TODO (need to track down the module in Plutus w/ the functions I need)" + +pConstr :: Word64 -> Vector PlutusTerm -> PlutusTerm +pConstr w = Constr () w . Vector.toList -- 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 @@ -66,22 +103,13 @@ mapData :: Vector PlutusTerm -> PlutusTerm mapData = undefined data SomeBuiltin where - SomeBuiltin1 :: OneArgFunc -> SomeBuiltin - SomeBuiltin2 :: TwoArgFunc -> SomeBuiltin - SomeBuiltin3 :: ThreeArgFunc -> SomeBuiltin - SomeBuiltin6 :: SixArgFunc -> SomeBuiltin + 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 +idName (UnsafeId _i) = undefined From d784c79819fdd4372ef323d5c62a0ba2cc175075 Mon Sep 17 00:00:00 2001 From: gnumonik Date: Mon, 20 Oct 2025 23:00:55 -0400 Subject: [PATCH 5/5] added version pins to test dependencies --- c2uplc.cabal | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/c2uplc.cabal b/c2uplc.cabal index 0421ad6..398d118 100644 --- a/c2uplc.cabal +++ b/c2uplc.cabal @@ -76,7 +76,7 @@ common test-lang ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N build-depends: , c2uplc - , containers >=0.6.8 && <0.8 + , containers >=0.6.8 && <0.8 , covenant ==1.3.0 , prettyprinter ==1.7.1 , QuickCheck @@ -84,9 +84,9 @@ common test-lang , tasty-expected-failure ==0.12.3 , tasty-hunit ==0.10.2 , tasty-quickcheck ==0.11.1 - , text - , transformers - , vector + , text ==2.1.1 + , transformers ==0.6.1.0 + , vector ==0.13.2.0 -- Executable executable c2uplc