output all shadowed variables in both repl and cli

pact-repl/Main.hs

@@ -52,6 +52,7 @@ data ReplOpts
   | OServer FilePath
   -- Crypto
   | OGenKey
+  | OCheckNativeShadowing FilePath
   deriving (Eq, Show)
 
 replOpts :: O.Parser (Maybe ReplOpts)
@@ -61,8 +62,10 @@ replOpts = O.optional $
   <|> O.flag' OLanguageServer (O.long "lsp" <> O.help "Start Language Server")
   <|> apiReqFlag
   <|> unsignedReqFlag
+  <|> O.flag' OGenKey (O.short 'g' <> O.long "genkey" <> O.help "Generate ED25519 keypair")
   <|> loadFlag
   <|> OServer <$> O.strOption (O.metavar "CONFIG" <> O.short 's' <> O.long "server" <> O.help "Run Pact-Server")
+  <|> checkNativeShadowingFlag
 
 -- Todo: trace output and coverage?
 loadFlag :: O.Parser ReplOpts
@@ -78,6 +81,11 @@ loadFlag = fmap OLoad $
     <*> O.argument O.str
       (O.metavar "FILE" <> O.help "File path to compile (if .pact extension) or execute.")
 
+checkNativeShadowingFlag :: O.Parser ReplOpts
+checkNativeShadowingFlag =
+  OCheckNativeShadowing
+    <$> O.strOption(O.metavar "FILE" <> O.long "check-shadowing" <> O.help "Run a native shadowing check over a particular .pact or .repl file")
+
 argParser :: O.ParserInfo (Maybe ReplOpts)
 argParser = O.info (O.helper <*> replOpts)
             (O.fullDesc <> O.header "The Pact Smart Contract Language Interpreter")
@@ -126,6 +134,7 @@ main = O.execParser argParser >>= \case
     OServer configPath -> Y.decodeFileEither configPath >>= \case
       Left perr -> putStrLn $ Y.prettyPrintParseException perr
       Right config -> runServer config noSPVSupport
+    OCheckNativeShadowing fp -> checkParsedShadows fp
   where
     runScript f dolog = execScript dolog f >>= \case
       (Left pe, state) -> do

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

@@ -22,6 +22,7 @@ module Pact.Core.Repl.Compile
  , defaultLoadFile
  , mkReplState
  , mkReplState'
+ , checkParsedShadows
  ) where
 
 import Control.Lens
@@ -253,6 +254,36 @@ mangleFilePath fp = do
       | takeFileName currFile == currFile -> pure fp
       | otherwise -> pure $ combine (takeDirectory currFile) fp
 
