Add some new mutators

NAMESPACE

@@ -12,33 +12,61 @@ export(Mutator)
 export(PackageCopyStrategy)
 export(ProgressMutationReporter)
 export(TestStrategy)
+export(all_mutators)
 export(arithmetic_operators)
 export(boolean_literal)
 export(boolean_literals)
+export(branch_mutations)
 export(call_name)
+export(colon_end_decrement)
+export(colon_start_increment)
 export(comparison_operators)
+export(condition_constant)
 export(condition_mutations)
 export(default_copy_strategy)
 export(default_reporter)
 export(default_test_strategy)
 export(delete_statement)
+export(double_to_integer)
+export(drop_argument)
+export(empty_if_body)
+export(flip_named_flag)
+export(function_swaps)
 export(index_decrement)
 export(index_increment)
 export(index_mutations)
+export(integer_to_double)
+export(keep_operand)
 export(logical_operators)
+export(membership_operators)
 export(muttest)
 export(muttest_plan)
 export(na_literal)
 export(na_literals)
 export(negate_condition)
+export(numeric_boundaries)
 export(numeric_decrement)
 export(numeric_increment)
 export(numeric_literals)
+export(numeric_replace)
+export(numeric_type_swaps)
+export(operand_elision)
 export(operator)
 export(remove_condition_negation)
+export(remove_else_branch)
 export(remove_negation)
+export(remove_null_guard)
+export(remove_pipe_stage)
+export(remove_unary_minus)
+export(remove_validation)
+export(replace_call_result)
+export(replace_implicit_return)
 export(replace_return_value)
 export(report)
+export(reverse_arguments)
+export(seq_along_drop_first)
+export(seq_len_decrement)
+export(sequence_mutations)
 export(string_empty)
 export(string_fill)
 export(string_literals)

NEWS.md

