Provide better messages for code involving infix operators

R/detect_mistakes.R

@@ -1,10 +1,10 @@
 detect_mistakes <- function(
-    user,
-    solution,
-    env = rlang::env_parent(),
-    enclosing_call = NULL,
-    enclosing_arg = NULL,
-    allow_partial_matching = TRUE
+  user,
+  solution,
+  env = rlang::env_parent(),
+  enclosing_call = NULL,
+  enclosing_arg = NULL,
+  allow_partial_matching = TRUE
 ) {
   force(env)
 
@@ -119,7 +119,7 @@ detect_mistakes <- function(
 }
 
 detect_mistakes_expression <- function(
-    user, solution, env, enclosing_call, enclosing_arg, allow_partial_matching
+  user, solution, env, enclosing_call, enclosing_arg, allow_partial_matching
 ) {
   stopifnot(is.expression(solution))
 

R/detect_mistakes_helpers.R

@@ -1,5 +1,5 @@
 detect_wrong_value <- function(
-    user, solution, submitted, enclosing_arg, enclosing_call
+  user, solution, submitted, enclosing_arg, enclosing_call
 ) {
   if (is.call(user) && is.call(solution)) {
     return()
@@ -42,7 +42,7 @@ detect_wrong_call <- function(user, solution, enclosing_arg, enclosing_call) {
 }
 
 detect_name_problems <- function(
-    user, solution, enclosing_arg, enclosing_call, allow_partial_matching
+  user, solution, enclosing_arg, enclosing_call, allow_partial_matching
 ) {
   user_args <- as.list(user)
   user_names <- real_names(user)
@@ -140,7 +140,7 @@ detect_name_problems <- function(
 }
 
 detect_duplicate_names <- function(
-    user, user_names, solution_names, enclosing_call, enclosing_arg
+  user, user_names, solution_names, enclosing_call, enclosing_arg
 ) {
   user_arg_ns <- table(user_names)
   solution_arg_ns <- table(solution_names)
@@ -162,11 +162,11 @@ detect_duplicate_names <- function(
 }
 
 detect_too_many_matches <- function(
-    user,
-    remaining_solution_names,
-    remaining_user_names,
-    enclosing_call,
-    enclosing_arg
+  user,
+  remaining_solution_names,
+  remaining_user_names,
+  enclosing_call,
+  enclosing_arg
 ) {
   ## Do any non-matched solution names partially match multiple user names?
   pmatches_per_formal <- function(solution_name) {
@@ -190,7 +190,7 @@ detect_too_many_matches <- function(
 }
 
 detect_bad_argument_names <- function(
-    user, matches, enclosing_call, enclosing_arg
+  user, matches, enclosing_call, enclosing_arg
 ) {
   offenders <- matches[matches > 1]
 
@@ -209,7 +209,7 @@ detect_bad_argument_names <- function(
 }
 
 detect_surplus_argument <- function(
-    user, unused, enclosing_call, enclosing_arg
+  user, unused, enclosing_call, enclosing_arg
 ) {
   if (length(unused) > 0) {
     surplus_name <- rlang::names2(unused[1])
@@ -226,13 +226,13 @@ detect_surplus_argument <- function(
 }
 
 detect_pmatches_argument_name <- function(
-    user,
-    remaining_user_names,
-    remaining_solution_names,
-    matched_user_names,
-    matched_solution_names,
-    enclosing_call,
-    enclosing_arg
+  user,
+  remaining_user_names,
+  remaining_solution_names,
+  matched_user_names,
+  matched_solution_names,
+  enclosing_call,
+  enclosing_arg
 ) {
   ## where does partial matching occur ?
   where_pmatches <- function(user_name) {
@@ -253,7 +253,7 @@ detect_pmatches_argument_name <- function(
 }
 
 detect_unnamed_surplus_argument <- function(
-    user, user_args, solution_args, enclosing_call, enclosing_arg
+  user, user_args, solution_args, enclosing_call, enclosing_arg
 ) {
   # Check for unnamed, unused arguments
   # Any further matching will now be by position not name
@@ -275,7 +275,7 @@ detect_unnamed_surplus_argument <- function(
 }
 
 detect_missing_argument <- function(
-    submitted, solution_original, env, enclosing_call, enclosing_arg
+  submitted, solution_original, env, enclosing_call, enclosing_arg
 ) {
   explicit_user <- suppressWarnings(call_standardise_formals(
     unpipe_all(submitted),
@@ -306,7 +306,7 @@ detect_missing_argument <- function(
 }
 
 detect_surplus_dots_argument <- function(
-    user, user_names, solution_names, enclosing_call, enclosing_arg
+  user, user_names, solution_names, enclosing_call, enclosing_arg
 ) {
   unmatched_user_names <- setdiff(user_names, solution_names)
 
@@ -325,15 +325,15 @@ detect_surplus_dots_argument <- function(
 }
 
 detect_wrong_arguments <- function(
-    user,
-    solution,
-    solution_names,
-    submitted,
-    submitted_names,
-    env,
-    enclosing_call,
-    enclosing_arg,
-    allow_partial_matching
+  user,
+  solution,
+  solution_names,
+  submitted,
+  submitted_names,
+  env,
+  enclosing_call,
+  enclosing_arg,
+  allow_partial_matching
 ) {
   user_args <- as.list(user)[-1]         # remove the call
   solution_args <- as.list(solution)[-1] # remove the call

R/message_generators.R

@@ -24,11 +24,11 @@ message_missing_answer <- function(this_prior_line) {
 
 # bad argument name
 message_bad_argument_name <- function(
-    submitted_call,
-    submitted,
-    submitted_name,
-    enclosing_call = NULL,
-    enclosing_arg = NULL
+  submitted_call,
+  submitted,
+  submitted_name,
+  enclosing_call = NULL,
+  enclosing_arg = NULL
 ) { # only if the user supplied one (to match user code)
 
   # f(1, g(1, h(b = i(1))))
@@ -66,10 +66,10 @@ message_bad_argument_name <- function(
 
 # duplicate_name
 message_duplicate_name <- function(
-    submitted_call,
-    submitted_name,
-    enclosing_call = NULL,
-    enclosing_arg = NULL
+  submitted_call,
+  submitted_name,
+  enclosing_call = NULL,
+  enclosing_arg = NULL
 ) {
   # f(a = 1, a = 2)
   # f(a = 1)
@@ -100,10 +100,10 @@ message_duplicate_name <- function(
 # WHAT TO DO IF THE MISSING ARGUMENT DOESN'T HAVE A NAME IN THE SOLUTION?
 # missing argument
 message_missing_argument <- function(
-    submitted_call,
-    solution_name = NULL,
-    enclosing_call = NULL,
-    enclosing_arg = NULL
+  submitted_call,
+  solution_name = NULL,
+  enclosing_call = NULL,
+  enclosing_arg = NULL
 ) {
   # f(1, g(1, h(i(1))))
   # f(1, a = g(1, a = h(a = i(1)), b = i(2)))
@@ -142,11 +142,11 @@ message_missing_argument <- function(
 
 # surplus argument
 message_surplus_argument <- function(
-    submitted_call,
-    submitted,
-    submitted_name = NULL,
-    enclosing_call = NULL,
-    enclosing_arg = NULL
+  submitted_call,
+  submitted,
+  submitted_name = NULL,
+  enclosing_call = NULL,
+  enclosing_arg = NULL
 ) {
   # f(1, g(1, h(1, b = i(1))))
   # f(1, a = g(1, a = h(a = 1)))
@@ -187,12 +187,12 @@ message_surplus_argument <- function(
 
 # partial matching
 message_pmatches_argument_name <- function(
-    submitted_call,
-    submitted,
-    submitted_name = NULL,
-    solution_name = NULL,
-    enclosing_call = NULL,
-    enclosing_arg = NULL
+  submitted_call,
+  submitted,
+  submitted_name = NULL,
+  solution_name = NULL,
+  enclosing_call = NULL,
+  enclosing_arg = NULL
 ) {
   # "{intro}I did not expect your call to {submitted_call} to ",
   # "include {submitted}. You ",
@@ -242,10 +242,10 @@ message_pmatches_argument_name <- function(
 
 # too_many_matches
 message_too_many_matches <- function(
-    submitted_call,
-    solution_name,
-    enclosing_call = NULL,
-    enclosing_arg = NULL
+  submitted_call,
+  solution_name,
+  enclosing_call = NULL,
+  enclosing_arg = NULL
 ) {
   # f(1, g(1, h(b = i(1), ba = 2)))
   # f(1, a = g(1, a = h(bab = 1)))
@@ -280,11 +280,12 @@ message_too_many_matches <- function(
 }
 
 # wrong call
-message_wrong_call <- function(submitted,
-                       solution,
-                       submitted_name = NULL,
-                       enclosing_call = NULL) {
-
+message_wrong_call <- function(
+  submitted,
+  solution,
+  submitted_name = NULL,
+  enclosing_call = NULL
+) {
   # f(1, g(1, h(a = i(1))))
   # f(1, a = g(1, a = h(a = j(1))))
 
@@ -295,6 +296,16 @@ message_wrong_call <- function(submitted,
   intro <- build_intro(.call = enclosing_call)
 
   solution_original <- solution
+
+  # If both `submitted` and `solution` are infixes, only show the infix,
+  # e.g. "I expected you to call `+` where you called `*`."
+  # Otherwise, show the context around the infix,
+  # e.g. "I expected you to call `mean()` where you called `(x + y)/2`."
+  if (is_infix(submitted) && is_infix(solution)) {
+    submitted <- submitted[[1]]
+    solution <- solution[[1]]
+  }
+
   submitted <- prep(submitted)
   solution <- prep(solution)
 
@@ -324,10 +335,10 @@ message_wrong_call <- function(submitted,
 # argument that appears before the call or value. It should be passed to
 # submitted_name
 message_wrong_value <- function(
-    submitted,
-    solution,
-    submitted_name = NULL,
-    enclosing_call = NULL
+  submitted,
+  solution,
+  submitted_name = NULL,
+  enclosing_call = NULL
 ) {
   if (is_missing(submitted)) {
     submitted <- NULL
@@ -343,7 +354,7 @@ message_wrong_value <- function(
   intro <- build_intro(.call = enclosing_call)
 
   expected <- "expected"
-  if (length(submitted) > length(solution)) {
+  if (length(submitted) > length(solution) && !is_infix(submitted)) {
     expected <- "didn't expect"
     solution <- submitted
     submitted <- NULL
@@ -356,7 +367,9 @@ message_wrong_value <- function(
 
   if (is.null(submitted)) {
     intro <- ""
-    submitted <- build_intro(enclosing_call %||% solution_original, .open = "", .close = "")
+    submitted <- build_intro(
+      enclosing_call %||% solution_original, .open = "", .close = ""
+    )
   } else {
     submitted <- prep(submitted)
   }
@@ -394,8 +407,10 @@ prep <- function(text) {
   # grab whole expression ending up with: NULL <- NULL.
   # this extra condition to use `[[` works, but requires further
   # investigation for a cleaner solution.
-  if (is_infix(text)) {
+  if (is_infix_assign(text)) {
     text <- text[[1]]
+  } else if (is_infix(text)) {
+    text <- text
   } else if (is.call(text) && !is_pipe(text)) {
     text <- text[1]
   } else if (is.pairlist(text)) {