+checkParsedShadows :: FilePath -> IO ()
+checkParsedShadows fp = do
+  source <- T.readFile fp
+  case Lisp.lexer source >>= Lisp.parseReplProgram of
+    Left err -> do
+      let errorLoc = view peInfo err
+          msg = pretty errorLoc <> ":" <+> pretty err
+      T.putStrLn (renderCompactText' msg)
+    Right program -> do
+      let (_, reverse -> shadows) = runShadowsM replBuiltinMap (traverse checkReplTopLevelShadows program)
+      case shadows of
+        [] -> pure ()
+        _ -> do
+          let shadowOutput = vsep $ fmap (\s@(Shadows _ _ i) -> pretty i <> ":" <+> pretty s) shadows
+          T.putStrLn $ renderCompactText' shadowOutput
+
+
+liftShadowsReplM :: ShadowsM b FileLocSpanInfo a -> ReplM b a
+liftShadowsReplM act = do
+  natives <- viewEvalEnv eeNatives
+  let (a, shadows) = runShadowsM natives act
+  case reverse shadows of
+    [] -> pure a
+    h:rest -> do
+      traverse_ printShadow (h:rest)
+      throwError $ toShadowingError h
+  where
+  printShadow s@(Shadows _ _ i) = replPrintLn i s
+  toShadowingError (Shadows _ arg i) = PEDesugarError (InvalidNativeShadowing arg) i
+
 interpretReplProgram
   :: ReplInterpreter
   -> SourceCode
@@ -263,7 +294,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_ (liftShadowsReplM . checkReplTopLevelShadows) parsed
   traverse pipe' parsed
   where
   renderDoc info doc = liftIO (renderBuiltinDoc doc) >>= \case

pact/Pact/Core/NativeShadowing.hs

@@ -14,35 +14,100 @@
 -- module names and interface names
 --
 module Pact.Core.NativeShadowing
- ( liftShadowsMEvalM
- , runShadowsM
+ ( runShadowsM
  , ShadowsM
  , checkTopLevelShadows
- , checkReplTopLevelShadows)
+ , checkReplTopLevelShadows
+ , Shadows(..))
  where
 
 import Control.Lens
 import Control.Monad
 import Control.Monad.Reader
-import Control.Monad.Except
+import Control.Monad.State.Strict
 import Data.Foldable(traverse_)
 import Data.Text(Text)
 
-import Pact.Core.Errors
-import Pact.Core.Environment
+import Pact.Core.Names
 import Pact.Core.Syntax.ParseTree
+import Pact.Core.Type
+import Pact.Core.Pretty
 
 import qualified Data.Map.Strict as M
 
+-- | The context of what is being shadowed,
+--   that is, the location and type of definition where shadowing is occuring.
+data ShadowCtx
+  = DefNameCtx DefKind QualifiedName
+  | DefArgContext DefKind Int QualifiedName
+  | DefBodyContext DefKind QualifiedName
+  | ModuleCtx ModuleName
+  | InterfaceCtx ModuleName
+  | InterfaceDefCtx DefKind QualifiedName
+  | InterfaceDefArgCtx DefKind Int QualifiedName
+  | TopLevelExprCtx
+  deriving (Eq, Show)
+
+instance Pretty ShadowCtx where
+  pretty = \case
+    DefNameCtx dk qn ->
+      "in the definition name of" <+> pretty dk <+> pretty qn
+    DefArgContext dk argIx qn ->
+      "in definition" <+> pretty dk <+> pretty qn <+> "at argument position" <+> pretty argIx
+    DefBodyContext dk qn ->
+      "in the body of definition" <+> pretty dk <+> pretty qn
+    ModuleCtx mn ->
+      "in module name" <+> pretty mn
+    InterfaceCtx mn ->
+      "in interface name" <+> pretty mn
+    InterfaceDefCtx dk qn ->
+      "in the definition name of" <+> pretty dk <+> pretty qn
+    InterfaceDefArgCtx dk argIx qn ->
+      "in definition" <+> pretty dk <+> pretty qn <+> "at argument position" <+> pretty argIx
+    TopLevelExprCtx ->
+      "in top level expression"
+
+data Shadows i
+  = Shadows ShadowCtx Text i
+  deriving (Eq, Show)
+
+instance Pretty i => Pretty (Shadows i) where
+  pretty (Shadows ctx shadowedVar _) =
+    "Variable" <+> pretty shadowedVar <+> "shadows native of the same name" <+> pretty ctx
+
+data ShadowsEnv b
+  = ShadowsEnv
+  { _context :: ShadowCtx
+  , _natives :: M.Map Text b
+  }
+
 newtype ShadowsM b i a
-  = ShadowsM (ExceptT (PactError i) (Reader (M.Map Text b)) a)
+  = ShadowsM (StateT [Shadows i] (Reader (ShadowsEnv b)) a)
   deriving
   ( Functor
   , Applicative
   , Monad
-  , MonadError (PactError i)
-  , MonadReader (M.Map Text b)
-  ) via (ExceptT (PactError i) (Reader (M.Map Text b)))
+  , MonadState [Shadows i]
+  , MonadReader (ShadowsEnv b)
+  ) via (StateT [Shadows i] (Reader (ShadowsEnv b)))
+
+
+withContext :: ShadowCtx -> ShadowsM b i a -> ShadowsM b i a
+withContext ctx = local (\(ShadowsEnv _ n) -> ShadowsEnv ctx n)
+
+viewContext :: ShadowsM b i ShadowCtx
+viewContext = asks _context
+
+-- | Enrich the context of a Def within a module (or a top level repl def)
+--   with its qualified name
+withModuleDefCtx :: MArg i -> (QualifiedName -> ShadowCtx) -> ShadowsM b i a -> ShadowsM b i a
+withModuleDefCtx (MArg defname _ _) mkCtx act =
+  viewContext >>= \case
+    ModuleCtx mn -> withContext (mkCtx (QualifiedName defname mn)) act
+    InterfaceCtx mn -> withContext (mkCtx (QualifiedName defname mn)) act
+    -- A `def` cannot exist outside a `ModuleCtx` outside of the REPL, so we can safely assume this is a
+    -- REPL def
+    _ -> withContext (mkCtx (QualifiedName defname replModuleName)) act
 
 checkExprShadows :: Expr i -> ShadowsM b i ()
 checkExprShadows expr =
