expect_type_linter

DESCRIPTION

@@ -22,6 +22,7 @@ Imports:
     codetools,
     cyclocomp,
     digest,
+    glue,
     jsonlite,
     knitr,
     stats,
@@ -32,6 +33,7 @@ Suggests:
     covr,
     httr (>= 1.2.1),
     mockery,
+    patrick,
     rmarkdown,
     rstudioapi (>= 0.2),
     testthat (>= 3.0.0),
@@ -63,6 +65,7 @@ Collate:
     'exclude.R'
     'expect_lint.R'
     'expect_null_linter.R'
+    'expect_type_linter.R'
     'extract.R'
     'extraction_operator_linter.R'
     'function_left_parentheses.R'

NAMESPACE

@@ -32,6 +32,7 @@ export(equals_na_linter)
 export(expect_lint)
 export(expect_lint_free)
 export(expect_null_linter)
+export(expect_type_linter)
 export(extraction_operator_linter)
 export(function_left_parentheses_linter)
 export(get_source_expressions)

NEWS.md

@@ -88,6 +88,7 @@ function calls. (#850, #851, @renkun-ken)
 * `lintr` now uses the 3rd edition of `testthat` (@MichaelChirico, #910)
 * `lintr` is adopting a new set of linters provided as part of Google's extension to the tidyverse style guide (#884, @michaelchirico)
    + `expect_null_linter()` Require usage of `expect_null(x)` over `expect_equal(x, NULL)` and similar
+   + `expect_type_linter()` Require usage of `expect_type(x, t)` over `expect_equal(typeof(x), t)` and similar
 * `assignment_linter()` now lints right assignment (`->` and `->>`) and gains two arguments. `allow_cascading_assign` (`TRUE` by default) toggles whether to lint `<<-` and `->>`; `allow_right_assign` toggles whether to lint `->` and `->>` (#915, @michaelchirico)
 
 # lintr 2.0.1

R/expect_type_linter.R

@@ -0,0 +1,62 @@
+#' Require usage of expect_type(x, type) over expect_equal(typeof(x), type)
+#'
+#' [testthat::expect_type()] exists specifically for testing the storage type
+#'   of objects. [testthat::expect_equal()], [testthat::expect_identical()], and
+#'   [testthat::expect_true()] can also be used for such tests,
+#'   but it is better to use the tailored function instead.
+#'
+#' @evalRd rd_tags("expect_type_linter")
+#' @seealso [linters] for a complete list of linters available in lintr.
+#' @export
+expect_type_linter <- function() {
+  Linter(function(source_file) {
+    if (length(source_file$parsed_content) == 0L) {
+      return(list())
+    }
+
+    xml <- source_file$xml_parsed_content
+
+    base_type_tests <- xp_text_in_table(paste0("is.", base_types)) # nolint: object_usage_linter. TODO(#942): fix this.
+    xpath <- glue::glue("//expr[
+      (
+        SYMBOL_FUNCTION_CALL[text() = 'expect_equal' or text() = 'expect_identical']
+        and following-sibling::expr[
+          expr[SYMBOL_FUNCTION_CALL[text() = 'typeof']]
+          and (position() = 1 or preceding-sibling::expr[STR_CONST])
+        ]
+      ) or (
+        SYMBOL_FUNCTION_CALL[text() = 'expect_true']
+        and following-sibling::expr[1][expr[SYMBOL_FUNCTION_CALL[ {base_type_tests} ]]]
+      )
+    ]")
+
+    bad_expr <- xml2::xml_find_all(xml, xpath)
+    return(lapply(bad_expr, gen_expect_type_lint, source_file))
+  })
+}
+
+gen_expect_type_lint <- function(expr, source_file) {
+  matched_function <- xml2::xml_text(xml2::xml_find_first(expr, "SYMBOL_FUNCTION_CALL"))
+  if (matched_function %in% c("expect_equal", "expect_identical")) {
+    lint_msg <- sprintf("expect_type(x, t) is better than %s(typeof(x), t)", matched_function)
+  } else {
+    lint_msg <- "expect_type(x, t) is better than expect_true(is.<t>(x))"
+  }
+  xml_nodes_to_lint(expr, source_file, lint_msg, type = "warning")
+}
+
+
+# NB: the full list of values that can arise from `typeof(x)` is available
+#   in ?typeof (or, slightly more robustly, in the R source: src/main/util.c.
+#   Not all of them are available in is.<type> form, e.g. 'any' or
+#   'special'. 'builtin' and 'closure' are special cases, corresponding to
+#   is.primitive and is.function (essentially).
+base_types <- c(
+  "raw", "logical", "integer", "double", "complex", "character", "list",
+  "numeric", "function", "primitive", "environment", "pairlist", "promise",
+  # Per ?is.language, it's the same as is.call || is.name || is.expression.
+  #   so by blocking it, we're forcing more precise tests of one of
+  #   those directly ("language", "symbol", and "expression", resp.)
+  # NB: is.name and is.symbol are identical.
+  "language", "call", "name", "symbol", "expression"
+)

inst/lintr/linters.csv

@@ -1,44 +1,45 @@
 linter,tags
 absolute_path_linter,robustness best_practices configurable
 assignment_linter,style consistency default
+assignment_spaces_linter,style readability
 backport_linter,robustness configurable package_development
 closed_curly_linter,style readability default configurable
 commas_linter,style readability default
 commented_code_linter,style readability best_practices default
 cyclocomp_linter,style readability best_practices default configurable
+duplicate_argument_linter,correctness common_mistakes configurable
 equals_na_linter,robustness correctness common_mistakes default
 expect_null_linter,package_development best_practices
+expect_type_linter,package_development best_practices
 extraction_operator_linter,style best_practices
 function_left_parentheses_linter,style readability default
 implicit_integer_linter,style consistency best_practices
 infix_spaces_linter,style readability default
 line_length_linter,style readability default configurable
+missing_argument_linter,correctness common_mistakes configurable
+missing_package_linter,robustness common_mistakes
+namespace_linter,correctness robustness configurable
 no_tab_linter,style consistency default
 nonportable_path_linter,robustness best_practices configurable
 object_length_linter,style readability default configurable
 object_name_linter,style consistency default configurable
 object_usage_linter,style readability correctness default
 open_curly_linter,style readability default configurable
 package_hooks_linter,style correctness package_development
+paren_body_linter,style readability default
 paren_brace_linter,style readability default
+pipe_call_linter,style readability
 pipe_continuation_linter,style readability default
 semicolon_terminator_linter,style readability default configurable
 seq_linter,robustness efficiency consistency best_practices default
 single_quotes_linter,style consistency readability default
 spaces_inside_linter,style readability default
 spaces_left_parentheses_linter,style readability default
+sprintf_linter,correctness common_mistakes
 T_and_F_symbol_linter,style readability robustness consistency best_practices default
 todo_comment_linter,style configurable
 trailing_blank_lines_linter,style default
 trailing_whitespace_linter,style default
 undesirable_function_linter,style efficiency configurable robustness best_practices
 undesirable_operator_linter,style efficiency configurable robustness best_practices
 unneeded_concatenation_linter,style readability efficiency
-assignment_spaces_linter,style readability
-duplicate_argument_linter,correctness common_mistakes configurable
-missing_argument_linter,correctness common_mistakes configurable
-missing_package_linter,robustness common_mistakes
-namespace_linter,correctness robustness configurable
-paren_body_linter,style readability default
-pipe_call_linter,style readability
-sprintf_linter,correctness common_mistakes

tests/testthat/test-expect_type_linter.R

@@ -0,0 +1,62 @@
+test_that("expect_type_linter skips allowed usages", {
+  # expect_type doesn't have an inverted version
+  expect_lint("expect_true(!is.numeric(x))", NULL, expect_type_linter())
+  # NB: also applies to tinytest, but it's sufficient to test testthat
+  expect_lint("testthat::expect_true(!is.numeric(x))", NULL, expect_type_linter())
+
+  # other is.<x> calls are not suitable for expect_type in particular
+  expect_lint("expect_true(is.data.frame(x))", NULL, expect_type_linter())
+
+  # expect_type(x, ...) cannot be cleanly used here:
+  expect_lint("expect_true(typeof(x) %in% c('builtin', 'closure'))", NULL, expect_type_linter())
+})
+
+test_that("expect_type_linter blocks simple disallowed usages", {
+  expect_lint(
+    "expect_equal(typeof(x), 'double')",
+    rex::rex("expect_type(x, t) is better than expect_equal(typeof(x), t)"),
+    expect_type_linter()
+  )
+
+  # expect_identical is treated the same as expect_equal
+  expect_lint(
+    "testthat::expect_identical(typeof(x), 'language')",
+    rex::rex("expect_type(x, t) is better than expect_identical(typeof(x), t)"),
+    expect_type_linter()
+  )
+
+  # different equivalent usage
+  expect_lint(
+    "expect_true(is.complex(foo(x)))",
+    rex::rex("expect_type(x, t) is better than expect_true(is.<t>(x))"),
+    expect_type_linter()
+  )
+
+  # yoda test with clear expect_type replacement
+  expect_lint(
+    "expect_equal('integer', typeof(x))",
+    rex::rex("expect_type(x, t) is better than expect_equal(typeof(x), t)"),
+    expect_type_linter()
+  )
+})
+
+
+skip_if_not_installed("patrick")
+local({
+  # test for lint errors appropriately raised for all is.<type> calls
+  is_types <- c(
+    "raw", "logical", "integer", "double", "complex", "character", "list",
+    "numeric", "function", "primitive", "environment", "pairlist", "promise",
+    "language", "call", "name", "symbol", "expression"
+  )
+  patrick::with_parameters_test_that(
+    "expect_type_linter catches expect_true(is.<base type>)",
+    expect_lint(
+      sprintf("expect_true(is.%s(x))", is_type),
+      rex::rex("expect_type(x, t) is better than expect_true(is.<t>(x))"),
+      expect_type_linter()
+    ),
+    .test_name = is_types,
+    is_type = is_types
+  )
+})