Scaffold & Mock Plutus

c2uplc.cabal

@@ -1,37 +1,34 @@
-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: [email protected], [email protected]
-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:         [email protected], [email protected]
+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
 
 -- 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

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

flake.nix

@@ -77,7 +77,6 @@
                 cabal = { };
                 haskell-language-server = { };
                 hlint = { };
-                cabal-fmt = { };
                 fourmolu = { };
                 hspec-discover = { };
                 markdown-unlit = { };

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