closes #19, error messages are more consistent, give more context

r-lib · Jul 26, 2017 · 28c479c · 28c479c
1 parent 81dfd87
commit 28c479c
Show file tree

Hide file tree

Showing 3 changed files with 58 additions and 23 deletions.
diff --git a/R/assignment-op.R b/R/assignment-op.R
@@ -180,18 +180,34 @@
     return(invisible(value))
   }
 
-    if (internals[1] == ':' && !(is.atomic(value) || is_Date(value))) {
-      stop('expecting vector of values, but found ', class(value),
-           call. = FALSE)
-    }
+  if (!all(internals == ":" | internals == "{")) {
+    name <- internals[which(!(internals == ":" | internals == "{"))][1]
+    stop(
+      "invalid `%<-%` left-hand side, unexpected call `", name, "`",
+      call. = FALSE
+    )
+  }
 
-    # NULL as a value slips through here, bug or feature?
-    if (internals[1] == '{' && is.vector(value) && !is_list(value)) {
-      stop('expecting list of values, but found vector', call. = FALSE)
-    }
+  #
+  # only when unpacking an atomic or date are `{` and `}` not required
+  #
+  if (internals[1] == ":" && !(is.atomic(value) || is_Date(value))) {
+    stop(
+      "invalid `%<-%` right-hand side, expecting vector of values, ",
+      "but found ", class(value),
+      call. = FALSE
+    )
+  }
 
-  } else {
-    stop('use `<-` for standard assignment', call. = FALSE)
+  #
+  # use `{`s only for non-vector values
+  #
+  if (internals[1] == "{" && is.vector(value) && !is_list(value)) {
+    stop(
+      "invalid `%<-%` right-hand side, expecting list of values, ",
+      "but found vector",
+      call. = FALSE
+    )
   }
 
   lhs <- variables(ast)

diff --git a/R/destructure.R b/R/destructure.R
@@ -135,12 +135,18 @@ destructure.summary.lm <- function(x) {
 #' @rdname destructure-methods
 #' @export
 destructure.default <- function(x) {
-  stop('cannot de-structure ', class(x), call. = FALSE)
+  stop(
+    "invalid `%<-%` right-hand side, incorrect number of values",
+    call. = FALSE
+  )
 }
 
 assert_destruction <- function(x) {
   if (length(x) > 1) {
-    stop('cannot de-structure ', class(x), ' vector of length greater than 1',
-         call. = FALSE)
+    stop(
+      "invalid `destructure` argument, cannot de-structure ", class(x),
+      " vector of length greater than 1",
+      call. = FALSE
+    )
   }
 }
diff --git a/R/pair-off.R b/R/pair-off.R
@@ -2,16 +2,16 @@ is_collector <- function(x) {
   if (!is.character(x)) {
     return(FALSE)
   }
-  grepl('^\\.\\.\\.', x)
+  grepl("^\\.\\.\\.", x)
 }
 
 has_collector <- function(x) {
   any(vapply(x, is_collector, logical(1)))
 }
 
 collect <- function(names, values) {
-  if (!any(grepl('^\\.\\.\\.', names))) {
-    stop('no collector variable specified', call. = FALSE)
+  if (!any(grepl("^\\.\\.\\.", names))) {
+    stop("no collector variable specified", call. = FALSE)
   }
 
   if (length(names) == length(values)) {
@@ -26,14 +26,22 @@ collect <- function(names, values) {
   c_index <- which(grepl('^\\.\\.\\.', names))
 
   if (length(c_index) != 1) {
-    stop('assignment ambiguity due to multiple collector variables at the same depth',
-         call. = FALSE)
+    stop(
+      "invalid `%<-%` left-hand side, multiple collector variables at the ",
+      "same depth",
+      call. = FALSE
+    )
   }
 
   if (c_index == 1) {
     # ...firsts, a, b
-    post <- rev(seq.int(from = length(values), length.out = length(names) - 1,
-                        by = -1))
+    post <- rev(
+      seq.int(
+        from = length(values),
+        length.out = length(names) - 1,
+        by = -1
+      )
+    )
 
     c(list(values[-post]), values[post])
   } else if (c_index == length(names)) {
@@ -44,16 +52,21 @@ collect <- function(names, values) {
   } else {
     # a, ...mid, b
     pre <- seq.int(1, c_index - 1)
-    post <- rev(seq.int(from = length(values),
-                        length.out = length(names) - length(pre) - 1, by = -1))
+    post <- rev(
+      seq.int(
+        from = length(values),
+        length.out = length(names) - length(pre) - 1,
+        by = -1
+      )
+    )
 
     c(values[pre], list(values[-c(pre, post)]), values[post])
   }
 }
 
 pair_off <- function(names, values) {
   if (is.character(names)) {
-    if (names == '.') {
+    if (names == ".") {
       return()
     }