From ea86d2b659ed80db5e54890409bcc88d600c7fc3 Mon Sep 17 00:00:00 2001 From: jmcardon Date: Mon, 9 Dec 2024 21:56:04 -0600 Subject: [PATCH] Make pact throw an error on unused partial application --- .../Pact/Core/IR/Eval/Direct/Evaluator.hs | 25 ++++++------ pact-repl/Pact/Core/IR/Eval/Direct/Types.hs | 23 +++++++++++ .../Pact/Core/Repl/Runtime/ReplBuiltin.hs | 2 +- .../constructor-tag-goldens/EvalError.golden | 1 + pact-tests/pact-tests/partial-app-errors.repl | 20 ++++++++++ pact/Pact/Core/Errors.hs | 40 +++++++++++++++++++ pact/Pact/Core/IR/Eval/CEK/Evaluator.hs | 25 ++++++------ pact/Pact/Core/IR/Eval/CEK/Types.hs | 3 +- pact/Pact/Core/IR/Eval/CEK/Utils.hs | 22 ++++++++++ 9 files changed, 135 insertions(+), 26 deletions(-) create mode 100644 pact-tests/pact-tests/partial-app-errors.repl diff --git a/pact-repl/Pact/Core/IR/Eval/Direct/Evaluator.hs b/pact-repl/Pact/Core/IR/Eval/Direct/Evaluator.hs index 5d070680b..d0b618fec 100644 --- a/pact-repl/Pact/Core/IR/Eval/Direct/Evaluator.hs +++ b/pact-repl/Pact/Core/IR/Eval/Direct/Evaluator.hs @@ -236,8 +236,9 @@ evaluate env = \case fn <- enforceUserAppClosure info =<< evaluate env ufn args <- traverse (evaluate env) uargs applyLam fn args - Sequence e1 e2 _ -> do - _ <- evaluate env e1 + Sequence e1 e2 info -> do + v <- evaluate env e1 + enforceSaturatedApp info v evaluate env e2 Builtin b info -> do let builtins = _ceBuiltins env @@ -728,7 +729,7 @@ applyLam vc@(C (Closure fqn ca arity term mty env cloi)) args apply' e (ty:tys) [] = do let env' = set ceLocal e env -- Todo: fix partial SF args - pclo = PartialClosure (Just (StackFrame fqn [] SFDefun cloi)) (ty :| tys) (length tys + 1) term mty env' cloi + pclo = PartialClosure (Just (StackFrame fqn [] SFDefun cloi)) (ty :| tys) argLen (length tys + 1) term mty env' cloi return (VPartialClosure pclo) apply' _ [] _ = throwExecutionError cloi ClosureAppliedToTooManyArgs @@ -758,26 +759,26 @@ applyLam (LC (LamClosure ca arity term mty env cloi)) args apply' e [] [] = do evaluate (set ceLocal e env) term apply' e (ty:tys) [] = - return (VPartialClosure (PartialClosure Nothing (ty :| tys) (length tys + 1) term mty (set ceLocal e env) cloi)) + return (VPartialClosure (PartialClosure Nothing (ty :| tys) argLen (length tys + 1) term mty (set ceLocal e env) cloi)) apply' _ [] _ = throwExecutionError cloi ClosureAppliedToTooManyArgs -applyLam (PC (PartialClosure li argtys _ term mty env cloi)) args = do +applyLam (PC (PartialClosure li argtys nargs _ term mty env cloi)) args = do chargeGasArgs cloi (GAApplyLam (_sfName <$> li) (length args)) - apply' (view ceLocal env) (NE.toList argtys) args + apply' nargs (view ceLocal env) (NE.toList argtys) args where - apply' e (Arg _ ty _:tys) (x:xs) = do + apply' n e (Arg _ ty _:tys) (x:xs) = do x' <- enforcePactValue cloi x maybeTCType cloi ty x' - apply' (RAList.cons (VPactValue x') e) tys xs - apply' e [] [] = do + apply' (n + 1) (RAList.cons (VPactValue x') e) tys xs + apply' _ e [] [] = do case li of Just sf -> do evalWithStackFrame cloi sf mty $ evaluate (set ceLocal e env) term Nothing -> do evaluate (set ceLocal e env) term >>= enforcePactValue' cloi - apply' e (ty:tys) [] = do - let pclo = PartialClosure li (ty :| tys) (length tys + 1) term mty (set ceLocal e env) cloi + apply' n e (ty:tys) [] = do + let pclo = PartialClosure li (ty :| tys) n (length tys + 1) term mty (set ceLocal e env) cloi return (VPartialClosure pclo) - apply' _ [] _ = throwExecutionError cloi ClosureAppliedToTooManyArgs + apply' _ _ [] _ = throwExecutionError cloi ClosureAppliedToTooManyArgs applyLam (PN (PartialNativeFn b env fn arity pArgs i)) args | arity == argLen = do diff --git a/pact-repl/Pact/Core/IR/Eval/Direct/Types.hs b/pact-repl/Pact/Core/IR/Eval/Direct/Types.hs index 576ef7be4..a9e72828d 100644 --- a/pact-repl/Pact/Core/IR/Eval/Direct/Types.hs +++ b/pact-repl/Pact/Core/IR/Eval/Direct/Types.hs @@ -53,6 +53,7 @@ module Pact.Core.IR.Eval.Direct.Types , toArgTypeError , argsError , mkDirectBuiltinFn + , enforceSaturatedApp ) where import Control.Lens @@ -124,6 +125,7 @@ data PartialClosure (e :: RuntimeMode) (b :: K.Type) (i :: K.Type) = PartialClosure { _pcloFrame :: !(Maybe (StackFrame i)) , _pcloTypes :: !(NonEmpty (Arg Type i)) + , _pcloNArgs :: !Int , _pcloArity :: !Int , _pcloTerm :: !(EvalTerm b i) , _pcloRType :: !(Maybe Type) @@ -348,3 +350,24 @@ mkDirectBuiltinFn mkDirectBuiltinFn i b env fn = NativeFn b env fn (builtinArity b) i {-# INLINE mkDirectBuiltinFn #-} + +invalidArgs + :: i + -> ErrorClosureType + -> Int + -> Int + -> EvalM e b i a +invalidArgs info mn expected actual = + throwExecutionError info $ InvalidNumArgs mn expected actual + +enforceSaturatedApp :: IsBuiltin b => i -> EvalValue e b i -> EvalM e b i () +enforceSaturatedApp info = \case + VPactValue _ -> pure () + VClosure clo -> case clo of + PC pc -> + invalidArgs info (maybe ErrClosureLambda ErrClosureUserFun (_sfName <$> _pcloFrame pc)) (_pcloArity pc + _pcloNArgs pc) (_pcloNArgs pc) + PN pn -> + let nargs = length (_pNativeAppliedArgs pn) + in invalidArgs info (ErrClosureNativeFun (builtinName (_pNative pn))) (_pNativeArity pn + nargs) nargs + _ -> pure () +{-# INLINE enforceSaturatedApp #-} diff --git a/pact-repl/Pact/Core/Repl/Runtime/ReplBuiltin.hs b/pact-repl/Pact/Core/Repl/Runtime/ReplBuiltin.hs index 53578934f..3847b8c1e 100644 --- a/pact-repl/Pact/Core/Repl/Runtime/ReplBuiltin.hs +++ b/pact-repl/Pact/Core/Repl/Runtime/ReplBuiltin.hs @@ -385,7 +385,7 @@ testCapability info b cont handler env = \case [VCapToken origToken] -> do d <- getDefCap info (_ctName origToken) let cBody = Constant LUnit info - cont' = SeqC env cBody cont + cont' = SeqC env info cBody cont case _dcapMeta d of Unmanaged -> evalCap info cont' handler env origToken PopCapInvoke TestCapEval cBody diff --git a/pact-tests/constructor-tag-goldens/EvalError.golden b/pact-tests/constructor-tag-goldens/EvalError.golden index e7979ae49..848adddba 100644 --- a/pact-tests/constructor-tag-goldens/EvalError.golden +++ b/pact-tests/constructor-tag-goldens/EvalError.golden @@ -73,4 +73,5 @@ {"conName":"HyperlaneDecodeError","conIndex":"48"} {"conName":"ModuleAdminNotAcquired","conIndex":"49"} {"conName":"UnknownException","conIndex":"4a"} +{"conName":"InvalidNumArgs","conIndex":"4b"} diff --git a/pact-tests/pact-tests/partial-app-errors.repl b/pact-tests/pact-tests/partial-app-errors.repl new file mode 100644 index 000000000..b0f415725 --- /dev/null +++ b/pact-tests/pact-tests/partial-app-errors.repl @@ -0,0 +1,20 @@ + +(expect-failure "Partial application error is thrown when trying to sequence a partial native app with a value" + "Incorrect number of arguments (1) for native function + supplied; expected (2)" + (do (+ 1) 1) +) + +(module m g (defcap g () true) + + (defun f:integer (a:integer b:integer c:string) (do a b)) +) + +(expect-failure "Partial application error is thrown when trying to sequence a partial user fun app with a value" + "Incorrect number of arguments (1) for function m.f.{nv2apbz7RTDv53cf46_3VX1msHQzBgTEqfxumYRGdf8} supplied; expected (3)" + (do (f 1) 1) +) + +(expect-failure "Partial application error is thrown when trying to sequence a partial lambda app with a value" + "Incorrect number of arguments (1) for lambda supplied; expected (3)" + (do ((lambda (x y z) x) 1) 1) +) diff --git a/pact/Pact/Core/Errors.hs b/pact/Pact/Core/Errors.hs index dc3daf0f1..0fd0c76ae 100644 --- a/pact/Pact/Core/Errors.hs +++ b/pact/Pact/Core/Errors.hs @@ -38,6 +38,7 @@ module Pact.Core.Errors , LegacyPactErrorType(..) , PactErrorCompat(..) , VerifierError(..) + , ErrorClosureType(..) , _PELexerError , _PEParseError , _PEDesugarError @@ -184,6 +185,7 @@ module Pact.Core.Errors , _HyperlaneDecodeErrorInternal , _HyperlaneDecodeErrorBinary , _HyperlaneDecodeErrorParseRecipient + , _InvalidNumArgs , toPrettyLegacyError , BoundedText , _boundedText @@ -722,8 +724,23 @@ data EvalError -- ^ Module admin was needed for a particular operation, but has not been acquired. | UnknownException Text -- ^ An unknown exception was thrown and converted to text. Intentionally and crucially lazy. + | InvalidNumArgs ErrorClosureType Int Int deriving (Eq, Show, Generic) +data ErrorClosureType + = ErrClosureUserFun FullyQualifiedName + | ErrClosureLambda + | ErrClosureNativeFun NativeName + deriving (Eq, Show, Generic) + +instance NFData ErrorClosureType + +instance Pretty ErrorClosureType where + pretty = \case + ErrClosureUserFun fqn -> "function" <+> pretty fqn + ErrClosureLambda -> "lambda" + ErrClosureNativeFun n -> "native function" <+> pretty n + instance NFData EvalError @@ -915,6 +932,13 @@ instance Pretty EvalError where "Module admin necessary for operation but has not been acquired:" <> pretty mn UnknownException msg -> "Unknown exception: " <> pretty msg + InvalidNumArgs errCloType expected actual -> + "Incorrect number of arguments" + <+> parens (pretty actual) + <+> "for" + <+> pretty errCloType + <+> "supplied; expected" + <+> parens (pretty expected) -- | Errors meant to be raised -- internally by a PactDb implementation @@ -1558,6 +1582,20 @@ evalErrorToBoundedText = mkBoundedText . \case -- Maybe library dependent, do not serialise UnknownException _ -> thsep ["Unknown exception"] + InvalidNumArgs mfqn expected actual -> + thsep + [ "Incorrect number of arguments" + , tparens (tInt actual) + , "for" + , renderClosureType mfqn + , "supplied; expected" + , tInt expected] + where + renderClosureType = \case + ErrClosureLambda -> "lambda" + ErrClosureUserFun fqn -> thsep ["user function", tFqn fqn] + ErrClosureNativeFun b -> thsep ["native function", _natName b] + -- | 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. @@ -1705,6 +1743,8 @@ thsep :: [Text] -> Text thsep = concatBounded (fromIntegral (natVal (Proxy @PactErrorMsgSize))) . intersperse " " tdquotes :: Text -> Text tdquotes x = T.concat ["\"", x, "\""] +tparens :: Text -> Text +tparens x = T.concat ["(", x, ")"] tInt :: Int -> Text tInt = T.pack . show tBool :: Bool -> Text diff --git a/pact/Pact/Core/IR/Eval/CEK/Evaluator.hs b/pact/Pact/Core/IR/Eval/CEK/Evaluator.hs index fb5c57171..efe6993ca 100644 --- a/pact/Pact/Core/IR/Eval/CEK/Evaluator.hs +++ b/pact/Pact/Core/IR/Eval/CEK/Evaluator.hs @@ -209,7 +209,7 @@ evaluateTerm cont handler env (Builtin b info) = do -- evaluateTerm cont handler env (Sequence e1 e2 _info) = do -- chargeGasArgs info (GAConstant constantWorkNodeGas) - evalCEK (SeqC env e2 cont) handler env e1 + evalCEK (SeqC env _info e2 cont) handler env e1 -- | ------ From --------------- | ------ To ------------------------ | -- -- @@ -1008,7 +1008,8 @@ applyContToValue (LetC env i arg letbody cont) handler v = do -- | ------ From ------------ | ------ To ---------------- | -- <_, SeqC(E, e2, K), H> -- -applyContToValue (SeqC env e cont) handler _ = +applyContToValue (SeqC env info e cont) handler v = do + enforceSaturatedApp info v evalCEK cont handler env e -- | ------ From ------------------------ | ------ To ---------------- | -- if b then @@ -1359,7 +1360,7 @@ applyLam vc@(C (Closure fqn ca arity term mty env cloi)) args cont handler apply' e (ty:tys) [] = do let env' = set ceLocal e env -- Todo: fix partial SF args - pclo = PartialClosure (Just (StackFrame fqn [] SFDefun cloi)) (ty :| tys) (length tys + 1) term mty env' cloi + pclo = PartialClosure (Just (StackFrame fqn [] SFDefun cloi)) (ty :| tys) argLen (length tys + 1) term mty env' cloi returnCEKValue cont handler (VPartialClosure pclo) apply' _ [] _ = throwExecutionError cloi ClosureAppliedToTooManyArgs @@ -1394,29 +1395,29 @@ applyLam (LC (LamClosure ca arity term mty env cloi)) args cont handler evalCEK cont handler (set ceLocal e env) term apply' e (ty:tys) [] = returnCEKValue cont handler - (VPartialClosure (PartialClosure Nothing (ty :| tys) (length tys + 1) term mty (set ceLocal e env) cloi)) + (VPartialClosure (PartialClosure Nothing (ty :| tys) argLen (length tys + 1) term mty (set ceLocal e env) cloi)) apply' _ [] _ = do throwExecutionError cloi ClosureAppliedToTooManyArgs -applyLam (PC (PartialClosure li argtys _ term mty env cloi)) args cont handler = do +applyLam (PC (PartialClosure li argtys nargs _ term mty env cloi)) args cont handler = do chargeGasArgs cloi (GAApplyLam (_sfName <$> li) (length args)) - apply' (view ceLocal env) (NE.toList argtys) args + apply' nargs (view ceLocal env) (NE.toList argtys) args where - apply' e (Arg _ ty _:tys) (x:xs) = do + apply' n e (Arg _ ty _:tys) (x:xs) = do x' <- enforcePactValue cloi x maybeTCType cloi ty x' - apply' (RAList.cons (VPactValue x') e) tys xs - apply' e [] [] = do + apply' (n + 1) (RAList.cons (VPactValue x') e) tys xs + apply' _ e [] [] = do case li of Just sf -> do evalWithStackFrame cloi cont handler (set ceLocal e env) mty sf term Nothing -> do let cont' = EnforcePactValueC cloi cont evalCEK cont' handler (set ceLocal e env) term - apply' e (ty:tys) [] = do - let pclo = PartialClosure li (ty :| tys) (length tys + 1) term mty (set ceLocal e env) cloi + apply' n e (ty:tys) [] = do + let pclo = PartialClosure li (ty :| tys) n (length tys + 1) term mty (set ceLocal e env) cloi returnCEKValue cont handler (VPartialClosure pclo) - apply' _ [] _ = do + apply' _ _ [] _ = do throwExecutionError cloi ClosureAppliedToTooManyArgs applyLam nclo@(N (NativeFn b env fn arity i)) args cont handler diff --git a/pact/Pact/Core/IR/Eval/CEK/Types.hs b/pact/Pact/Core/IR/Eval/CEK/Types.hs index 94285e53e..5fe940d03 100644 --- a/pact/Pact/Core/IR/Eval/CEK/Types.hs +++ b/pact/Pact/Core/IR/Eval/CEK/Types.hs @@ -196,6 +196,7 @@ data PartialClosure (e :: RuntimeMode) (b :: K.Type) (i :: K.Type) = PartialClosure { _pcloFrame :: !(Maybe (StackFrame i)) , _pcloTypes :: !(NonEmpty (Arg Type i)) + , _pcloNArgs :: !Int , _pcloArity :: !Int , _pcloTerm :: !(EvalTerm b i) , _pcloRType :: !(Maybe Type) @@ -436,7 +437,7 @@ data Cont (e :: RuntimeMode) (b :: K.Type) (i :: K.Type) -- ^ Let single-variable pushing -- Optimization frame: Bypasses closure creation and thus less alloc -- Known as a single argument it will not construct a needless closure - | SeqC (CEKEnv e b i) (EvalTerm b i) (Cont e b i) + | SeqC (CEKEnv e b i) i (EvalTerm b i) (Cont e b i) -- ^ Sequencing expression, holding the next term to evaluate | ListC (CEKEnv e b i) i [EvalTerm b i] [PactValue] (Cont e b i) -- ^ Continuation for list elements diff --git a/pact/Pact/Core/IR/Eval/CEK/Utils.hs b/pact/Pact/Core/IR/Eval/CEK/Utils.hs index af1bfa2a8..0a5c16f33 100644 --- a/pact/Pact/Core/IR/Eval/CEK/Utils.hs +++ b/pact/Pact/Core/IR/Eval/CEK/Utils.hs @@ -8,6 +8,7 @@ module Pact.Core.IR.Eval.CEK.Utils , readOnlyEnv , envFromPurity , enforcePactValue + , enforceSaturatedApp ) where import Control.Lens @@ -109,3 +110,24 @@ enforcePactValue :: i -> CEKValue e b i -> EvalM e b i PactValue enforcePactValue info = \case VPactValue pv -> pure pv _ -> throwExecutionError info ExpectedPactValue + +invalidArgs + :: i + -> ErrorClosureType + -> Int + -> Int + -> EvalM e b i a +invalidArgs info mn expected actual = + throwExecutionError info $ InvalidNumArgs mn expected actual + +enforceSaturatedApp :: IsBuiltin b => i -> CEKValue e b i -> EvalM e b i () +enforceSaturatedApp info = \case + VPactValue _ -> pure () + VClosure clo -> case clo of + PC pc -> + invalidArgs info (maybe ErrClosureLambda ErrClosureUserFun (_sfName <$> _pcloFrame pc)) (_pcloArity pc + _pcloNArgs pc) (_pcloNArgs pc) + PN pn -> + let nargs = length (_pNativeAppliedArgs pn) + in invalidArgs info (ErrClosureNativeFun (builtinName (_pNative pn))) (_pNativeArity pn + nargs) nargs + _ -> pure () +{-# INLINE enforceSaturatedApp #-}