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 96d09f1..398d118 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,15 +22,9 @@ 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 + -Wredundant-strictness-flags -Wmissing-deriving-strategies + -Woperator-whitespace -Wambiguous-fields -Wmisplaced-pragmas -Wall + -Wcompat -Wredundant-bang-patterns -Wmissing-export-lists -Wmissing-import-lists default-extensions: @@ -65,40 +59,58 @@ 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 + , covenant ==1.3.0 + , prettyprinter ==1.7.1 + , QuickCheck + , tasty ==1.5.3 + , tasty-expected-failure ==0.12.3 + , tasty-hunit ==0.10.2 + , tasty-quickcheck ==0.11.1 + , text ==2.1.1 + , transformers ==0.6.1.0 + , vector ==0.13.2.0 -- 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.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 431c720..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: @@ -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.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/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/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 c1612ea..6ace2f1 100644 --- a/src/Covenant/CodeGen.hs +++ b/src/Covenant/CodeGen.hs @@ -1,2 +1,297 @@ -module Covenant.CodeGen where +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 Control.Monad.Error.Class (MonadError, throwError) +import Control.Monad.Reader.Class (MonadReader, asks) +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.Map (Map) +import Data.Map qualified as M + +import Data.Vector (Vector) +import Data.Vector qualified as Vector + +import Data.Text (Text) + +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 + | 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))) + +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 + 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 :: + 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 + +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 + +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 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 new file mode 100644 index 0000000..4c258a1 --- /dev/null +++ b/src/Covenant/MockPlutus.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE GADTs #-} + +{- 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 Data.Vector qualified as Vector +import Data.Word (Word64) +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 +type PlutusTerm = Term Name DefaultUni DefaultFun () + +pVar :: Name -> PlutusTerm +pVar = Var () + +pLam :: Name -> PlutusTerm -> PlutusTerm +pLam = LamAbs () + +pApp :: PlutusTerm -> PlutusTerm -> PlutusTerm +pApp = Apply () + +pForce :: PlutusTerm -> PlutusTerm +pForce = Force () + +pDelay :: PlutusTerm -> PlutusTerm +pDelay = Delay () + +pError :: PlutusTerm +pError = Error () + +pCase :: PlutusTerm -> Vector PlutusTerm -> PlutusTerm +pCase = undefined + +pConstant :: AConstant -> PlutusTerm +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 + +-- 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 + +idName :: Id -> Name +idName (UnsafeId _i) = undefined