Add argument args to check_function()

R/standalone-types-check.R

@@ -3,12 +3,16 @@
 # file: standalone-types-check.R
 # last-updated: 2023-03-13
 # license: https://unlicense.org
-# dependencies: standalone-obj-type.R
+# dependencies: [standalone-obj-type.R, standalone-cli.R]
 # imports: rlang (>= 1.1.0)
 # ---
 #
 # ## Changelog
 #
+# 2023-08-31:
+# - `check_functions()` gains the argument `args` to specify which arguments the
+#   function should have (@mgirlich).
+#
 # 2023-03-13:
 # - Improved error messages of number checkers (@teunbrand)
 # - Added `allow_infinite` argument to `check_number_whole()` (@mgirlich).
@@ -381,11 +385,19 @@ check_environment <- function(x,
 
 check_function <- function(x,
                            ...,
+                           args = NULL,
                            allow_null = FALSE,
                            arg = caller_arg(x),
                            call = caller_env()) {
   if (!missing(x)) {
     if (is_function(x)) {
+      .check_function_args(
+        f = x,
+        expected_args = args,
+        arg = arg,
+        call = call
+      )
+
       return(invisible(NULL))
     }
     if (allow_null && is_null(x)) {
@@ -404,6 +416,56 @@ check_function <- function(x,
   )
 }
 
+.check_function_args <- function(f,
+                                 expected_args,
+                                 arg,
+                                 call) {
+  if (is_null(expected_args)) {
+    return(invisible(NULL))
+  }
+
+  actual_args <- fn_fmls_names(f) %||% character()
+  n_actual_args <- length(actual_args)
+
+  if (is.numeric(expected_args)) {
+    n_expected_args <- expected_args
+    if (n_actual_args >= n_expected_args) {
+      return(invisible(NULL))
+    }
+
+    message <- sprintf(
+      "%s must have at least %i %s, not %i %s.",
+      format_arg(arg),
+      n_expected_args,
+      pluralise(n_expected_args, "argument", "arguments"),
+      n_actual_args,
+      pluralise(n_actual_args, "argument", "arguments")
+    )
+    abort(message, call = call, arg = arg)
+  }
+
+  missing_args <- setdiff(expected_args, actual_args)
+  if (is_empty(missing_args)) {
+    return(invisible(NULL))
+  }
+
+  if (n_actual_args == 0) {
+    arg_info <- "instead it has no arguments"
+  } else {
+    arg_info <- paste0("instead it has ", format_arg(actual_args))
+  }
+
+  n_expected_args <- length(expected_args)
+  message <- sprintf(
+    "%s must have the %s %s, %s.",
+    format_arg(arg),
+    pluralise(n_expected_args, "argument", "arguments"),
+    format_arg(expected_args),
+    arg_info
+  )
+  abort(message, call = call, arg = arg)
+}
+
 check_closure <- function(x,
                           ...,
                           allow_null = FALSE,

tests/testthat/_snaps/standalone-types-check.md

@@ -391,6 +391,69 @@
       Error in `checker()`:
       ! `foo` must be a defused call, not a symbol.
 
+# `check_function()` checks
+
+    Code
+      err(checker(, check_function))
+    Output
+      <error/rlang_error>
+      Error in `checker()`:
+      ! `foo` must be a function, not absent.
+    Code
+      err(checker(NULL, check_function))
+    Output
+      <error/rlang_error>
+      Error in `checker()`:
+      ! `foo` must be a function, not `NULL`.
+    Code
+      err(checker(TRUE, check_function))
+    Output
+      <error/rlang_error>
+      Error in `checker()`:
+      ! `foo` must be a function, not `TRUE`.
+    Code
+      err(checker(alist(foo(), bar()), check_function, allow_null = TRUE))
+    Output
+      <error/rlang_error>
+      Error in `checker()`:
+      ! `foo` must be a function or `NULL`, not a list.
+    Code
+      err(checker(quote(foo), check_function))
+    Output
+      <error/rlang_error>
+      Error in `checker()`:
+      ! `foo` must be a function, not a symbol.
+
+---
+
+    Code
+      err(checker(function() x, args = 2, check_function))
+    Output
+      <error/rlang_error>
+      Error in `checker()`:
+      ! `foo` must have at least 2 arguments, not 0 arguments.
+
+---
+
+    Code
+      err(checker(function() x, args = "x", check_function))
+    Output
+      <error/rlang_error>
+      Error in `checker()`:
+      ! `foo` must have the argument `x`, instead it has no arguments.
+    Code
+      err(checker(function(y) x, args = "x", check_function))
+    Output
+      <error/rlang_error>
+      Error in `checker()`:
+      ! `foo` must have the argument `x`, instead it has `y`.
+    Code
+      err(checker(function(y, z) x, args = "x", check_function))
+    Output
+      <error/rlang_error>
+      Error in `checker()`:
+      ! `foo` must have the argument `x`, instead it has `y` and `z`.
+
 # `check_environment()` checks
 
     Code

tests/testthat/test-standalone-types-check.R

@@ -138,6 +138,42 @@ test_that("`check_call()` checks", {
   })
 })
 
+test_that("`check_function()` checks", {
+  expect_null(check_function(function(x) x))
+  expect_null(check_function(NULL, allow_null = TRUE))
+
+  expect_snapshot({
+    err(checker(, check_function))
+    err(checker(NULL, check_function))
+    err(checker(TRUE, check_function))
+    err(checker(alist(foo(), bar()), check_function, allow_null = TRUE))
+    err(checker(quote(foo), check_function))
+  })
+
+  # numeric `args`
+  expect_null(check_function(function() x, args = 0))
+  expect_null(check_function(function(x) x, args = 0))
+  # can also have more arguments
+  expect_null(check_function(function(x, y, z) x, args = 2))
+
+  # must not have too few arguments
+  expect_snapshot({
+    err(checker(function() x, args = 2, check_function))
+  })
+
+  # character `args`
+  expect_null(check_function(function() x, args = character()))
+  expect_null(check_function(function(x) x, args = "x"))
+  expect_null(check_function(function(x, y, z) x, args = c("x", "y")))
+
+  # arguments missing
+  expect_snapshot({
+    err(checker(function() x, args = "x", check_function))
+    err(checker(function(y) x, args = "x", check_function))
+    err(checker(function(y, z) x, args = "x", check_function))
+  })
+})
+
 test_that("`check_environment()` checks", {
   expect_null(check_environment(env()))
   expect_null(check_environment(NULL, allow_null = TRUE))