From 8786c931b0cb193b20be5dfe61b6f60e2ef031e3 Mon Sep 17 00:00:00 2001 From: jmcardon Date: Wed, 12 Feb 2025 14:01:50 -0500 Subject: [PATCH] Add checks for native shadowing --- pact-repl/Pact/Core/Repl/Compile.hs | 2 + pact-tests/Pact/Core/Test/LexerParserTests.hs | 5 +- pact-tests/Pact/Core/Test/ReplTests.hs | 8 +- pact-tests/Pact/Core/Test/StaticErrorTests.hs | 8 +- .../DesugarError.golden | 1 + pact-tests/pact-tests/meta.repl | 2 +- pact-tng.cabal | 1 + pact/Pact/Core/Errors.hs | 5 + pact/Pact/Core/IR/Desugar.hs | 8 +- pact/Pact/Core/NativeShadowing.hs | 169 ++++++++++++++++++ pact/Pact/Core/Syntax/ParseTree.hs | 25 ++- pact/Pact/Core/Syntax/Parser.y | 4 +- 12 files changed, 220 insertions(+), 18 deletions(-) create mode 100644 pact/Pact/Core/NativeShadowing.hs diff --git a/pact-repl/Pact/Core/Repl/Compile.hs b/pact-repl/Pact/Core/Repl/Compile.hs index f93ebfed6..37928228c 100644 --- a/pact-repl/Pact/Core/Repl/Compile.hs +++ b/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 diff --git a/pact-tests/Pact/Core/Test/LexerParserTests.hs b/pact-tests/Pact/Core/Test/LexerParserTests.hs index 63af022e0..aac164c3e 100644 --- a/pact-tests/Pact/Core/Test/LexerParserTests.hs +++ b/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 diff --git a/pact-tests/Pact/Core/Test/ReplTests.hs b/pact-tests/Pact/Core/Test/ReplTests.hs index b96c70046..fb851e6fd 100644 --- a/pact-tests/Pact/Core/Test/ReplTests.hs +++ b/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 diff --git a/pact-tests/Pact/Core/Test/StaticErrorTests.hs b/pact-tests/Pact/Core/Test/StaticErrorTests.hs index 19456cc63..39b7dcb86 100644 --- a/pact-tests/Pact/Core/Test/StaticErrorTests.hs +++ b/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| diff --git a/pact-tests/constructor-tag-goldens/DesugarError.golden b/pact-tests/constructor-tag-goldens/DesugarError.golden index 1036e4c5f..cf084ba96 100644 --- a/pact-tests/constructor-tag-goldens/DesugarError.golden +++ b/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"} diff --git a/pact-tests/pact-tests/meta.repl b/pact-tests/pact-tests/meta.repl index 257c5b477..161b6484d 100644 --- a/pact-tests/pact-tests/meta.repl +++ b/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)))] diff --git a/pact-tng.cabal b/pact-tng.cabal index 9c1b6b236..63008fb7a 100644 --- a/pact-tng.cabal +++ b/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 diff --git a/pact/Pact/Core/Errors.hs b/pact/Pact/Core/Errors.hs index f8747ed9b..b7c4820e8 100644 --- a/pact/Pact/Core/Errors.hs +++ b/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. diff --git a/pact/Pact/Core/IR/Desugar.hs b/pact/Pact/Core/IR/Desugar.hs index edbe9d58a..a15dd0188 100644 --- a/pact/Pact/Core/IR/Desugar.hs +++ b/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 diff --git a/pact/Pact/Core/NativeShadowing.hs b/pact/Pact/Core/NativeShadowing.hs new file mode 100644 index 000000000..fdd262124 --- /dev/null +++ b/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 +-- +-- 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 \ No newline at end of file diff --git a/pact/Pact/Core/Syntax/ParseTree.hs b/pact/Pact/Core/Syntax/ParseTree.hs index 9c9ee8b8d..0732b0f91 100644 --- a/pact/Pact/Core/Syntax/ParseTree.hs +++ b/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) diff --git a/pact/Pact/Core/Syntax/Parser.y b/pact/Pact/Core/Syntax/Parser.y index 5b6701b44..e31847d81 100644 --- a/pact/Pact/Core/Syntax/Parser.y +++ b/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 }