'Arg' Resolution

.pre-commit-config.yaml

@@ -1 +1 @@
-/nix/store/dfy3nfvlb9iznhv8844mlgbxyklfq2i3-pre-commit-config.json
+/nix/store/ccvqzyflrv09cnr6r73sjczxkld8w2mq-pre-commit-config.json

c2uplc.cabal

@@ -1,36 +1,30 @@
-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
+    -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

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

flake.nix

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

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))