@@ -65,39 +130,59 @@ checkMArgShadows (MArg name _mty i) = checkNativeShadows name i
 
 checkNativeShadows :: Text -> info -> ShadowsM b info ()
 checkNativeShadows name i = do
-  natives <- ask
+  ShadowsEnv ctx natives <- ask
   when (M.member name natives) $
-    throwError (PEDesugarError (InvalidNativeShadowing name) i)
+    modify' (Shadows ctx name i:)
 
 
 checkDefunShadows :: Defun i -> ShadowsM b i ()
 checkDefunShadows (Defun spec args term _anns _) = do
-  traverse_ checkMArgShadows (spec:args)
-  traverse_ checkExprShadows term
+  withModuleDefCtx spec (DefNameCtx DKDefun) $ checkMArgShadows spec
+  forM_ (zip [0..] args) $ \(idx, arg)  ->
+    withModuleDefCtx spec (DefArgContext DKDefun idx) $ checkMArgShadows arg
+  withModuleDefCtx spec (DefBodyContext DKDefun) $ traverse_ checkExprShadows term
 
 checkDefcapShadows :: DefCap i -> ShadowsM b i ()
 checkDefcapShadows (DefCap spec args term _ _ _) = do
-  traverse_ checkMArgShadows (spec:args)
-  traverse_ checkExprShadows term
+  withModuleDefCtx spec (DefNameCtx DKDefCap) $ checkMArgShadows spec
+  forM_ (zip [0..] args) $ \(idx, arg)  ->
+    withModuleDefCtx spec (DefArgContext DKDefCap idx) $ checkMArgShadows arg
+  withModuleDefCtx spec (DefBodyContext DKDefCap) $ traverse_ checkExprShadows term
 
 checkDefconstShadows :: DefConst i -> ShadowsM b i ()
 checkDefconstShadows (DefConst spec term _ _) = do
