fix code parser for := operator (#234)

Closes #233 and alternative for #233

This removed `:=` from extracted calls so that it is not treated as
`LEFT_ASSIGNMENT`.


**Current main** - check row 26

```r
devtools::load_all(".")
code <- "
iris <- data.table::data.table(iris) %>%
  .[, NewSpecies := factor(Species)]
"

code_split <- split_code(paste(code, collapse = "\n"))[[1]]
current_call <- parse(text = code_split, keep.source = TRUE)
pd <- normalize_pd(utils::getParseData(current_call))
reordered_pd <- extract_calls(pd)
reordered_pd[[1]]


   line1 col1 line2 col2 id parent                token terminal       text
46     2    1     3   36 46      0                 expr    FALSE           
5      2    1     2    4  5     46                 expr    FALSE           
4      2    6     2    7  4     46          LEFT_ASSIGN     TRUE         <-
45     2    9     3   36 45     46                 expr    FALSE           
3      2    1     2    4  3      5               SYMBOL     TRUE       iris
17     2    9     2   36 17     45                 expr    FALSE           
18     2   38     2   40 18     45              SPECIAL     TRUE        %>%
43     3    3     3   36 43     45                 expr    FALSE           
9      2    9     2   30  9     17                 expr    FALSE           
10     2   31     2   31 10     17                  '('     TRUE          (
13     2   32     2   35 13     17                 expr    FALSE           
12     2   36     2   36 12     17                  ')'     TRUE          )
6      2    9     2   18  6      9       SYMBOL_PACKAGE     TRUE data.table
7      2   19     2   20  7      9               NS_GET     TRUE         ::
8      2   21     2   30  8      9 SYMBOL_FUNCTION_CALL     TRUE data.table
11     2   32     2   35 11     13               SYMBOL     TRUE       iris
22     3    3     3    3 22     43                 expr    FALSE           
21     3    4     3    4 21     43                  '['     TRUE          [
23     3    5     3    5 23     43                  ','     TRUE          ,
39     3    7     3   35 39     43                 expr    FALSE           
38     3   36     3   36 38     43                  ']'     TRUE          ]
20     3    3     3    3 20     22               SYMBOL     TRUE          .
27     3    7     3   16 27     39                 expr    FALSE           
26     3   18     3   19 26     39          LEFT_ASSIGN     TRUE         :=
37     3   21     3   35 37     39                 expr    FALSE           
25     3    7     3   16 25     27               SYMBOL     TRUE NewSpecies
30     3   21     3   26 30     37                 expr    FALSE           
29     3   27     3   27 29     37                  '('     TRUE          (
33     3   28     3   34 33     37                 expr    FALSE           
32     3   35     3   35 32     37                  ')'     TRUE          )
28     3   21     3   26 28     30 SYMBOL_FUNCTION_CALL     TRUE     factor
31     3   28     3   34 31     33               SYMBOL     TRUE    Species
```

**Feature branch** - row removed

```r
   line1 col1 line2 col2 id parent                token terminal       text
46     2    1     3   36 46      0                 expr    FALSE           
5      2    1     2    4  5     46                 expr    FALSE           
4      2    6     2    7  4     46          LEFT_ASSIGN     TRUE         <-
45     2    9     3   36 45     46                 expr    FALSE           
3      2    1     2    4  3      5               SYMBOL     TRUE       iris
17     2    9     2   36 17     45                 expr    FALSE           
18     2   38     2   40 18     45              SPECIAL     TRUE        %>%
43     3    3     3   36 43     45                 expr    FALSE           
9      2    9     2   30  9     17                 expr    FALSE           
10     2   31     2   31 10     17                  '('     TRUE          (
13     2   32     2   35 13     17                 expr    FALSE           
12     2   36     2   36 12     17                  ')'     TRUE          )
6      2    9     2   18  6      9       SYMBOL_PACKAGE     TRUE data.table
7      2   19     2   20  7      9               NS_GET     TRUE         ::
8      2   21     2   30  8      9 SYMBOL_FUNCTION_CALL     TRUE data.table
11     2   32     2   35 11     13               SYMBOL     TRUE       iris
22     3    3     3    3 22     43                 expr    FALSE           
21     3    4     3    4 21     43                  '['     TRUE          [
23     3    5     3    5 23     43                  ','     TRUE          ,
39     3    7     3   35 39     43                 expr    FALSE           
38     3   36     3   36 38     43                  ']'     TRUE          ]
20     3    3     3    3 20     22               SYMBOL     TRUE          .
27     3    7     3   16 27     39                 expr    FALSE           
37     3   21     3   35 37     39                 expr    FALSE           
25     3    7     3   16 25     27               SYMBOL     TRUE NewSpecies
30     3   21     3   26 30     37                 expr    FALSE           
29     3   27     3   27 29     37                  '('     TRUE          (
33     3   28     3   34 33     37                 expr    FALSE           
32     3   35     3   35 32     37                  ')'     TRUE          )
28     3   21     3   26 28     30 SYMBOL_FUNCTION_CALL     TRUE     factor
31     3   28     3   34 31     33               SYMBOL     TRUE    Species
```


This lead to the fact that below can be executed without errors

```r
devtools::load_all(".")
code <- "
iris <- data.table::data.table(iris) %>%
  .[, NewSpecies := factor(Species)]
"

q <- eval_code(qenv(), code)
cat(get_code(q))
```

```r

iris <- data.table::data.table(iris) %>%
  .[, NewSpecies := factor(Species)]
```

---------

Signed-off-by: Marcin <[email protected]>
Co-authored-by: André Veríssimo <[email protected]>

Author: m7pr

R/utils-get_code_dependency.R

@@ -106,6 +106,7 @@ extract_calls <- function(pd) {
   calls <- Filter(function(call) !(nrow(call) == 1 && call$token == "';'"), calls)
   calls <- Filter(Negate(is.null), calls)
   calls <- fix_shifted_comments(calls)
+  calls <- remove_custom_assign(calls, c(":="))
   fix_arrows(calls)
 }
 
@@ -144,6 +145,23 @@ fix_shifted_comments <- function(calls) {
   Filter(nrow, calls)
 }
 
+#' Fixes edge case of custom assignments operator being treated as assignment.
+#'
+#' @param exclude (`character`) custom assignment operators to be excluded
+#' @keywords internal
+#' @noRd
+remove_custom_assign <- function(calls, exclude = NULL) {
+  checkmate::assert_list(calls)
+  checkmate::assert_character(exclude, null.ok = TRUE)
+  lapply(calls, function(call) {
+    if (!is.null(exclude)) {
+      call[!(call$token == "LEFT_ASSIGN" & call$text %in% exclude), ]
+    } else {
+      call
+    }
+  })
+}
+
 #' Fixes edge case of `<-` assignment operator being called as function,
 #' which is \code{`<-`(y,x)} instead of traditional `y <- x`.
 #' @keywords internal

tests/testthat/test-qenv_eval_code.R

@@ -105,6 +105,15 @@ testthat::test_that("eval_code accepts calls containing only comments and empty
   testthat::expect_identical(get_code(eval_code(qenv(), code)), code)
 })
 
+testthat::test_that("eval_code does not treat := as an assignment operator", {
+  code <- "
+    x <- 'name'
+    rlang::list2(!!x := 1)
+  "
+  q <- eval_code(qenv(), code)
+  testthat::expect_identical(get_code(q), code)
+})
+
 # comments ----------
 testthat::test_that("comments fall into proper calls", {
   # If comment is on top, it gets moved to the first call.