r-lib · gaborcsardi · May 14, 2019 · Apr 1, 2019 · Apr 1, 2019
diff --git a/R/brackets.R b/R/brackets.R
@@ -0,0 +1,74 @@
+open_brackets <- function() {
+  c("(", "{", "[")
+}
+
+close_brackets <- function(){
+  c(")", "}", "]")
+}
+
+bracket_tokens <- function() {
+  s <- c(open_brackets(), close_brackets())
+  c(paste0("'", s, "'"), "LBB")
+}
+
+apply_color <- function(x, lvl, l){
+  k <- (lvl - 1) %% length(l) + 1
+  l[[k]](x)
+}
+
+#' Colored brackets
+#'
+#' Add color to brackets. Brackets will be coloured consecutively with the
+#' colors provided in \code{color_seq} by scope.
+#'
+#' @param x a character vector of brackets consisting of a valid sequence of any
+#'   of the following: \code{'[[', '[', ']', '(', ')', '{', '}'}
+#' @param color_seq a list of functions that take and return a character scalar. The 
+#' ordering defines the sequence of color functions to apply to a given scope level.
+#' Color functions are recycled when the scope level exceeds the length of \code{color_seq}
+#'
+#' @details Meant for coloring brackets encountered within \code{highlight}.
+#'   Note that occurrences of 'orphan' brackets are not taken into account
+#'   mainly due to the fact that cases such as
+#'
+#'   \code{foo <- function(x){ `[[`(x, 1) }}
+#'
+#'   will either be converted to
+#'
+#'   \code{foo <- function(x){ x[[1]] }}
+#'
+#'   before the brackets are coloured if passed in as
+#'   \code{highlight(deparse(foo))} or will be identified as a
+#'   'SYMBOL_FUNCTION_CALL' token instead of 'LBB' if passed in as
+#'
+#'   \code{highlight("foo <- function(x){ `[[`(x, 1) }")}
+#'
+#'   Similarly, invalid code that would lead to orphaned brackets is not taken
+#'   into account as this would be caught before hand in \code{highlight}.
+#'
+#' @keywords internal
+color_brackets <- function(x, color_seq = list(yellow, blue, cyan)) {
+  stopifnot(vapply(color_seq, is.function, logical(1)))
+  open <- c(open_brackets(), "[[")
+  o <- character() 
+  lvl <- 0 
+  i <- 1
+  while (i <= length(x)) {
+
+    if (x[i] %in% open) {
+      o[length(o) + 1] <- x[i]
+      lvl <- lvl + 1
+      x[i] <- apply_color(x[i], lvl, color_seq)
+      i <- i + 1
+      next
+    } 
+
+    j <- nchar(o[length(o)])
+    x[i:(i + j - 1)] <- 
+      apply_color(x[i:(i + j - 1)], lvl, color_seq)
+    i <- i + j
+    lvl <- lvl - 1
+    o <- o[-length(o)] 
+  }
+  x
+}
diff --git a/R/highlight.R b/R/highlight.R
@@ -12,6 +12,7 @@ reserved_words <- function() {
     "REPEAT", "WHILE", "FOR", "IN", "NEXT", "BREAK")
 }
 
+
 #' Syntax highlight R code
 #'
 #' @param code Character vector, each element is one line of code.
@@ -72,6 +73,12 @@ highlight <- function(code, style = default_style()) {
     comment <- data$token == "COMMENT"
     hitext[comment] <- style$comment(data$text[comment])
   }
+
+  ## Brackets
+  if (!is.null(style$bracket)){
+    bracket <- data$token %in% bracket_tokens()
+    hitext[bracket] <- color_brackets(data$text[bracket], style$bracket)
+  }
 
   do_subst(code, data, hitext)
 }

diff --git a/R/style.R b/R/style.R
@@ -10,10 +10,12 @@
 #' * `call`: function calls
 #' * `string`: character literals
 #' * `comment`: comments
+#' * `bracket`: brackets: \code{(){}[]} 
 #'
 #' Each entry in a list must be a function that takes a character
-#' scalar, and returns a character scalar. The default style adds
-#' ANSI formatting to the code.
+#' scalar, and returns a character scalar with the exception of `bracket`
+#' which should be a list of these type of functions defining a color sequence. 
+#' The default style adds ANSI formatting to the code.
 #'
 #' Note that you can also change the code if you like, e.g. to include
 #' a unicode arrow character instead of the two-character assignment
@@ -33,6 +35,7 @@ default_style <- function() {
     operator = green,
     call     = cyan,
     string   = yellow,
-    comment  = combine_styles(make_style("darkgrey"), italic)
+    comment  = combine_styles(make_style("darkgrey"), italic),
+    bracket  = c(yellow, blue, cyan)
   )
 }
diff --git a/man/color_brackets.Rd b/man/color_brackets.Rd
diff --git a/man/default_style.Rd b/man/default_style.Rd
diff --git a/tests/testthat/test-brackets.R b/tests/testthat/test-brackets.R
@@ -0,0 +1,60 @@
+
+
+context("colour_brackets")
+
+col_seq <- list(function(x)
+  paste0("1", x),
+  function(x)
+    paste0("2", x),
+  function(x)
+    paste0("3", x))
+
+test_that("bracket highlighting", {
+  # [](){}
+  expect_equal(color_brackets(c("[", "]", "(", ")", "{", "}"), col_seq),
+               c("1[", "1]", "1(", "1)", "1{", "1}"))
+
+  # [({[({})]})]
+  expect_equal(
+    color_brackets(c(
+      "[", "(", "{", "[", "(", "{", "}", ")", "]", "}", ")", "]"
+    ),
+    col_seq),
+    c(
+      "1[",
+      "2(",
+      "3{",
+      "1[",
+      "2(",
+      "3{",
+      "3}",
+      "2)",
+      "1]",
+      "3}",
+      "2)",
+      "1]"
+    )
+  )
+
+  # [[ [] ]][[ ()() ]]
+  expect_equal(
+    color_brackets(
+      c("[[", "[", "]", "]", "]", "[[", "(", ")", "(", ")", "]", "]"),
+      col_seq
+    ),
+    c(
+      "1[[",
+      "2[",
+      "2]",
+      "1]",
+      "1]",
+      "1[[",
+      "2(",
+      "2)",
+      "2(",
+      "2)",
+      "1]",
+      "1]"
+    )
+  )
+})
diff --git a/tests/testthat/test-highlight.R b/tests/testthat/test-highlight.R
@@ -103,3 +103,10 @@ test_that("comment", {
     c("C", " ls() C")
   )
 })
+
+test_that("bracket", {
+  expect_equal(
+    highlight("foo <- function(x){x}", list(bracket = list(function(x) "B"))),
+    "foo <- functionBxBBxB"
+  )
+})
diff --git a/tests/testthat/test-style.R b/tests/testthat/test-style.R
@@ -7,7 +7,7 @@ test_that("default_style", {
   expect_true(
     all(
       names(def) %in%
-      c("reserved", "number", "null", "operator", "call", "string", "comment")
+      c("reserved", "number", "null", "operator", "call", "string", "comment", "bracket")
     )
   )
 })