-  checkMArgShadows spec
-  checkExprShadows term
-
+  withModuleDefCtx spec (DefNameCtx DKDefConst) $ checkMArgShadows spec
+  withModuleDefCtx spec (DefBodyContext DKDefConst) $ 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
+checkDefSchemaShadows (DefSchema name _args _ i) = viewContext >>= \case
+    ModuleCtx mn -> do
+      let qn = QualifiedName name mn
+      withContext (DefNameCtx (DKDefSchema (fakeSchema qn)) qn) act
+    -- A `def` cannot exist outside a `ModuleCtx` outside of the REPL, so we can safely assume this is a
+    -- REPL def
+    -- you can't define repl defschemas yet so this case is actually impossible, but in the future it might not be
+    _ -> do
+      let qn = QualifiedName name replModuleName
+      withContext (DefNameCtx (DKDefSchema (fakeSchema qn)) qn) act
+  where
+  act = checkNativeShadows name i
+  -- We kind of need this because I unfortunately made `DefKind` take a parameter :(
+  --
+  fakeSchema qn = Schema qn mempty
 
 checkDeftableShadows :: DefTable i -> ShadowsM b i ()
-checkDeftableShadows (DefTable name _ _ i) = checkNativeShadows name i
+checkDeftableShadows (DefTable name _ _ i) =
+  withModuleDefCtx (MArg name Nothing i) (DefNameCtx DKDefTable) $
+    checkNativeShadows name i
 
 checkDefpactShadows :: DefPact i -> ShadowsM b i ()
 checkDefpactShadows (DefPact spec args steps _ann _) = do
-  traverse_ checkMArgShadows (spec:args)
-  traverse_ checkShadowedStep steps
+  withModuleDefCtx spec (DefNameCtx DKDefPact) $ checkMArgShadows spec
+  forM_ (zip [0..] args) $ \(idx, arg)  ->
+    withModuleDefCtx spec (DefArgContext DKDefPact idx) $ checkMArgShadows arg
+  withModuleDefCtx spec (DefBodyContext DKDefPact) $ traverse_ checkShadowedStep steps
   where
   checkShadowedStep = \case
     Step me e _ -> do
@@ -117,21 +202,27 @@ checkDefShadows = \case
   DPact d -> checkDefpactShadows d
 
 checkModuleShadows :: Module i -> ShadowsM b i ()
-checkModuleShadows (Module mname _gov _exts defs _anns i) = do
+checkModuleShadows (Module mname _gov _exts defs _anns i) = withContext (ModuleCtx (ModuleName mname Nothing)) $ do
   checkNativeShadows mname i
   traverse_ checkDefShadows defs
 
 checkIfDefunShadows :: IfDefun i -> ShadowsM b i ()
-checkIfDefunShadows (IfDefun spec args _anns _) =
-  traverse_ checkMArgShadows (spec:args)
+checkIfDefunShadows (IfDefun spec args _anns _) = do
+  withModuleDefCtx spec (DefNameCtx DKDefun) $ checkMArgShadows spec
+  forM_ (zip [0..] args) $ \(idx, arg)  ->
+    withModuleDefCtx spec (DefArgContext DKDefun idx) $ checkMArgShadows arg
 
 checkIfDefcapShadows :: IfDefCap i -> ShadowsM b i ()
-checkIfDefcapShadows (IfDefCap spec args _ _ _) =
-  traverse_ checkMArgShadows (spec:args)
+checkIfDefcapShadows (IfDefCap spec args _ _ _) = do
+  withModuleDefCtx spec (DefNameCtx DKDefCap) $ checkMArgShadows spec
+  forM_ (zip [0..] args) $ \(idx, arg)  ->
+    withModuleDefCtx spec (DefArgContext DKDefCap idx) $ checkMArgShadows arg
 
 checkIfDefpactShadows :: IfDefPact i -> ShadowsM b i ()
-checkIfDefpactShadows (IfDefPact spec args _ _) =
-  traverse_ checkMArgShadows (spec:args)
+checkIfDefpactShadows (IfDefPact spec args _ _) = do
+  withModuleDefCtx spec (DefNameCtx DKDefPact) $ checkMArgShadows spec
+  forM_ (zip [0..] args) $ \(idx, arg)  ->
+    withModuleDefCtx spec (DefArgContext DKDefPact idx) $ checkMArgShadows arg
 
 checkIfDefShadows :: IfDef i  -> ShadowsM b i ()
 checkIfDefShadows = \case
@@ -142,7 +233,7 @@ checkIfDefShadows = \case
   IfDPact dp -> checkIfDefpactShadows dp
 
 checkInterfaceShadows :: Interface i -> ShadowsM b i ()
-checkInterfaceShadows (Interface ifn defns _ _ i) = do
+checkInterfaceShadows (Interface ifn defns _ _ i) = withContext (InterfaceCtx (ModuleName ifn Nothing)) $ do
   checkNativeShadows ifn i
   traverse_ checkIfDefShadows defns
 
@@ -159,11 +250,6 @@ checkReplTopLevelShadows = \case
   RTLDefun df -> checkDefunShadows df
   RTLDefConst dc -> checkDefconstShadows dc
 
-runShadowsM :: M.Map Text b -> ShadowsM b i a -> Either (PactError i) a
+runShadowsM :: M.Map Text b -> ShadowsM b i a -> (a, [Shadows i])
 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
+  runReader (runStateT act []) (ShadowsEnv TopLevelExprCtx e)