Add checks for native shadowing

pact-repl/Pact/Core/Repl/Compile.hs

@@ -55,6 +55,7 @@ import Pact.Core.Interpreter
 import Pact.Core.Pretty hiding (pipe)
 import Pact.Core.Serialise
 import Pact.Core.PactValue
+import Pact.Core.NativeShadowing
 
 
 import Pact.Core.IR.Eval.Runtime
@@ -262,6 +263,7 @@ interpretReplProgram interpreter sc@(SourceCode sourceFp source) = do
   debugIfFlagSet ReplDebugLexer lexx
   parsed <- liftEither $ bimap (fmap toFileLoc) ((fmap.fmap) toFileLoc) (parseSource lexx)
   setBuiltinResolution sc
+  traverse_ (liftShadowsMEvalM . checkReplTopLevelShadows) parsed
   traverse pipe' parsed
   where
   renderDoc info doc = liftIO (renderBuiltinDoc doc) >>= \case

pact-tests/Pact/Core/Test/LexerParserTests.hs

@@ -131,10 +131,9 @@ exprGen = Gen.recursive Gen.choice
       pure $ Lisp.Let LFLetNormal binders inner ()
 
     binderGen = do
-      name <- identGen
-      ty <- Gen.maybe typeGen
+      marg <- margGen
       expr <- Gen.subterm exprGen id
-      pure $ Lisp.Binder name ty expr
+      pure $ Lisp.Binder marg expr
 
 typeGen :: Gen Lisp.Type
 typeGen = Gen.recursive Gen.choice

pact-tests/Pact/Core/Test/ReplTests.hs

@@ -33,6 +33,7 @@ import Pact.Core.Errors
 import Pact.Core.Serialise
 import Pact.Core.Persistence
 import Pact.Core.IR.Term
+import Pact.Core.Repl
 import Pact.Core.Repl.Compile
 import qualified Pact.Core.IR.ModuleHashing as MH
 
@@ -83,9 +84,10 @@ runReplTest (ReplSourceDir path) pdb file src interp = do
   let rstate = mkReplState ee (const (const (pure ()))) (\f reset -> void (loadFile interp f reset)) & replCurrSource .~ source
   stateRef <- newIORef rstate
   evalReplM stateRef (interpretReplProgram interp source) >>= \case
-    Left e -> let
-      rendered = replError (SourceCode file src) e
-      in assertFailure (T.unpack rendered)
+    Left e -> do
+      rstate' <- readIORef stateRef
+      let rendered = renderLocatedPactErrorFromState rstate' e
+      assertFailure (T.unpack rendered)
     Right _ -> do
       traverse_ ensurePassing . _replTestResults =<< readIORef stateRef
       ensureModuleHashesMatch

pact-tests/Pact/Core/Test/StaticErrorTests.hs