@@ -1,3 +1,12 @@
+# muttest (development version)
+
+- ✨ New mutators:
+  - Calls and arguments: `drop_argument()`, `reverse_arguments()`, `remove_validation()`, `flip_named_flag()`, `replace_call_result()`, `remove_pipe_stage()`.
+  - Control flow: `condition_constant()`, `remove_else_branch()`, `empty_if_body()`, `remove_null_guard()`, `keep_operand()`, `replace_implicit_return()`.
+  - Literals and sequences: `remove_unary_minus()`, `integer_to_double()`, `double_to_integer()`, `numeric_replace()`, `seq_len_decrement()`, `seq_along_drop_first()`, `colon_start_increment()`, `colon_end_decrement()`.
+- ✨ New presets: `function_swaps()` (`any`/`all`, `min`/`max`, `nrow`/`ncol`, ...), `membership_operators()`, `operand_elision()`, `branch_mutations()`, `numeric_boundaries()`, `numeric_type_swaps()` and `sequence_mutations()`.
+- ✨ New `all_mutators()` returns a flat list of every mutator with default arguments.
+
 # muttest 0.3.0
 
 - ✨ New `JSONMutationReporter` writes a report conforming to the [mutation-testing-elements](https://stryker-mutator.io) schema, a cross-language standard shared by StrykerJS/.NET/Scala — so muttest output can be fed to any schema-compatible tooling.

R/mutate-nodes.R

@@ -0,0 +1,91 @@
+# Helpers for mutators that need the tree-sitter node (not just its text) to
+# decide what to write back, e.g. to reuse a child node's text or to rewrite a
+# multi-line span. Mutators built on these set `mutate_fn` on the Mutator.
+
+proposal <- function(node, text) list(node = node, text = text)
+
+# Replace the (possibly multi-line) span of `node` with `text`.
+replace_span <- function(code, node, text) {
+  s <- treesitter::node_start_point(node)
+  e <- treesitter::node_end_point(node)
+  first <- code[s$row + 1L]
+  last <- code[e$row + 1L]
+  new <- strsplit(
+    paste0(substr(first, 1, s$column), text, substr(last, e$column + 1L, nchar(last))),
+    "\n",
+    fixed = TRUE
+  )[[1]]
+  if (length(new) == 0) new <- ""
+  c(code[seq_len(s$row)], new, code[-seq_len(e$row + 1L)])
+}
+
+# Run `query_str`, call `propose(node)` for every @target capture and build one
+# mutant per returned proposal(). `propose` may return NULL or an empty list.
+mutate_nodes <- function(code, query_str, propose) {
+  language <- treesitter.r::language()
+  parser <- treesitter::parser(language)
+  tree <- treesitter::parser_parse(parser, paste(code, collapse = "\n"))
+  root_node <- treesitter::tree_root_node(tree)
+  captures <- treesitter::query_captures(treesitter::query(language, query_str), root_node)
+
+  mutations <- list()
+  for (i in seq_along(captures$node)) {
+    if (captures$name[[i]] != "target") next
+    for (p in propose(captures$node[[i]])) {
+      mutations <- append(mutations, list(list(
+        code = replace_span(code, p$node, p$text),
+        location = node_location(p$node),
+        replacement = p$text
+      )))
+    }
+  }
+  if (length(mutations) == 0) return(NULL)
+  mutations
+}
+
+node_mutator <- function(from, to, query, propose) {
+  Mutator$new(
+    from = from,
+    to = to,
+    query = query,
+    mutate_fn = function(code) mutate_nodes(code, query, propose)
+  )
+}
+
+field_text <- function(node, field) {
+  child <- treesitter::node_child_by_field_name(node, field)
+  if (is.null(child)) NULL else treesitter::node_text(child)
+}
+
+# Name of the called function, without any `pkg::` prefix; NULL when the callee
+# is not a plain or namespaced identifier.
+call_function_name <- function(call_node) {
+  fn <- treesitter::node_child_by_field_name(call_node, "function")
+  if (is.null(fn)) return(NULL)
+  type <- treesitter::node_type(fn)
+  if (type == "namespace_operator") return(field_text(fn, "rhs"))
+  if (type == "identifier") return(treesitter::node_text(fn))
+  NULL
+}
+
+# Argument nodes of a call (comments excluded); empty list for `f()`.
+call_argument_nodes <- function(call_node) {
+  args <- treesitter::node_child_by_field_name(call_node, "arguments")
+  if (is.null(args)) return(list())
+  Filter(
+    function(n) treesitter::node_type(n) == "argument",
+    treesitter::node_named_children(args)
+  )
+}
+
+is_assignment_target <- function(node) {
+  parent <- treesitter::node_parent(node)
+  if (is.null(parent) || treesitter::node_type(parent) != "binary_operator") {
+    return(FALSE)
+  }
+  op <- field_text(parent, "operator")
+  side <- if (op %in% c("<-", "<<-", "=", ":=")) "lhs" else if (op %in% c("->", "->>")) "rhs" else return(FALSE)
+  target <- treesitter::node_child_by_field_name(parent, side)
+  treesitter::node_start_byte(target) == treesitter::node_start_byte(node) &&
+    treesitter::node_end_byte(target) == treesitter::node_end_byte(node)
+}

R/mutator-all.R

@@ -0,0 +1,57 @@
+#' All mutators
+#'
+#' Returns a flat list of every mutator muttest ships, built with default
+#' arguments: all the presets plus the standalone mutators not covered by one.
+#' Handy for a first exploratory run; expect a large number of mutants, so
+#' prefer scoping a plan to specific presets for routine use.
+#'
+#' Mutators that overlap are not duplicated: [remove_negation()] is included
+#' instead of [remove_condition_negation()], and `while` conditions are not
+#' forced to a constant (see [condition_constant()]). [drop_argument()] is
+#' unscoped, so it targets every call.
+#'
+#' @return A list of [Mutator] objects.
+#' @export
+#' @examples
+#' length(all_mutators())
+#'
+#' \dontrun{
+#' plan <- muttest_plan(
+#'   source_files = "R/stats.R",
+#'   mutators = all_mutators()
+#' )
+#' muttest(plan, "tests/testthat")
+#' }
+all_mutators <- function() {
+  c(
+    arithmetic_operators(),
+    comparison_operators(),
+    logical_operators(),
+    membership_operators(),
+    operand_elision(),
+    boolean_literals(),
+    na_literals(),
+    numeric_literals(),
+    numeric_boundaries(),
+    numeric_type_swaps(),
+    string_literals(),
+    index_mutations(),
+    sequence_mutations(),
+    branch_mutations(),
+    function_swaps(),
+    list(
+      negate_condition(),
+      remove_negation(),
+      remove_unary_minus(),
+      replace_return_value(),
+      replace_implicit_return(),
+      replace_call_result(),
+      delete_statement(),
+      drop_argument(),
+      reverse_arguments(),
+      remove_validation(),
+      flip_named_flag(),
+      remove_pipe_stage()
+    )
+  )
+}

R/mutator-arguments.R

@@ -0,0 +1,124 @@
+#' Drop one argument from a call
+#'
+#' Produces one mutant per argument of each call with two or more arguments,
+#' removing that argument: `f(a, b)` becomes `f(b)` and `f(a)`. Surviving
+#' mutants reveal parameters that have no observable effect. `return()` is never
+#' touched. Dropping arguments often yields code that errors, which counts as
+#' killed, so scope it with `functions` to keep runs fast.
+#'
+#' @param functions Character vector of function names to target (without
+#'   `pkg::`). `NULL`, the default, targets every call.
+#' @return A [Mutator] object.
+#' @export
+#' @examples
+#' drop_argument()
+#' drop_argument("c")
+drop_argument <- function(functions = NULL) {
+  checkmate::assert_character(functions, min.chars = 1, any.missing = FALSE, null.ok = TRUE)
+  argument_mutator("f(a, b)", "f(b)", functions, function(texts) {
+    lapply(seq_along(texts), function(i) texts[-i])
+  })
+}
+
+#' Reverse the arguments of a call
+#'
+#' Reverses the argument order of each call with two or more arguments, so
+#' `c(a, b)` becomes `c(b, a)`. Surviving mutants mean no test depends on the
+#' order of the elements.
+#'
+#' @param functions Character vector of function names to target (without
+#'   `pkg::`). Defaults to `"c"`; `NULL` targets every call.
+#' @return A [Mutator] object.
+#' @export
+#' @examples
+#' reverse_arguments()
+#' reverse_arguments(c("c", "paste"))
+reverse_arguments <- function(functions = "c") {
+  checkmate::assert_character(functions, min.chars = 1, any.missing = FALSE, null.ok = TRUE)
+  argument_mutator("f(a, b)", "f(b, a)", functions, function(texts) {
+    if (identical(rev(texts), texts)) list() else list(rev(texts))
+  })
+}
+
+# `variants(texts)` returns a list of character vectors, each the argument
+# texts for one mutant.
+argument_mutator <- function(from, to, functions, variants) {
+  node_mutator(
+    from = from,
+    to = to,
+    query = "(call) @target",
+    propose = function(node) {
+      name <- call_function_name(node)
+      if (is.null(name) || name == "return") return(NULL)
+      if (!is.null(functions) && !name %in% functions) return(NULL)
+      args <- call_argument_nodes(node)
+      if (length(args) < 2) return(NULL)
+      texts <- vapply(args, treesitter::node_text, character(1))
+      args_node <- treesitter::node_child_by_field_name(node, "arguments")
+      lapply(variants(texts), function(v) {
+        proposal(args_node, paste0("(", paste(v, collapse = ", "), ")"))
+      })
+    }
+  )
+}
+
+#' Remove validation calls
+#'
+#' Replaces calls that enforce preconditions with `NULL`, so
+#' `if (!is.numeric(x)) stop("bad")` becomes `if (!is.numeric(x)) NULL`.
+#' Surviving mutants mean no test checks that invalid input is rejected. By
+#' default targets `stop()`, `stopifnot()`, `warning()`, `rlang::abort()`,
+#' `cli::cli_abort()`, `cli::cli_warn()` and checkmate-style `assert_*()` calls.
+#'
+#' Unlike [delete_statement()], the call is replaced rather than deleted, so
+#' calls used as the body of an `if` stay syntactically valid.
+#'
+#' @param pattern Regular expression matched against the function name.
+#' @return A [Mutator] object.
+#' @export
+#' @examples
+#' remove_validation()
+#' remove_validation("^stopifnot$")
+remove_validation <- function(
+  pattern = "^(stop|stopifnot|warning|abort|cli_abort|cli_warn|assert_[A-Za-z0-9_]+)$"
+) {
+  checkmate::assert_string(pattern, min.chars = 1)
+  node_mutator(
+    from = "stop(...)",
+    to = "NULL",
+    query = "(call) @target",
+    propose = function(node) {
+      name <- call_function_name(node)
+      if (is.null(name) || !grepl(pattern, name)) return(NULL)
+      list(proposal(node, "NULL"))
+    }
+  )
+}
+
+#' Flip logical flags passed as named arguments
+#'
+#' Flips `TRUE`/`FALSE` only where it is the value of a named argument, e.g.
+#' `mean(x, na.rm = TRUE)` becomes `mean(x, na.rm = FALSE)`. A narrower and
+#' less noisy alternative to [boolean_literal()] for catching silently-wrong
+#' option handling (`na.rm`, `drop`, `fixed`, `decreasing`, ...).
+#'
+#' @param arguments Character vector of argument names to target. `NULL`, the
+#'   default, targets every named argument.
+#' @return A [Mutator] object.
+#' @export
+#' @examples
+#' flip_named_flag()
+#' flip_named_flag(c("na.rm", "drop"))
+flip_named_flag <- function(arguments = NULL) {
+  checkmate::assert_character(arguments, min.chars = 1, any.missing = FALSE, null.ok = TRUE)
+  node_mutator(
+    from = "name = TRUE",
+    to = "name = FALSE",
+    query = "(argument name: (_) value: [(true) (false)] @target)",
+    propose = function(node) {
+      name <- field_text(treesitter::node_parent(node), "name")
+      if (!is.null(arguments) && !name %in% arguments) return(NULL)
+      list(proposal(node, if (treesitter::node_text(node) == "TRUE") "FALSE" else "TRUE"))
+    }
+  )
+}