Make pact throw an error on unused partial application

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

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 #-}

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

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"}
 

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

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

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 ------------------------ |
 --   <CAnd e1 e2, E, K, H>         <e1, E, CondC(E, AndFrame(e2),K),H>
 --   <COr e1 e2, E, K, H>          <e1, E, CondC(E, OrFrame(e2),K),H>
@@ -1008,7 +1008,8 @@ applyContToValue (LetC env i arg letbody cont) handler v = do
 -- | ------ From ------------ | ------ To ---------------- |
 --   <_, SeqC(E, e2, K), H>     <e2, E, 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 ---------------- |
 --   <VBool b, CondC(E, AndC(e2), K), H>   if b then <e2, E, EnforceBool(K), H>
@@ -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

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

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 #-}