@@ -162,15 +162,15 @@ desugarTests =
       iface
       |])
   , ("interface_instead_of_module", isDesugarError _InvalidModuleReference, [text|
-      (module mod G (defcap G () true))
+      (module modl G (defcap G () true))
 
       (module other-mod OG (defcap OG () true)
-        (defun foo:string (a:string b:module{mod}) a)
+        (defun foo:string (a:string b:module{modl}) a)
         )
       |])
   , ("interface_instead_of_module_same", isDesugarError _NoSuchModule, [text|
-      (module mod G (defcap G () true)
-        (defun foo:string (a:string b:module{mod}) a)
+      (module modl G (defcap G () true)
+        (defun foo:string (a:string b:module{modl}) a)
         )
       |])
   , ("import_unknown_module", isDesugarError _NoSuchModule, [text|

pact-tests/constructor-tag-goldens/DesugarError.golden

@@ -23,4 +23,5 @@
 {"conName":"InvalidDynamicInvoke","conIndex":"16"}
 {"conName":"DuplicateDefinition","conIndex":"17"}
 {"conName":"InvalidBlessedHash","conIndex":"18"}
+{"conName":"InvalidNativeShadowing","conIndex":"19"}
 

pact-tests/pact-tests/meta.repl

@@ -1,6 +1,6 @@
 (define-keyset 'k (sig-keyset))
 
-(module mod 'k
+(module modl 'k
   @doc   "this defines mod"
   @model [(property (do (crazy stuff)))]
 

pact-tng.cabal

@@ -254,6 +254,7 @@ library
     Pact.Core.DeriveConTag
     Pact.Core.Signer
     Pact.Core.SatWord
+    Pact.Core.NativeShadowing
 
      -- Syntax modules
     Pact.Core.Syntax.ParseTree

pact/Pact/Core/Errors.hs

@@ -342,6 +342,7 @@ data DesugarError
   -- ^ Name was defined twice
   | InvalidBlessedHash Text
   -- ^ Blessed hash has invalid format
+  | InvalidNativeShadowing Text
   deriving (Eq, Show,  Generic)
 
 instance NFData DesugarError
@@ -411,6 +412,8 @@ instance Pretty DesugarError where
       "Duplicate definition:" <+> pretty qn
     InvalidBlessedHash hs ->
       "Invalid blessed hash, incorrect format:" <+> pretty hs
+    InvalidNativeShadowing t ->
+      "Variable" <+> pretty t <+> "shadows native with the same name"
 
 -- | Argument type mismatch meant for errors
 --   that does not force you to show the whole PactValue
@@ -1763,6 +1766,8 @@ desugarErrorToBoundedText = mkBoundedText . \case
       thsep ["Duplicate definition:", renderQualName qn]
     InvalidBlessedHash hs ->
       thsep ["Invalid blessed hash, incorrect format:", hs]
+    InvalidNativeShadowing t ->
+      thsep ["Variable", t, "shadows native with same name"]
 
 -- | NOTE: Do _not_ change this function post mainnet release just to improve an error.
 --  This will fork the chain, these messages will make it into outputs.

pact/Pact/Core/IR/Desugar.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TemplateHaskell #-}
@@ -443,7 +441,11 @@ desugarLispTerm = \case
   Lisp.Object fields i ->
     ObjectLit <$> (traverse._2) desugarLispTerm fields <*> pure i
   where
-  binderToLet i (Lisp.Binder n mty expr) term = do
+  -- Todo: because previously `Binder`s did not carry variable loc info, we used to use the info
+  -- from the enclosing `Let`. We should use the info from the `MArg` now in the binder, but
+  -- this would actually impact serialization and cause a fork, so unless we decide this is even worth it
+  -- to fork, this will just remain a quirk
+  binderToLet i (Lisp.Binder (Lisp.MArg n mty _) expr) term = do
     expr' <- desugarLispTerm expr
     pure $ Let (Arg n mty i) expr' term i
 

pact/Pact/Core/NativeShadowing.hs

@@ -0,0 +1,169 @@
+{-# LANGUAGE DerivingVia #-}
+
+
+-- |
+-- Module      :  Pact.Core.IR.Term
+-- Copyright   :  (C) 2022 Kadena
+-- License     :  BSD-style (see the file LICENSE)
+-- Maintainer  :  Jose Cardona <[email protected]>
+--
+-- Checks our parse tree for any sort of native shadowing.
+-- In pact 5 we don't allow natives to be shadowed in any way, so
+-- the functions in this module emit an error when natives are shadowed in
+-- locally bound variables, lambdas, module definitions, interface definitions,
+-- module names and interface names
+--
+module Pact.Core.NativeShadowing
+ ( liftShadowsMEvalM
+ , runShadowsM
+ , ShadowsM
+ , checkTopLevelShadows
+ , checkReplTopLevelShadows)
+ where
+
+import Control.Lens
+import Control.Monad
+import Control.Monad.Reader
+import Control.Monad.Except
+import Data.Foldable(traverse_)
+import Data.Text(Text)
+
+import Pact.Core.Errors
+import Pact.Core.Environment
+import Pact.Core.Syntax.ParseTree
+
+import qualified Data.Map.Strict as M
+
+newtype ShadowsM b i a
+  = ShadowsM (ExceptT (PactError i) (Reader (M.Map Text b)) a)
+  deriving
+  ( Functor
+  , Applicative
+  , Monad
+  , MonadError (PactError i)
+  , MonadReader (M.Map Text b)
+  ) via (ExceptT (PactError i) (Reader (M.Map Text b)))
+
+checkExprShadows :: Expr i -> ShadowsM b i ()
+checkExprShadows expr =
+  () <$ transformM errorOnShadowing expr
+  where
+  errorOnShadowing = \case
+    Let lf bndrs e i -> do
+      traverse_ checkBndr bndrs
+      pure $ Let lf bndrs e i
+    Lam bnds exprs i -> do
+      traverse_ checkMArgShadows bnds
+      pure $ Lam bnds exprs i
+    e -> pure e
+    where
+    checkBndr (Binder marg _) = checkMArgShadows marg
+
+checkMArgShadows :: MArg i -> ShadowsM b i ()
+checkMArgShadows (MArg name _mty i) = checkNativeShadows name i
+
+
+checkNativeShadows :: Text -> info -> ShadowsM b info ()
+checkNativeShadows name i = do
+  natives <- ask
+  when (M.member name natives) $
+    throwError (PEDesugarError (InvalidNativeShadowing name) i)
+
+
+checkDefunShadows :: Defun i -> ShadowsM b i ()
+checkDefunShadows (Defun spec args term _anns _) = do
+  traverse_ checkMArgShadows (spec:args)
+  traverse_ checkExprShadows term
+
+checkDefcapShadows :: DefCap i -> ShadowsM b i ()
+checkDefcapShadows (DefCap spec args term _ _ _) = do
+  traverse_ checkMArgShadows (spec:args)
+  traverse_ checkExprShadows term
+
+checkDefconstShadows :: DefConst i -> ShadowsM b i ()
+checkDefconstShadows (DefConst spec term _ _) = do
+  checkMArgShadows spec
+  checkExprShadows term
+
+-- Note: We don't have to check whether `args` shadow here
+-- since they're object fields
+checkDefSchemaShadows :: DefSchema i -> ShadowsM b i ()
+checkDefSchemaShadows (DefSchema name _args _ i) = do
+  checkNativeShadows name i
+
+checkDeftableShadows :: DefTable i -> ShadowsM b i ()
+checkDeftableShadows (DefTable name _ _ i) = checkNativeShadows name i
+
+checkDefpactShadows :: DefPact i -> ShadowsM b i ()
+checkDefpactShadows (DefPact spec args steps _ann _) = do
+  traverse_ checkMArgShadows (spec:args)
+  traverse_ checkShadowedStep steps
+  where
+  checkShadowedStep = \case
+    Step me e _ -> do
+      traverse_ checkExprShadows me
+      checkExprShadows e
+    StepWithRollback me e1 e2 _ -> do
+      traverse_ checkExprShadows me
+      traverse_ checkExprShadows [e1, e2]
+
+checkDefShadows :: Def i -> ShadowsM b i ()
+checkDefShadows = \case
+  Dfun d -> checkDefunShadows d
+  DConst d -> checkDefconstShadows d
+  DCap d -> checkDefcapShadows d
+  DSchema d -> checkDefSchemaShadows d
+  DTable d -> checkDeftableShadows d
+  DPact d -> checkDefpactShadows d
+
+checkModuleShadows :: Module i -> ShadowsM b i ()
+checkModuleShadows (Module mname _gov _exts defs _anns i) = do
+  checkNativeShadows mname i
+  traverse_ checkDefShadows defs
+
+checkIfDefunShadows :: IfDefun i -> ShadowsM b i ()
+checkIfDefunShadows (IfDefun spec args _anns _) =
+  traverse_ checkMArgShadows (spec:args)
+
+checkIfDefcapShadows :: IfDefCap i -> ShadowsM b i ()
+checkIfDefcapShadows (IfDefCap spec args _ _ _) =
+  traverse_ checkMArgShadows (spec:args)
+
+checkIfDefpactShadows :: IfDefPact i -> ShadowsM b i ()
+checkIfDefpactShadows (IfDefPact spec args _ _) =
+  traverse_ checkMArgShadows (spec:args)
+
+checkIfDefShadows :: IfDef i  -> ShadowsM b i ()
+checkIfDefShadows = \case
+  IfDfun d -> checkIfDefunShadows d
+  IfDConst d -> checkDefconstShadows d
+  IfDCap dc -> checkIfDefcapShadows dc
+  IfDSchema ds -> checkDefSchemaShadows ds
+  IfDPact dp -> checkIfDefpactShadows dp
+
+checkInterfaceShadows :: Interface i -> ShadowsM b i ()
+checkInterfaceShadows (Interface ifn defns _ _ i) = do
+  checkNativeShadows ifn i
+  traverse_ checkIfDefShadows defns
+
+checkTopLevelShadows :: TopLevel i -> ShadowsM b i ()
+checkTopLevelShadows = \case
+  TLModule m -> checkModuleShadows m
+  TLInterface i -> checkInterfaceShadows i
+  TLTerm e -> checkExprShadows e
+  TLUse _ -> pure ()
+
+checkReplTopLevelShadows :: ReplTopLevel i -> ShadowsM b i ()
+checkReplTopLevelShadows = \case
+  RTLTopLevel tl -> checkTopLevelShadows tl
+  RTLDefun df -> checkDefunShadows df
+  RTLDefConst dc -> checkDefconstShadows dc
+
+runShadowsM :: M.Map Text b -> ShadowsM b i a -> Either (PactError i) a
+runShadowsM e (ShadowsM act) =
+  runReader (runExceptT act) e
+
+liftShadowsMEvalM :: ShadowsM b i a -> EvalM e b i a
+liftShadowsMEvalM act = do
+  natives <- viewEvalEnv eeNatives
+  liftEither $ runShadowsM natives act

pact/Pact/Core/Syntax/ParseTree.hs

@@ -594,11 +594,11 @@ instance Pretty (MArg i) where
 
 
 data Binder i =
-  Binder Text (Maybe Type) (Expr i)
+  Binder (MArg i) (Expr i)
   deriving (Show, Eq, Functor, Generic, NFData)
 
 instance Pretty (Binder i) where
-  pretty (Binder ident ty e) =
+  pretty (Binder (MArg ident ty _) e) =
     parens $ pretty ident <> maybe mempty ((":" <>) . pretty) ty <+> pretty e
 
 data CapForm i
@@ -632,6 +632,27 @@ data Expr i
   | Binding [(Field, MArg i)] [Expr i] i
   deriving (Show, Eq, Functor, Generic, NFData)
 
+instance Plated (Expr i) where
+  plate f = \case
+    Var pn i -> pure (Var pn i)
+    Let lf bndrs exprs i ->
+      Let lf <$> (traverse.traverseBinder) f bndrs <*> traverse f exprs <*> pure i
+    Lam margs e i ->
+      Lam margs <$> traverse f e <*> pure i
+    App l r i ->
+      App <$> f l <*> traverse f r <*> pure i
+    List li i ->
+      List <$> traverse f li <*> pure i
+    Constant l i -> pure (Constant l i)
+    Object fe i ->
+      Object <$> (traverse._2) f fe <*> pure i
+    Binding ma e i ->
+      Binding ma <$> traverse f e <*> pure i
+    where
+      traverseBinder f' (Binder marg e) =
+        Binder marg <$> f' e
+
+
 data ReplTopLevel i
   = RTLTopLevel (TopLevel i)
   | RTLDefun (Defun i)

pact/Pact/Core/Syntax/Parser.y

@@ -361,8 +361,8 @@ LetExpr :: { SpanInfo -> ParsedExpr }
 
 -- Binders are non-empty, this is safe
 Binders :: { [Binder SpanInfo] }
-  : Binders '(' IDENT MTypeAnn Expr ')' { (Binder (getIdent $3) $4 $5):$1 }
-  | '(' IDENT MTypeAnn Expr ')' { [Binder (getIdent $2) $3 $4] }
+  : Binders '(' IDENT MTypeAnn Expr ')' { (Binder (MArg (getIdent $3) $4 (_ptInfo $3)) $5):$1 }
+  | '(' IDENT MTypeAnn Expr ')' { [Binder (MArg (getIdent $2) $3 (_ptInfo $2)) $4] }
 
 GenAppExpr :: { SpanInfo -> ParsedExpr }
   : Expr AppBindList { \i -> App $1 (toAppExprList i (reverse $2)) i }