├── .github ├── .gitignore └── workflows │ ├── pkgdown.yaml │ ├── test-coverage.yaml │ ├── R-CMD-check.yaml │ └── pr-commands.yaml ├── LICENSE ├── .gitignore ├── .Rbuildignore ├── tests ├── testthat │ ├── helper-codegrip.R │ ├── fixtures │ │ └── calls.R │ ├── helper-reshape.R │ ├── test-ast.R │ ├── test-text.R │ ├── helper-ast-call.R │ ├── _snaps │ │ ├── ast-call.md │ │ ├── reshape.md │ │ └── reshape-call.md │ ├── test-reshape.R │ ├── test-reshape-call.R │ ├── test-move.R │ └── test-ast-call.R └── testthat.R ├── NAMESPACE ├── R ├── codegrip-package.R ├── reshape-emacs.R ├── move-emacs.R ├── move-addin.R ├── text.R ├── utils-emacs.R ├── indent.R ├── utils.R ├── reshape-addin.R ├── reshape.R ├── move.R ├── ast-call.R ├── reshape-call.R ├── compat-purrr.R └── ast.R ├── NEWS.md ├── codecov.yml ├── codegrip.Rproj ├── inst ├── rstudio │ └── addins.dcf └── emacs │ └── codegrip.el ├── DESCRIPTION ├── man ├── codegrip-package.Rd ├── addin_reshape.Rd └── figures │ └── README │ ├── move.svg │ ├── reshape-call.svg │ ├── reshape-def.svg │ └── move-reshape.svg ├── LICENSE.md └── README.md /.github/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | YEAR: 2022 2 | COPYRIGHT HOLDER: codegrip authors 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^LICENSE\.md$ 2 | ^.*\.Rproj$ 3 | ^\.Rproj\.user$ 4 | ^codecov\.yml$ 5 | ^\.github$ 6 | -------------------------------------------------------------------------------- /tests/testthat/helper-codegrip.R: -------------------------------------------------------------------------------- 1 | p <- function(text) { 2 | parse_xml_one(parse_info(text = text)) 3 | } 4 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | export(addin_reshape) 4 | import(rlang) 5 | import(xml2, except = as_list) 6 | -------------------------------------------------------------------------------- /R/codegrip-package.R: -------------------------------------------------------------------------------- 1 | #' @keywords internal 2 | #' @import rlang 3 | #' @rawNamespace import(xml2, except = as_list) 4 | "_PACKAGE" 5 | 6 | ## usethis namespace: start 7 | ## usethis namespace: end 8 | NULL 9 | -------------------------------------------------------------------------------- /tests/testthat/fixtures/calls.R: -------------------------------------------------------------------------------- 1 | #' foobar 2 | foo <- function(bar, 3 | baz) { 4 | quux(1, list(2), 3) # foo 5 | (foo)(4, 6 | 5) 7 | } 8 | 9 | 10 | hop( 11 | hip 12 | ) 13 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | # codegrip (development version) 2 | 3 | * The long "flat" form for function definitions now aligns arguments using a 4 | single indent rather than a double indent, which follows the 5 | [tidyverse style guide](https://style.tidyverse.org/functions.html#long-lines-1) 6 | (#20). 7 | -------------------------------------------------------------------------------- /codecov.yml: -------------------------------------------------------------------------------- 1 | comment: false 2 | 3 | coverage: 4 | status: 5 | project: 6 | default: 7 | target: auto 8 | threshold: 1% 9 | informational: true 10 | patch: 11 | default: 12 | target: auto 13 | threshold: 1% 14 | informational: true 15 | -------------------------------------------------------------------------------- /codegrip.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | BuildType: Package 16 | PackageUseDevtools: Yes 17 | PackageInstallArgs: --no-multiarch --with-keep.source 18 | -------------------------------------------------------------------------------- /tests/testthat/helper-reshape.R: -------------------------------------------------------------------------------- 1 | snap_reshape_cycle <- function(n, code, line = 1, col = 1) { 2 | for (i in seq_len(n)) { 3 | info <- parse_info(text = code) 4 | out <- reshape_info(line, col, info = info) 5 | code <- if (length(out$reshaped)) out$reshaped else code 6 | 7 | cat_line( 8 | sprintf("i: %d", i), 9 | code, 10 | "" 11 | ) 12 | } 13 | } 14 | -------------------------------------------------------------------------------- /inst/rstudio/addins.dcf: -------------------------------------------------------------------------------- 1 | Name: Move Outside 2 | Description: Move to containing expression. 3 | Binding: addin_move_outside 4 | Interactive: false 5 | 6 | Name: Move Inside 7 | Description: Move inside expression. 8 | Binding: addin_move_inside 9 | Interactive: false 10 | 11 | Name: Reshape Expression 12 | Description: Reshape expressions longer or wider. 13 | Binding: addin_reshape 14 | Interactive: false 15 | -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | # This file is part of the standard setup for testthat. 2 | # It is recommended that you do not modify it. 3 | # 4 | # Where should you do additional test configuration? 5 | # Learn more about the roles of various files in: 6 | # * https://r-pkgs.org/tests.html 7 | # * https://testthat.r-lib.org/reference/test_package.html#special-files 8 | 9 | library(testthat) 10 | library(codegrip) 11 | 12 | test_check("codegrip") 13 | -------------------------------------------------------------------------------- /R/reshape-emacs.R: -------------------------------------------------------------------------------- 1 | emacs_reshape <- function(...) { 2 | tryCatch( 3 | expr = { 4 | emacs_reshape_unsafe(...) 5 | }, 6 | error = function(cnd) { 7 | FALSE 8 | } 9 | ) 10 | } 11 | 12 | emacs_reshape_unsafe <- function(file, line, col) { 13 | parse_info <- parse_info(file = file) 14 | out <- reshape_info(line, col, info = parse_info) 15 | 16 | writeLines(character(), file) 17 | print_lisp(out, file) 18 | 19 | !is_null(out) 20 | } 21 | -------------------------------------------------------------------------------- /R/move-emacs.R: -------------------------------------------------------------------------------- 1 | emacs_move <- function(cmd, ...) { 2 | action <- switch( 3 | cmd, 4 | "outside" = move_outside_info, 5 | "inside" = move_inside_info, 6 | "next" = move_next_info, 7 | "previous" = move_previous_info, 8 | function(...) FALSE 9 | ) 10 | tryCatch( 11 | emacs_move_unsafe(action, ...), 12 | error = function(cnd) FALSE 13 | ) 14 | } 15 | 16 | emacs_move_unsafe <- function(action_info, file, line, col) { 17 | parse_info <- parse_info(file = file) 18 | out <- action_info(line, col, info = parse_info) 19 | 20 | writeLines(character(), file) 21 | print_lisp(out, file) 22 | 23 | !is_null(out) 24 | } 25 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: codegrip 2 | Title: Syntax-Based Editing and Navigation of R Code 3 | Version: 0.0.0.9000 4 | Authors@R: c( 5 | person("Lionel", "Henry", ,"lionel@posit.co", c("aut", "cre")), 6 | person("Posit PBC", role = c("cph", "fnd")) 7 | ) 8 | Description: Provides addins for reshaping R code and navigating 9 | across syntactic constructs. 10 | License: MIT + file LICENSE 11 | Encoding: UTF-8 12 | Imports: 13 | rlang, 14 | vctrs, 15 | xml2, 16 | xmlparsedata 17 | Suggests: 18 | covr, 19 | rstudioapi, 20 | testthat (>= 3.0.0) 21 | Roxygen: list(markdown = TRUE) 22 | RoxygenNote: 7.3.2 23 | Config/testthat/edition: 3 24 | URL: https://github.com/lionel-/codegrip 25 | BugReports: https://github.com/lionel-/codegrip/issues 26 | -------------------------------------------------------------------------------- /man/codegrip-package.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/codegrip-package.R 3 | \docType{package} 4 | \name{codegrip-package} 5 | \alias{codegrip} 6 | \alias{codegrip-package} 7 | \title{codegrip: Syntax-Based Editing and Navigation of R Code} 8 | \description{ 9 | Provides addins for reshaping R code and navigating across syntactic constructs. 10 | } 11 | \seealso{ 12 | Useful links: 13 | \itemize{ 14 | \item \url{https://github.com/lionel-/codegrip} 15 | \item Report bugs at \url{https://github.com/lionel-/codegrip/issues} 16 | } 17 | 18 | } 19 | \author{ 20 | \strong{Maintainer}: Lionel Henry \email{lionel@posit.co} 21 | 22 | Other contributors: 23 | \itemize{ 24 | \item Posit PBC [copyright holder, funder] 25 | } 26 | 27 | } 28 | \keyword{internal} 29 | -------------------------------------------------------------------------------- /tests/testthat/test-ast.R: -------------------------------------------------------------------------------- 1 | test_that("Can detect indentations", { 2 | info <- parse_info(test_path("fixtures", "calls.R")) 3 | xml <- parse_xml(info) 4 | 5 | calls <- find_function_calls(xml) 6 | 7 | indents <- sapply(calls, function(call) node_indentation(call, info = info)) 8 | expect_equal( 9 | indents, 10 | c(0L, 2L, 2L, 2L, 0L) 11 | ) 12 | }) 13 | 14 | test_that("indent_adjust() works", { 15 | code <- as_lines("{ 16 | a 17 | b 18 | }") 19 | exp <- as_lines(" { 20 | a 21 | b 22 | }") 23 | out <- indent_adjust(code, 2) 24 | expect_equal(out, exp) 25 | expect_equal(indent_adjust(out, -2), code) 26 | 27 | # Newlines in strings are preserved 28 | code <- as_lines("{' 29 | a 30 | b 31 | '}") 32 | exp <- as_lines(" {' 33 | a 34 | b 35 | '}") 36 | out <- indent_adjust(code, 2) 37 | expect_equal(out, exp) 38 | expect_equal(indent_adjust(out, -2), code) 39 | }) 40 | -------------------------------------------------------------------------------- /R/move-addin.R: -------------------------------------------------------------------------------- 1 | addin_move_outside <- function() { 2 | addin_move(move_outside_info) 3 | } 4 | addin_move_inside <- function() { 5 | addin_move(move_inside_info) 6 | } 7 | addin_move_next <- function() { 8 | addin_move(move_next_info) 9 | } 10 | addin_move_previous <- function() { 11 | addin_move(move_previous_info) 12 | } 13 | 14 | addin_move <- function(action) { 15 | tryCatch( 16 | addin_move_unsafe(action), 17 | error = function(...) NULL 18 | ) 19 | } 20 | 21 | addin_move_unsafe <- function(action) { 22 | context <- rstudioapi::getActiveDocumentContext() 23 | lines <- context$contents 24 | sel <- context$selection[[1]]$range 25 | 26 | # No traversal for selections 27 | if (!identical(sel$start, sel$end)) { 28 | return() 29 | } 30 | 31 | line <- sel$start[[1]] 32 | col <- sel$start[[2]] 33 | 34 | parse_info <- parse_info(lines = lines) 35 | out <- action(line, col, info = parse_info) 36 | 37 | if (!is_null(out)) { 38 | pos <- rstudioapi::document_position(out[["line"]], out[["col"]]) 39 | rstudioapi::setCursorPosition(pos) 40 | } 41 | } 42 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | # MIT License 2 | 3 | Copyright (c) 2022 codegrip authors 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /R/text.R: -------------------------------------------------------------------------------- 1 | rx_spaces <- "[[:space:]]" 2 | rx_not_spaces <- "[^[:space:]]" 3 | 4 | skip_space <- function(lines, line, col, ...) { 5 | line_text <- lines[[line]] 6 | if (!line_is_at_whitespace(line_text, col)) { 7 | return(c(line = line, col = col)) 8 | } 9 | 10 | n <- nchar(line_text) 11 | line_text <- substr(line_text, col, n) 12 | trimmed_n <- n - nchar(line_text) 13 | 14 | not_space_loc <- regexpr(rx_not_spaces, line_text) 15 | if (not_space_loc > 0) { 16 | return(c(line = line, col = not_space_loc + trimmed_n)) 17 | } 18 | 19 | for (i in seq2(line + 1L, length(lines))) { 20 | line_text <- lines[[i]] 21 | 22 | not_space_loc <- regexpr(rx_not_spaces, line_text) 23 | if (not_space_loc > 0) { 24 | return(c(line = i, col = not_space_loc)) 25 | } 26 | } 27 | 28 | # In case an empty `for` loop didn't initialise `i` 29 | i <- i %||% line 30 | 31 | c(line = i, col = nchar(lines[[i]])) 32 | } 33 | 34 | line_is_at_whitespace <- function(line, col) { 35 | at_end <- col == nchar(line) + 1 36 | at_end || grepl(rx_spaces, substr(line, col, col)) 37 | } 38 | 39 | chr_suffix <- function(x, start) { 40 | substr(x, start, nchar(x)) 41 | } 42 | -------------------------------------------------------------------------------- /man/addin_reshape.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/reshape-addin.R 3 | \name{addin_reshape} 4 | \alias{addin_reshape} 5 | \title{Reshape expressions longer or wider} 6 | \usage{ 7 | addin_reshape() 8 | } 9 | \description{ 10 | \code{addin_reshape()} lets you cycle between different shapes of 11 | function calls. For instance, reshaping transforms code from wide to long 12 | shape and vice versa: 13 | 14 | \if{html}{\out{
}}\preformatted{list(a, b, c) 15 | 16 | list( 17 | a, 18 | b, 19 | c 20 | ) 21 | }\if{html}{\out{
}} 22 | 23 | Note that for function definitions, \code{addin_reshape()} cycles through two 24 | different long shapes. The traditional L form uses more horizontal space 25 | whereas the flat form uses less horizontal space and the arguments are 26 | always aligned at single indent: 27 | 28 | \if{html}{\out{
}}\preformatted{foo <- function(a, b, c) \{ 29 | NULL 30 | \} 31 | 32 | foo <- function(a, 33 | b, 34 | c) \{ 35 | NULL 36 | \} 37 | 38 | foo <- function( 39 | a, 40 | b, 41 | c 42 | ) \{ 43 | NULL 44 | \} 45 | }\if{html}{\out{
}} 46 | } 47 | -------------------------------------------------------------------------------- /R/utils-emacs.R: -------------------------------------------------------------------------------- 1 | # Bare bones printer for limited use cases 2 | print_lisp <- function(x, file = stdout(), last = FALSE) { 3 | cat <- function(...) { 4 | base::cat(..., file = file, append = TRUE) 5 | NULL 6 | } 7 | 8 | finish <- function(x = NULL) { 9 | if (!is_null(x)) { 10 | cat(x) 11 | } 12 | if (!last) { 13 | cat("\n") 14 | } 15 | 16 | invisible(NULL) 17 | } 18 | 19 | supported <- c( 20 | "list", 21 | "character", 22 | "logical", 23 | "integer", 24 | "double", 25 | "NULL" 26 | ) 27 | 28 | type <- typeof(x) 29 | if (!type %in% supported) { 30 | abort(sprintf("Unimplemented type %s.", type), .internal = TRUE) 31 | } 32 | 33 | switch( 34 | type, 35 | NULL = return(finish("nil")) 36 | ) 37 | 38 | cat("(") 39 | 40 | nms <- names(x) 41 | n <- length(x) 42 | 43 | for (i in seq_len(n)) { 44 | if (!is_null(nms)) { 45 | cat(paste0(":", nms[[i]], " ")) 46 | } 47 | 48 | switch( 49 | type, 50 | list = print_lisp(x[[i]], file, last = i == n), 51 | character = cat(encodeString(x[[i]], quote = "\"")), 52 | logical = , 53 | integer = , 54 | double = cat(x[[i]]) 55 | ) 56 | 57 | if (i < n) { 58 | cat(" ") 59 | } 60 | } 61 | 62 | finish(")") 63 | } 64 | -------------------------------------------------------------------------------- /.github/workflows/pkgdown.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, master] 6 | pull_request: 7 | branches: [main, master] 8 | release: 9 | types: [published] 10 | workflow_dispatch: 11 | 12 | name: pkgdown 13 | 14 | jobs: 15 | pkgdown: 16 | runs-on: ubuntu-latest 17 | # Only restrict concurrency for non-PR jobs 18 | concurrency: 19 | group: pkgdown-${{ github.event_name != 'pull_request' || github.run_id }} 20 | env: 21 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 22 | steps: 23 | - uses: actions/checkout@v3 24 | 25 | - uses: r-lib/actions/setup-pandoc@v2 26 | 27 | - uses: r-lib/actions/setup-r@v2 28 | with: 29 | use-public-rspm: true 30 | 31 | - uses: r-lib/actions/setup-r-dependencies@v2 32 | with: 33 | extra-packages: any::pkgdown, local::. 34 | needs: website 35 | 36 | - name: Build site 37 | run: pkgdown::build_site_github_pages(new_process = FALSE, install = FALSE) 38 | shell: Rscript {0} 39 | 40 | - name: Deploy to GitHub pages 🚀 41 | if: github.event_name != 'pull_request' 42 | uses: JamesIves/github-pages-deploy-action@v4.4.1 43 | with: 44 | clean: false 45 | branch: gh-pages 46 | folder: docs 47 | -------------------------------------------------------------------------------- /tests/testthat/test-text.R: -------------------------------------------------------------------------------- 1 | test_that("can skip whitespace", { 2 | lines <- "foo" 3 | expect_equal( 4 | skip_space(lines, 1, 1), 5 | c(line = 1, col = 1) 6 | ) 7 | expect_equal( 8 | skip_space(lines, 1, 3), 9 | c(line = 1, col = 3) 10 | ) 11 | 12 | lines <- " foo bar" 13 | expect_equal( 14 | skip_space(lines, 1, 1), 15 | c(line = 1, col = 3) 16 | ) 17 | expect_equal( 18 | skip_space(lines, 1, 6), 19 | c(line = 1, col = 8) 20 | ) 21 | expect_equal( 22 | skip_space(lines, 1, 8), 23 | c(line = 1, col = 8) 24 | ) 25 | 26 | lines <- c("foo", " bar") 27 | expect_equal( 28 | skip_space(lines, 2, 1), 29 | c(line = 2, col = 3) 30 | ) 31 | expect_equal( 32 | skip_space(lines, 2, 3), 33 | c(line = 2, col = 3) 34 | ) 35 | 36 | lines <- c("foo ", "", "bar") 37 | expect_equal( 38 | skip_space(lines, 1, 4), 39 | c(line = 3, col = 1) 40 | ) 41 | expect_equal( 42 | skip_space(lines, 2, 1), 43 | c(line = 3, col = 1) 44 | ) 45 | 46 | # NOTE: Is this correct? 47 | lines <- "" 48 | expect_equal( 49 | skip_space(lines, 1, 1), 50 | c(line = 1, col = 0) 51 | ) 52 | 53 | lines <- " " 54 | expect_equal( 55 | skip_space(lines, 1, 1), 56 | c(line = 1, col = 2) 57 | ) 58 | expect_equal( 59 | skip_space(lines, 1, 2), 60 | c(line = 1, col = 2) 61 | ) 62 | 63 | # NOTE: Should this be `col = 2`? 64 | lines <- c(" ", " ") 65 | expect_equal( 66 | skip_space(lines, 1, 1), 67 | c(line = 2, col = 1) 68 | ) 69 | }) 70 | -------------------------------------------------------------------------------- /.github/workflows/test-coverage.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, master] 6 | pull_request: 7 | branches: [main, master] 8 | 9 | name: test-coverage 10 | 11 | jobs: 12 | test-coverage: 13 | runs-on: ubuntu-latest 14 | env: 15 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 16 | 17 | steps: 18 | - uses: actions/checkout@v3 19 | 20 | - uses: r-lib/actions/setup-r@v2 21 | with: 22 | use-public-rspm: true 23 | 24 | - uses: r-lib/actions/setup-r-dependencies@v2 25 | with: 26 | extra-packages: any::covr 27 | needs: coverage 28 | 29 | - name: Test coverage 30 | run: | 31 | covr::codecov( 32 | quiet = FALSE, 33 | clean = FALSE, 34 | install_path = file.path(Sys.getenv("RUNNER_TEMP"), "package") 35 | ) 36 | shell: Rscript {0} 37 | 38 | - name: Show testthat output 39 | if: always() 40 | run: | 41 | ## -------------------------------------------------------------------- 42 | find ${{ runner.temp }}/package -name 'testthat.Rout*' -exec cat '{}' \; || true 43 | shell: bash 44 | 45 | - name: Upload test results 46 | if: failure() 47 | uses: actions/upload-artifact@v3 48 | with: 49 | name: coverage-test-failures 50 | path: ${{ runner.temp }}/package 51 | -------------------------------------------------------------------------------- /R/indent.R: -------------------------------------------------------------------------------- 1 | node_indentation <- function(node, ..., info) { 2 | check_dots_empty() 3 | check_node(node) 4 | 5 | line <- xml_line1(node) 6 | line_text <- lines(info)[[line]] 7 | 8 | line_indentation(line_text) 9 | } 10 | 11 | line_indentation <- function(line) { 12 | line <- replace_tabs(line) 13 | indent <- regexpr("[^[:space:]]", line) - 1L 14 | max(indent, 0L) 15 | } 16 | 17 | indent_adjust <- function(lines, indent, skip = -1) { 18 | if (!length(lines)) { 19 | return(lines) 20 | } 21 | 22 | data <- parse_xml(parse_info(lines = lines)) 23 | nodes <- xml_find_all(data, "//*") 24 | 25 | for (i in seq_along(lines)) { 26 | if (i == skip) { 27 | next 28 | } 29 | 30 | line <- replace_tabs(lines[[i]]) 31 | 32 | # Don't indent empty lines with parasite whitespace 33 | if (!nzchar(line)) { 34 | next 35 | } 36 | 37 | col <- regexpr("[^[:space:]]", line) 38 | col <- if (col < 0) 1L else col 39 | 40 | # Find the AST node to which the new line belongs 41 | loc <- locate_node(nodes, i, col, data = data) 42 | if (!loc) { 43 | abort("Expected a node in `indent_adjust()`.", .internal = TRUE) 44 | } 45 | node <- nodes[[loc]] 46 | 47 | # Do not adjust indentation of lines inside strings 48 | if (xml_name(node) == "STR_CONST" && 49 | (col != xml_col1(node) || 50 | i != xml_line1(node))) { 51 | next 52 | } 53 | 54 | new_indent_n <- max(line_indentation(line) + indent, 0) 55 | lines[[i]] <- line_reindent(line, new_indent_n) 56 | } 57 | 58 | lines 59 | } 60 | -------------------------------------------------------------------------------- /R/utils.R: -------------------------------------------------------------------------------- 1 | check_rstudio <- function(call = caller_env()) { 2 | if (!is_rstudio()) { 3 | abort("Can't use this feature outside RStudio.", call = call) 4 | } 5 | } 6 | 7 | is_rstudio <- function() { 8 | identical(.Platform$GUI, "RStudio") 9 | } 10 | 11 | cat_line <- function(...) { 12 | cat(paste0(chr(...), "\n", collapse = "")) 13 | } 14 | 15 | lines <- function(info, call = caller_env()) { 16 | if (!is_null(info$lines)) { 17 | info$lines 18 | } else if (nzchar(info$file)) { 19 | readLines(info$file) 20 | } else { 21 | abort("Must supply either `text` or `file`.", call = call) 22 | } 23 | } 24 | 25 | as_lines <- function(text) { 26 | strsplit(text, "\n")[[1]] 27 | } 28 | 29 | split_sep <- function(xs, is_sep) { 30 | stopifnot( 31 | is_logical(is_sep) 32 | ) 33 | 34 | n <- sum(is_sep) + 1L 35 | out <- rep(list(xs[0]), n) 36 | 37 | j <- 1L 38 | locs <- integer() 39 | 40 | for (i in seq_along(xs)) { 41 | if (is_sep[[i]]) { 42 | out[[j]] <- xs[locs] 43 | locs <- integer() 44 | j <- j + 1L 45 | } else { 46 | locs <- c(locs, i) 47 | } 48 | } 49 | out[[j]] <- xs[locs] 50 | 51 | out 52 | } 53 | 54 | str_replace <- function(text, start, stop = nchar(text), value = "") { 55 | paste0( 56 | substr(text, 1, start - 1L), 57 | value, 58 | substr(text, stop + 1L, nchar(text)) 59 | ) 60 | } 61 | 62 | line_reindent <- function(line, n) { 63 | sub("^[[:space:]]*", spaces(n), line) 64 | } 65 | 66 | spaces <- function(n) { 67 | strrep(" ", n) 68 | } 69 | 70 | replace_tabs <- function(text) { 71 | # FIXME: Hardcoded indent level 72 | base_indent <- 2 73 | 74 | gsub("\t", strrep(" ", base_indent), text) 75 | } 76 | -------------------------------------------------------------------------------- /tests/testthat/helper-ast-call.R: -------------------------------------------------------------------------------- 1 | print_longer <- function(text, ..., orig = FALSE) { 2 | call <- sub_call_shape(text) 3 | def <- sub_def_shape(text) 4 | 5 | indent <- regexpr("[^[:space:]]", text) - 1 6 | indent <- strrep(" ", indent) 7 | 8 | cat_line( 9 | if (orig) cat_line(c(call, "")), 10 | paste0(indent, as_longer(call, ...)), 11 | "", 12 | paste0(indent, as_longer(def, ...)) 13 | ) 14 | } 15 | print_longer_l <- function(text, ...) { 16 | print_longer(text, L = TRUE, ...) 17 | } 18 | as_longer <- function(text, ...) { 19 | info <- parse_info(text = text) 20 | node_call_longer( 21 | parse_xml_one(info), 22 | info = info, 23 | ... 24 | ) 25 | } 26 | 27 | print_wider <- function(text, ...) { 28 | call <- sub_call_shape(text) 29 | def <- sub_def_shape(text) 30 | 31 | indent <- regexpr("[^[:space:]]", text) - 1 32 | indent <- strrep(" ", indent) 33 | 34 | cat_line( 35 | paste0(indent, as_wider(call, ...)), 36 | "", 37 | paste0(indent, as_wider(def, ...)) 38 | ) 39 | } 40 | as_wider <- function(text, ...) { 41 | info <- parse_info(text = text) 42 | node_call_wider( 43 | parse_xml_one(info), 44 | info = info, 45 | ... 46 | ) 47 | } 48 | 49 | expect_call_shape <- function(text, type) { 50 | call <- sub_call_shape(text) 51 | expect_equal( 52 | node_call_shape(p(call)), 53 | type 54 | ) 55 | 56 | def <- sub_def_shape(text) 57 | expect_equal( 58 | node_call_shape(p(def)), 59 | type 60 | ) 61 | } 62 | 63 | sub_call_shape <- function(text) { 64 | sub("\\(", "foofybaz\\(", text) 65 | } 66 | sub_def_shape <- function(text) { 67 | def <- sub("\\(", "function\\(", text) 68 | sub("\\)[[:space:]]*$", "\\) NULL", def) 69 | } 70 | -------------------------------------------------------------------------------- /R/reshape-addin.R: -------------------------------------------------------------------------------- 1 | #' Reshape expressions longer or wider 2 | #' 3 | #' @description `addin_reshape()` lets you cycle between different shapes of 4 | #' function calls. For instance, reshaping transforms code from wide to long 5 | #' shape and vice versa: 6 | #' ``` 7 | #' list(a, b, c) 8 | #' 9 | #' list( 10 | #' a, 11 | #' b, 12 | #' c 13 | #' ) 14 | #' ``` 15 | #' Note that for function definitions, `addin_reshape()` cycles through two 16 | #' different long shapes. The traditional L form uses more horizontal space 17 | #' whereas the flat form uses less horizontal space and the arguments are 18 | #' always aligned at single indent: 19 | #' ``` 20 | #' foo <- function(a, b, c) { 21 | #' NULL 22 | #' } 23 | #' 24 | #' foo <- function(a, 25 | #' b, 26 | #' c) { 27 | #' NULL 28 | #' } 29 | #' 30 | #' foo <- function( 31 | #' a, 32 | #' b, 33 | #' c 34 | #' ) { 35 | #' NULL 36 | #' } 37 | #' ``` 38 | #' @export 39 | addin_reshape <- function() { 40 | tryCatch( 41 | addin_reshape_unsafe(), 42 | error = function(...) NULL 43 | ) 44 | } 45 | 46 | addin_reshape_unsafe <- function() { 47 | context <- rstudioapi::getActiveDocumentContext() 48 | lines <- context$contents 49 | sel <- context$selection[[1]]$range 50 | 51 | # No reshaping for selections 52 | if (!identical(sel$start, sel$end)) { 53 | return() 54 | } 55 | 56 | line <- sel$start[[1]] 57 | col <- sel$start[[2]] 58 | 59 | parse_info <- parse_info(lines = lines) 60 | out <- reshape_info(line, col, info = parse_info) 61 | 62 | pos1 <- rstudioapi::document_position(out$start[["line"]], out$start[["col"]]) 63 | pos2 <- rstudioapi::document_position(out$end[["line"]], out$end[["col"]]) 64 | range <- rstudioapi::document_range(pos1, pos2) 65 | 66 | rstudioapi::modifyRange(range, out$reshaped) 67 | rstudioapi::setCursorPosition(sel) 68 | } 69 | -------------------------------------------------------------------------------- /.github/workflows/R-CMD-check.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | # 4 | # NOTE: This workflow is overkill for most R packages and 5 | # check-standard.yaml is likely a better choice. 6 | # usethis::use_github_action("check-standard") will install it. 7 | on: 8 | push: 9 | branches: [main, master] 10 | pull_request: 11 | branches: [main, master] 12 | 13 | name: R-CMD-check 14 | 15 | jobs: 16 | R-CMD-check: 17 | runs-on: ${{ matrix.config.os }} 18 | 19 | name: ${{ matrix.config.os }} (${{ matrix.config.r }}) 20 | 21 | strategy: 22 | fail-fast: false 23 | matrix: 24 | config: 25 | - {os: macos-latest, r: 'release'} 26 | 27 | - {os: windows-latest, r: 'release'} 28 | # Use 3.6 to trigger usage of RTools35 29 | - {os: windows-latest, r: '3.6'} 30 | # use 4.1 to check with rtools40's older compiler 31 | - {os: windows-latest, r: '4.1'} 32 | 33 | - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} 34 | - {os: ubuntu-latest, r: 'release'} 35 | - {os: ubuntu-latest, r: 'oldrel-1'} 36 | - {os: ubuntu-latest, r: 'oldrel-2'} 37 | - {os: ubuntu-latest, r: 'oldrel-3'} 38 | - {os: ubuntu-latest, r: 'oldrel-4'} 39 | 40 | env: 41 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 42 | R_KEEP_PKG_SOURCE: yes 43 | 44 | steps: 45 | - uses: actions/checkout@v3 46 | 47 | - uses: r-lib/actions/setup-pandoc@v2 48 | 49 | - uses: r-lib/actions/setup-r@v2 50 | with: 51 | r-version: ${{ matrix.config.r }} 52 | http-user-agent: ${{ matrix.config.http-user-agent }} 53 | use-public-rspm: true 54 | 55 | - uses: r-lib/actions/setup-r-dependencies@v2 56 | with: 57 | extra-packages: any::rcmdcheck 58 | needs: check 59 | 60 | - uses: r-lib/actions/check-r-package@v2 61 | with: 62 | upload-snapshots: true 63 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/ast-call.md: -------------------------------------------------------------------------------- 1 | # can find function call node for position 2 | 3 | Code 4 | # Node locations of function calls for all combinations of line and col 5 | call_nodes 6 | Output 7 | [[1]] 8 | [1] 0 0 0 0 0 0 0 0 0 9 | 10 | [[2]] 11 | [1] 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 12 | 13 | [[3]] 14 | [1] 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 15 | 16 | [[4]] 17 | [1] 1 1 2 2 2 2 2 2 2 2 3 3 3 3 3 3 3 2 2 2 2 1 1 1 1 1 1 18 | 19 | [[5]] 20 | [1] 1 1 4 4 4 4 4 4 4 4 21 | 22 | [[6]] 23 | [1] 4 4 4 4 24 | 25 | [[7]] 26 | [1] 1 1 1 27 | 28 | [[8]] 29 | integer(0) 30 | 31 | [[9]] 32 | integer(0) 33 | 34 | [[10]] 35 | [1] 5 5 5 5 36 | 37 | [[11]] 38 | [1] 5 5 5 5 5 39 | 40 | [[12]] 41 | [1] 5 42 | 43 | 44 | --- 45 | 46 | Code 47 | # Positions of function call at 4:4 48 | node_positions(node)[1:4] 49 | Output 50 | line1 col1 line2 col2 51 | 1 4 3 4 21 52 | 53 | # can retrieve function call text 54 | 55 | Code 56 | # Cursor on `function` 57 | node <- find_function_call(2, 13, data = xml) 58 | cat_line(node_text(node, info = info)) 59 | Output 60 | function(bar, 61 | baz) { 62 | quux(1, list(2), 3) # foo 63 | (foo)(4, 64 | 5) 65 | } 66 | Code 67 | # Cursor on `quux` 68 | node <- find_function_call(4, 4, data = xml) 69 | cat_line(node_text(node, info = info)) 70 | Output 71 | quux(1, list(2), 3) 72 | Code 73 | # Cursor on complex call 74 | node <- find_function_call(5, 3, data = xml) 75 | cat_line(node_text(node, info = info)) 76 | Output 77 | (foo)(4, 78 | 5) 79 | Code 80 | # Cursor on `hop` 81 | node <- find_function_call(11, 1, data = xml) 82 | cat_line(node_text(node, info = info)) 83 | Output 84 | hop( 85 | hip 86 | ) 87 | 88 | # check_call() detects calls 89 | 90 | Code 91 | (expect_error(fn(expr))) 92 | Output 93 | 94 | Error in `fn()`: 95 | ! `x` must be a function call node. 96 | 97 | -------------------------------------------------------------------------------- /.github/workflows/pr-commands.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | issue_comment: 5 | types: [created] 6 | 7 | name: Commands 8 | 9 | jobs: 10 | document: 11 | if: ${{ github.event.issue.pull_request && (github.event.comment.author_association == 'MEMBER' || github.event.comment.author_association == 'OWNER') && startsWith(github.event.comment.body, '/document') }} 12 | name: document 13 | runs-on: ubuntu-latest 14 | env: 15 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 16 | steps: 17 | - uses: actions/checkout@v3 18 | 19 | - uses: r-lib/actions/pr-fetch@v2 20 | with: 21 | repo-token: ${{ secrets.GITHUB_TOKEN }} 22 | 23 | - uses: r-lib/actions/setup-r@v2 24 | with: 25 | use-public-rspm: true 26 | 27 | - uses: r-lib/actions/setup-r-dependencies@v2 28 | with: 29 | extra-packages: any::roxygen2 30 | needs: pr-document 31 | 32 | - name: Document 33 | run: roxygen2::roxygenise() 34 | shell: Rscript {0} 35 | 36 | - name: commit 37 | run: | 38 | git config --local user.name "$GITHUB_ACTOR" 39 | git config --local user.email "$GITHUB_ACTOR@users.noreply.github.com" 40 | git add man/\* NAMESPACE 41 | git commit -m 'Document' 42 | 43 | - uses: r-lib/actions/pr-push@v2 44 | with: 45 | repo-token: ${{ secrets.GITHUB_TOKEN }} 46 | 47 | style: 48 | if: ${{ github.event.issue.pull_request && (github.event.comment.author_association == 'MEMBER' || github.event.comment.author_association == 'OWNER') && startsWith(github.event.comment.body, '/style') }} 49 | name: style 50 | runs-on: ubuntu-latest 51 | env: 52 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 53 | steps: 54 | - uses: actions/checkout@v3 55 | 56 | - uses: r-lib/actions/pr-fetch@v2 57 | with: 58 | repo-token: ${{ secrets.GITHUB_TOKEN }} 59 | 60 | - uses: r-lib/actions/setup-r@v2 61 | 62 | - name: Install dependencies 63 | run: install.packages("styler") 64 | shell: Rscript {0} 65 | 66 | - name: Style 67 | run: styler::style_pkg() 68 | shell: Rscript {0} 69 | 70 | - name: commit 71 | run: | 72 | git config --local user.name "$GITHUB_ACTOR" 73 | git config --local user.email "$GITHUB_ACTOR@users.noreply.github.com" 74 | git add \*.R 75 | git commit -m 'Style' 76 | 77 | - uses: r-lib/actions/pr-push@v2 78 | with: 79 | repo-token: ${{ secrets.GITHUB_TOKEN }} 80 | -------------------------------------------------------------------------------- /R/reshape.R: -------------------------------------------------------------------------------- 1 | find_reshape_node <- function(node, line, col) { 2 | pos <- df_pos(line, col) 3 | 4 | while (!is.na(node)) { 5 | set <- xml_children(node) 6 | 7 | can_reshape <- can_reshape(set) 8 | if (any(can_reshape)) { 9 | first_loc <- which(can_reshape)[[1]] 10 | first <- set[[first_loc]] 11 | first_pos <- as_df_pos(first) 12 | 13 | if (vctrs::vec_compare(pos, first_pos) >= 0) { 14 | return(first) 15 | } 16 | } 17 | 18 | node <- node_parent(node) 19 | } 20 | 21 | node 22 | } 23 | 24 | can_reshape <- function(data) { 25 | is_delim_open(data) 26 | } 27 | 28 | reshape_info <- function(line, col, ..., info, to = NULL) { 29 | info <- parse_info_complete(info) 30 | call <- find_function_call(line, col, data = info$xml) 31 | if (is_null(call)) { 32 | return() 33 | } 34 | 35 | if (is_null(to)) { 36 | if (node_call_type(call) == "prefix") { 37 | to <- switch( 38 | node_call_shape(call), 39 | wide = if (length(node_call_arguments(call)) == 1) { 40 | "long" 41 | } else { 42 | "L" 43 | }, 44 | L = "long", 45 | long = "wide", 46 | "none" 47 | ) 48 | } else { 49 | to <- switch( 50 | node_call_shape(call), 51 | wide = "long", 52 | L = , 53 | long = "wide", 54 | "none" 55 | ) 56 | } 57 | } 58 | 59 | reshaped <- switch( 60 | to, 61 | long = node_call_longer(call, info = info), 62 | L = node_call_longer(call, info = info, L = TRUE), 63 | wide = node_call_wider(call, info = info), 64 | none = node_text(call), 65 | abort("Unexpected value for `to`.", .internal = TRUE) 66 | ) 67 | 68 | pos <- node_positions(call) 69 | 70 | list( 71 | reshaped = reshaped, 72 | start = c(line = pos$line1, col = pos$col1), 73 | end = c(line = pos$line2, col = pos$col2 + 1L) 74 | ) 75 | } 76 | 77 | reshape <- function(line, col, ..., info, to = NULL) { 78 | out <- reshape_info(line, col, info = info, to = to) 79 | lines <- lines(info) 80 | 81 | start_line <- out$start[["line"]] 82 | start_col <- out$start[["col"]] 83 | end_line <- out$end[["line"]] 84 | end_col <- out$end[["col"]] 85 | 86 | if (start_line == end_line) { 87 | lines[[start_line]] <- str_replace( 88 | lines[[start_line]], 89 | start_col, 90 | end_col - 1L, 91 | value = out$reshaped 92 | ) 93 | } else { 94 | tail <- str_replace(lines[[end_line]], 1, end_col - 1L) 95 | head <- str_replace(lines[[start_line]], start_col, value = out$reshaped) 96 | lines[[start_line]] <- paste0(head, tail) 97 | lines <- lines[-end_line] 98 | } 99 | 100 | deleted <- seq2(start_line + 1L, end_line - 1L) 101 | if (length(deleted)) { 102 | lines <- lines[-deleted] 103 | } 104 | 105 | paste0(lines, collapse = "\n") 106 | } 107 | -------------------------------------------------------------------------------- /man/figures/README/move.svg: -------------------------------------------------------------------------------- 1 | list(a=1,b=c(2,3)) -------------------------------------------------------------------------------- /R/move.R: -------------------------------------------------------------------------------- 1 | move_outside_info <- function(line, col, ..., info) { 2 | xml <- parse_xml(info) 3 | 4 | node <- node_at_position(line, col, data = xml) 5 | if (is_null(node)) { 6 | return(NULL) 7 | } 8 | 9 | # Make sure we progress outwards 10 | col <- col - 1L 11 | 12 | node <- find_reshape_node(node, line, col) 13 | node <- node_non_terminal_parent(node) 14 | 15 | if (is.na(node)) { 16 | NULL 17 | } else { 18 | c( 19 | line = xml_line1(node), 20 | col = xml_col1(node) 21 | ) 22 | } 23 | } 24 | 25 | node_extents <- function(node) { 26 | data.frame( 27 | start = xml_start(node), 28 | end = xml_end(node) 29 | ) 30 | } 31 | 32 | move_inside_info <- function(line, col, ..., info) { 33 | xml <- parse_xml(info) 34 | 35 | pos <- skip_space(lines(info), line, col) 36 | line <- pos[["line"]] 37 | col <- pos[["col"]] 38 | 39 | node <- node_at_position(line, col, data = xml) 40 | if (is_null(node)) { 41 | return(NULL) 42 | } 43 | 44 | in_order <- keep(tree_suffix(node), is_terminal) 45 | 46 | # Don't step beyond closing delimiters 47 | is_close <- which(is_delim_close(in_order)) 48 | if (length(is_close)) { 49 | in_order <- in_order[seq(1, is_close[[1]])] 50 | } 51 | 52 | can_step_in <- which(can_step_in(in_order)) 53 | if (!length(can_step_in)) { 54 | return(NULL) 55 | } 56 | 57 | inside_node <- in_order[[can_step_in[[1]] + 1L]] 58 | inside_line <- xml_line1(inside_node) 59 | inside_col <- xml_col1(inside_node) 60 | 61 | if (line == inside_line && col == inside_col) { 62 | return(NULL) 63 | } 64 | 65 | c( 66 | line = inside_line, 67 | col = inside_col 68 | ) 69 | } 70 | 71 | can_step_in <- function(data) { 72 | is_delim_open(data) 73 | } 74 | 75 | move_next_info <- function(line, col, ..., info) { 76 | xml <- parse_xml(info) 77 | 78 | current_node <- node_at_position(line, col, data = xml) 79 | if (is_null(current_node)) { 80 | return(NULL) 81 | } 82 | 83 | in_order <- keep(tree_suffix(current_node), is_terminal) 84 | 85 | if (can_reshape(current_node)) { 86 | in_order <- in_order[-1] 87 | } 88 | 89 | can_reshape <- which(can_reshape(in_order)) 90 | if (!length(can_reshape)) { 91 | return(NULL) 92 | } 93 | 94 | out <- in_order[[can_reshape[[1]]]] 95 | c( 96 | line = xml_line1(out), 97 | col = xml_col1(out) 98 | ) 99 | } 100 | 101 | move_previous_info <- function(line, col, ..., info) { 102 | xml <- parse_xml(info) 103 | 104 | current_node <- node_at_position(line, col, data = xml) 105 | if (is_null(current_node)) { 106 | return(NULL) 107 | } 108 | 109 | in_order <- rev(keep(tree_prefix(current_node), is_terminal)) 110 | 111 | if (can_reshape(current_node)) { 112 | in_order <- in_order[-1] 113 | } 114 | 115 | can_reshape <- which(can_reshape(in_order)) 116 | if (!length(can_reshape)) { 117 | return(NULL) 118 | } 119 | 120 | out <- in_order[[can_reshape[[1]]]] 121 | c( 122 | line = xml_line1(out), 123 | col = xml_col1(out) 124 | ) 125 | } 126 | -------------------------------------------------------------------------------- /tests/testthat/test-reshape.R: -------------------------------------------------------------------------------- 1 | test_that("reshape() cycles function calls and definitions", { 2 | expect_snapshot({ 3 | code <- "foofybaz()" 4 | snap_reshape_cycle(2, code) 5 | 6 | code <- "foofybaz(a)" 7 | snap_reshape_cycle(3, code) 8 | 9 | code <- "foofybaz(a, b = 1, c)" 10 | snap_reshape_cycle(3, code) 11 | 12 | 13 | code <- "function() NULL" 14 | snap_reshape_cycle(2, code) 15 | 16 | code <- "function(a) NULL" 17 | snap_reshape_cycle(3, code) 18 | 19 | code <- "function(a, b = 1, c) NULL" 20 | snap_reshape_cycle(4, code) 21 | }) 22 | }) 23 | 24 | # Might change in the future 25 | test_that("reshape() cycles other call-like constructs", { 26 | expect_snapshot({ 27 | code <- "if (a) NULL" 28 | snap_reshape_cycle(2, code) 29 | 30 | code <- "if (a) b else c" 31 | snap_reshape_cycle(2, code) 32 | 33 | code <- "while (a) NULL" 34 | snap_reshape_cycle(2, code) 35 | 36 | code <- "for (i in x) NULL" 37 | snap_reshape_cycle(1, code) 38 | }) 39 | }) 40 | 41 | test_that("can reshape braced expressions", { 42 | expect_snapshot({ 43 | code <- 44 | "expect_snapshot({ 45 | a 46 | b 47 | })" 48 | snap_reshape_cycle(2, code) 49 | 50 | code <- 51 | "{ 52 | expect_snapshot({ 53 | a 54 | b 55 | }) 56 | }" 57 | snap_reshape_cycle(2, code, line = 2, col = 3) 58 | 59 | code <- 60 | "test_that('desc', { 61 | a 62 | b 63 | })" 64 | snap_reshape_cycle(3, code) 65 | 66 | code <- 67 | "test_that({ 68 | a 69 | b 70 | }, desc = 'desc')" 71 | snap_reshape_cycle(3, code) 72 | }) 73 | }) 74 | 75 | test_that("can reshape with multiple braced expressions", { 76 | expect_snapshot({ 77 | code <- "foo({ 78 | 1 79 | }, { 80 | 2 81 | })" 82 | snap_reshape_cycle(2, code) 83 | }) 84 | }) 85 | 86 | test_that("empty lines are not indented when reshaped", { 87 | code <- 88 | "foo({ 89 | 1 90 | 91 | 2 92 | })" 93 | 94 | exp <- 95 | "foo( 96 | { 97 | 1 98 | 99 | 2 100 | } 101 | )" 102 | 103 | expect_equal( 104 | reshape(1, 2, info = parse_info(text = code)), 105 | exp 106 | ) 107 | }) 108 | 109 | test_that("String arguments are correctly indented", { 110 | expect_snapshot({ 111 | code <- "foo({\n 'baz'\n 'foofy'\n})" 112 | snap_reshape_cycle(3, code) 113 | 114 | code <- "foo('desc', 'bar', {\n 'baz'\n 'foofy'\n})" 115 | snap_reshape_cycle(3, code) 116 | }) 117 | }) 118 | 119 | test_that("lines within strings are not indented", { 120 | expect_snapshot({ 121 | code <- 122 | "foo('{ 123 | 1 124 | 2 125 | }')" 126 | snap_reshape_cycle(2, code) 127 | }) 128 | }) 129 | 130 | test_that("can reshape calls with comments", { 131 | expect_snapshot({ 132 | code <- 133 | "foo( 134 | x, 135 | y # comment 136 | )" 137 | snap_reshape_cycle(2, code) 138 | 139 | code <- 140 | "foo(x, y # comment 141 | )" 142 | snap_reshape_cycle(2, code) 143 | }) 144 | }) 145 | 146 | test_that("can reshape calls with empty arguments", { 147 | expect_snapshot({ 148 | code <- "foo(x, , , y, z, )" 149 | snap_reshape_cycle(2, code) 150 | }) 151 | }) 152 | -------------------------------------------------------------------------------- /tests/testthat/test-reshape-call.R: -------------------------------------------------------------------------------- 1 | test_that("can detect call type", { 2 | expect_call_shape("()", "wide") 3 | expect_call_shape("(a)", "wide") 4 | expect_call_shape("(a, b, c)", "wide") 5 | expect_call_shape("\n(a, b, c)\n", "wide") 6 | 7 | # Aligned argument or paren determines L shape 8 | expect_call_shape("(\n )", "L") 9 | expect_call_shape("(a,\n b)", "L") 10 | 11 | # Simple heuristic: first argument determines wide shape 12 | expect_call_shape("(a,\n b, c)", "wide") 13 | expect_call_shape("(a, b, c\n)", "wide") 14 | expect_call_shape("(a, b = b(\n), c)", "wide") 15 | 16 | # Simple heuristic: unaligned argument or paren determines long shape 17 | expect_call_shape("(\n)", "long") 18 | expect_call_shape("(\na)", "long") 19 | expect_call_shape("(\na, b, c)", "long") 20 | expect_call_shape("(\n\na, b, c)", "long") 21 | }) 22 | 23 | test_that("can reshape call longer", { 24 | expect_snapshot({ 25 | print_longer("()") 26 | print_longer("(a)") 27 | print_longer("(b, c)") 28 | print_longer("(a, b, c)") 29 | print_longer("(a = 1, b, c = 3)") 30 | 31 | "Leading indentation is preserved. First line is not indented" 32 | "because the reshaped text is meant to be inserted at the node" 33 | "coordinates." 34 | print_longer(" ()") 35 | print_longer(" (a)") 36 | print_longer(" (a, b)") 37 | 38 | "Multiline args are indented as is" 39 | print_longer("(a, b = foo(\n bar\n), c)") 40 | print_longer("(a, b =\n 2, c)") 41 | print_longer(" (a, b = foo(\n bar \n ), c)") 42 | 43 | "Wrong indentation is preserved" 44 | print_longer("(a, b = foo(\nbar\n), c)") 45 | print_longer(" (a, b = foo(\n bar\n), c)") 46 | }) 47 | }) 48 | 49 | test_that("can reshape call longer (L shape)", { 50 | expect_snapshot({ 51 | print_longer_l("()") 52 | print_longer_l("(a)") 53 | print_longer_l("(a, b)") 54 | print_longer_l("(a, b, c)") 55 | print_longer_l("(a = 1, b, c = 3)") 56 | 57 | "Leading indentation is preserved. First line is not indented" 58 | "because the reshaped text is meant to be inserted at the node" 59 | "coordinates." 60 | print_longer_l(" ()") 61 | print_longer_l(" (a)") 62 | print_longer_l(" (a, b)") 63 | 64 | "Multiline args are indented as is" 65 | print_longer_l("(a, b = foo(\n bar\n), c)") 66 | print_longer_l("(a, b =\n 2, c)") 67 | print_longer_l(" (a, b = foo(\n bar \n ), c)") 68 | 69 | "Wrong indentation is preserved" 70 | print_longer_l("(a, b = foo(\nbar\n), c)") 71 | print_longer_l(" (a, b = foo(\n bar\n), c)") 72 | }) 73 | }) 74 | 75 | test_that("can reshape call wider", { 76 | expect_snapshot({ 77 | print_wider("()") 78 | print_wider("(\n a\n)") 79 | print_wider("(\n\n a\n\n)") 80 | print_wider("(\n a, \n b\n)") 81 | print_wider("(\n a, \n b, \n c\n)") 82 | print_wider("(\n a = 1,\n b,\n c = 3\n)") 83 | 84 | "Leading indentation is ignored" 85 | print_wider(" ()") 86 | print_wider(" (\n a\n)") 87 | print_wider(" (\n\n a\n\n,\n b)") 88 | 89 | "Multiline args are indented as is" 90 | print_wider("(\n a,\n b = foo(\n bar\n ),\n c)") 91 | print_wider("(\n a,\n b =\n 2,\n c\n)") 92 | }) 93 | }) 94 | -------------------------------------------------------------------------------- /R/ast-call.R: -------------------------------------------------------------------------------- 1 | # This also selects function definitions 2 | find_function_calls <- function(data) { 3 | xml_find_all(data, ".//*[following-sibling::OP-LEFT-PAREN]/..") 4 | } 5 | 6 | find_function_call <- function(line, col, ..., data) { 7 | check_dots_empty() 8 | 9 | calls <- find_function_calls(data) 10 | loc <- locate_node(calls, line, col, data = data) 11 | 12 | if (loc) { 13 | calls[[loc]] 14 | } else { 15 | NULL 16 | } 17 | } 18 | 19 | check_call <- function(node, 20 | arg = caller_arg(node), 21 | call = caller_env()) { 22 | check_node_or_nodeset(node, arg = arg, call = call) 23 | 24 | if (!node_is_call(node)) { 25 | abort( 26 | sprintf("`%s` must be a function call node.", arg), 27 | arg = arg, 28 | call = call 29 | ) 30 | } 31 | } 32 | 33 | node_is_call <- function(node) { 34 | check_node_or_nodeset(node) 35 | 36 | if (inherits(node, "xml_node")) { 37 | set <- xml_children(node) 38 | } else { 39 | set <- node 40 | } 41 | if (length(set) < 3) { 42 | return(FALSE) 43 | } 44 | 45 | identical(xml_name(set[[2]]), "OP-LEFT-PAREN") 46 | } 47 | 48 | node_call_arguments <- function(node) { 49 | check_call(node) 50 | set <- node_children(node) 51 | 52 | right_paren <- match("OP-RIGHT-PAREN", xml_name(set)) 53 | if (!right_paren) { 54 | abort("Can't find right paren.", .internal = TRUE) 55 | } 56 | 57 | # Remove prefix call (function, while, etc) body 58 | n <- length(set) 59 | if (right_paren < n) { 60 | set <- set[-seq(right_paren + 1, n)] 61 | n <- right_paren 62 | } 63 | 64 | # Remove function node and parentheses 65 | set <- set[-c(1:2, n)] 66 | 67 | if (length(set)) { 68 | # Split on comma 69 | split_sep(set, xml_name(set) == "OP-COMMA") 70 | } else { 71 | list() 72 | } 73 | } 74 | 75 | node_call_body <- function(node) { 76 | check_call(node) 77 | set <- node_children(node) 78 | 79 | right_paren <- match("OP-RIGHT-PAREN", xml_name(set)) 80 | if (!right_paren) { 81 | abort("Can't find right paren.", .internal = TRUE) 82 | } 83 | 84 | n <- length(set) 85 | if (right_paren == n) { 86 | NULL 87 | } else { 88 | set[seq(right_paren + 1, n)] 89 | } 90 | } 91 | 92 | node_call_type <- function(node) { 93 | if (node_call_fn(node) %in% prefix_fn_node_names) { 94 | "prefix" 95 | } else { 96 | "bare" 97 | } 98 | } 99 | 100 | node_call_fn <- function(node) { 101 | check_call(node) 102 | set <- node_children(node) 103 | xml_name(set[[1]]) 104 | } 105 | 106 | node_call_needs_space_before_paren <- function(node) { 107 | need_space_fns <- c( 108 | "IF", 109 | "FOR", 110 | "WHILE" 111 | ) 112 | 113 | node_call_fn(node) %in% need_space_fns 114 | } 115 | 116 | node_call_parens <- function(node) { 117 | check_call(node) 118 | set <- xml_children(node) 119 | 120 | left <- set[[2]] 121 | 122 | if (node_call_type(node) == "prefix") { 123 | right <- set[[length(set) - 1]] 124 | } else { 125 | right <- set[[length(set)]] 126 | } 127 | 128 | list(left = left, right = right) 129 | } 130 | 131 | node_call_separators <- function(node) { 132 | set <- xml_children(node) 133 | set[xml_name(set) %in% c("OP-LEFT-PAREN", "OP-COMMA")] 134 | } 135 | -------------------------------------------------------------------------------- /inst/emacs/codegrip.el: -------------------------------------------------------------------------------- 1 | ;;; codegrip.el --- Get a grip on your code 2 | 3 | ;; Copyright (C) 2022 Posit, PBC. 4 | 5 | ;; Author: Lionel Henry 6 | ;; Version: 1.3 7 | ;; Package-Requires: ((ess "18.10.3")) 8 | ;; URL: https://github.com/lionel-/codegrip/tree/main/inst/emacs 9 | 10 | ;;; Commentary: 11 | ;; Provides interactive commands for reshaping code. 12 | 13 | (defvar codegrip--scratch-file nil) 14 | 15 | ;;;###autoload 16 | (defun codegrip-reshape () 17 | (interactive) 18 | (inferior-ess-r-force) 19 | (codegrip--update-scratch) 20 | (let ((cmd (format "codegrip:::emacs_reshape(%d, %d, file = '%s')\n" 21 | (line-number-at-pos) 22 | (1+ (current-column)) 23 | (codegrip--scratch-file)))) 24 | (when (ess-boolean-command cmd) 25 | (let* ((out (read (codegrip--scratch-buffer-string))) 26 | (reshaped (car (plist-get out :reshaped))) 27 | (beg (codegrip--as-position (plist-get out :start))) 28 | (end (codegrip--as-position (plist-get out :end))) 29 | (point (point))) 30 | (kill-region beg end) 31 | (goto-char beg) 32 | (insert reshaped) 33 | (goto-char point))))) 34 | 35 | ;;;###autoload 36 | (defun codegrip-move-outside () 37 | (interactive) 38 | (codegrip--move "codegrip:::emacs_move('outside', %d, %d, file = '%s')\n")) 39 | 40 | ;;;###autoload 41 | (defun codegrip-move-inside () 42 | (interactive) 43 | (codegrip--move "codegrip:::emacs_move('inside', %d, %d, file = '%s')\n")) 44 | 45 | ;;;###autoload 46 | (defun codegrip-move-next () 47 | (interactive) 48 | (codegrip--move "codegrip:::emacs_move('next', %d, %d, file = '%s')\n")) 49 | 50 | ;;;###autoload 51 | (defun codegrip-move-previous () 52 | (interactive) 53 | (codegrip--move "codegrip:::emacs_move('previous', %d, %d, file = '%s')\n")) 54 | 55 | (defun codegrip--move (cmd) 56 | (interactive) 57 | (inferior-ess-r-force) 58 | (codegrip--update-scratch) 59 | (let ((cmd (format cmd 60 | (line-number-at-pos) 61 | (1+ (current-column)) 62 | (codegrip--scratch-file)))) 63 | (when (ess-boolean-command cmd) 64 | (let* ((out (read (codegrip--scratch-buffer-string))) 65 | (pos (codegrip--as-position out))) 66 | (goto-char pos))))) 67 | 68 | (defun codegrip--update-scratch () 69 | (let ((buf (current-buffer))) 70 | (with-current-buffer (codegrip--scratch-buffer) 71 | (replace-buffer-contents buf) 72 | (basic-save-buffer) 73 | (kill-buffer)))) 74 | 75 | (defun codegrip--scratch-file () 76 | (unless codegrip--scratch-file 77 | (setq codegrip--scratch-file (make-temp-file "codegrip-scratch"))) 78 | codegrip--scratch-file) 79 | 80 | (defun codegrip--scratch-buffer () 81 | (let ((buf (find-file-noselect (codegrip--scratch-file)))) 82 | (with-current-buffer buf 83 | (rename-buffer " *codegrip--scratch*")) 84 | buf)) 85 | 86 | (defun codegrip--scratch-buffer-string () 87 | (let* ((buf (codegrip--scratch-buffer)) 88 | (out (with-current-buffer buf 89 | (buffer-string)))) 90 | (kill-buffer buf) 91 | out)) 92 | 93 | (defun codegrip--as-position (data) 94 | (save-excursion 95 | (codegrip--goto-line (plist-get data :line)) 96 | (forward-char (1- (plist-get data :col))) 97 | (point))) 98 | 99 | (defun codegrip--goto-line (line) 100 | (goto-char (point-min)) 101 | (forward-line (1- line))) 102 | 103 | (provide 'codegrip) 104 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # codegrip 2 | 3 | 4 | [![Codecov test coverage](https://codecov.io/gh/lionel-/codegrip/branch/main/graph/badge.svg)](https://app.codecov.io/gh/lionel-/codegrip?branch=main) 5 | [![R-CMD-check](https://github.com/lionel-/codegrip/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/lionel-/codegrip/actions/workflows/R-CMD-check.yaml) 6 | 7 | 8 | codegrip provides [RStudio addins](http://rstudio.github.io/rstudioaddins/) and Emacs commands for reshaping R code and navigating across syntactic constructs. 9 | 10 | 11 | ### Reshaping 12 | 13 | `addin_reshape` lets you cycle between different shapes of function calls. For instance, reshaping transforms code from wide to long shape and vice versa. 14 | 15 | 16 | 17 | Note that for function definitions, `addin_reshape` cycles through two different long shapes. The traditional L form uses more horizontal space whereas the flat form uses less horizontal space and the arguments are always aligned at single indent: 18 | 19 | 20 | 21 | 22 | ### Navigating 23 | 24 | There are currently two motions implemented in codegrip: outwards and inwards. 25 | 26 | 27 | - `addin_move_inside` finds the first opening delimiter (`(`, `[`, or `{`) _after_ your cursor and steps inside it. 28 | 29 | - `addin_move_outside` finds the first opening delimiter _before_ your cursor and steps outside it. 30 | 31 | 32 | 33 | These motions are handy for quick navigation across to quickly jump from a function argument to the corresponding function call. From there, you can reshape the whole call using `addin_reshape`. 34 | 35 | 36 | 37 | 38 | ## Installation 39 | 40 | The package is not yet on CRAN but you can install the development version from [GitHub](https://github.com/) with: 41 | 42 | ``` r 43 | # install.packages("devtools") 44 | devtools::install_github("lionel-/codegrip") 45 | ``` 46 | 47 | 48 | ### Setup 49 | 50 | Suggested keybindings: 51 | 52 | - `Alt + Tab`: `addin_reshape` 53 | - `Alt + 3`: `addin_move_outside` 54 | - `Alt + 4`: `addin_move_inside` 55 | 56 | Not yet implemented: 57 | 58 | - `Alt + 1`: `addin_move_backwards` 59 | - `Alt + 2`: `addin_move_forwards` 60 | 61 | 62 | ## Using in Visual Studio Code 63 | 64 | `addin_reshape` is available for keybinding in VS Code. See [here](https://github.com/REditorSupport/vscode-R/wiki/RStudio-addin-support#enabling-rstudio-addin-support) for instructions on enabling general addin support. 65 | 66 | Once addins are enabled, add the following to `keybindings.json`: 67 | 68 | ```json 69 | { 70 | "key": "Alt+tab", 71 | "command": "r.runCommand", 72 | "description": "Reshape expressions longer or wider", 73 | "when": "editorTextFocus", 74 | "args": "codegrip::addin_reshape()" 75 | } 76 | ``` 77 | 78 | ## Roadmap 79 | 80 | - Forward and backward motions. 81 | 82 | - Adding arguments to a function call using forward backward motions. 83 | 84 | - Reshaping of repeated calls like `foo(...)(...)`. This will help reshaping data.table pipelines, e.g. `DT[...][...]`. 85 | 86 | - Reshaping of `{` expressions. 87 | 88 | - Reshaping of pipelines of binary operations, including pipes. 89 | 90 | - Columnar formatting of `tibble::tribble()` calls. 91 | 92 | - Selection of syntactic constructs, such as function arguments. 93 | 94 | 95 | ## Limitations 96 | 97 | codegrip currently uses the R parser to figure out the structure of your code. Because of this, it doesn't work with malformed or partially written code. Your whole file must be valid R code for codegrip commands to work. 98 | -------------------------------------------------------------------------------- /tests/testthat/test-move.R: -------------------------------------------------------------------------------- 1 | test_that("can move outside", { 2 | code <- 3 | "foo({ 4 | bar( 5 | point(4, 5) 6 | ) 7 | }) 8 | " 9 | 10 | info <- parse_info(text = code) 11 | 12 | expect_null( 13 | move_outside_info(1, 3, info = info) 14 | ) 15 | expect_equal( 16 | move_outside_info(3, 5, info = info), 17 | c(line = 2, col = 3) 18 | ) 19 | expect_equal( 20 | move_outside_info(2, 3, info = info), 21 | c(line = 1, col = 5) 22 | ) 23 | expect_equal( 24 | move_outside_info(1, 5, info = info), 25 | c(line = 1, col = 1) 26 | ) 27 | expect_null( 28 | move_outside_info(1, 1, info = info) 29 | ) 30 | }) 31 | 32 | test_that("can move inside and outside", { 33 | code <- 34 | "foo[bar[[ 35 | baz({ 36 | quux 37 | }) 38 | ]]]" 39 | info <- parse_info(text = code) 40 | 41 | a <- c(line = 1, col = 1) 42 | b <- c(line = 1, col = 5) 43 | c <- c(line = 2, col = 3) 44 | d <- c(line = 2, col = 7) 45 | e <- c(line = 3, col = 5) 46 | 47 | expect_equal(inject(move_inside_info(!!!a, info = info)), b) 48 | expect_equal(inject(move_inside_info(!!!b, info = info)), c) 49 | expect_equal(inject(move_inside_info(!!!c, info = info)), d) 50 | expect_equal(inject(move_inside_info(!!!d, info = info)), e) 51 | expect_null(inject(move_inside_info(!!!e, info = info))) 52 | 53 | expect_equal(inject(move_outside_info(!!!e, info = info)), d) 54 | expect_equal(inject(move_outside_info(!!!d, info = info)), c) 55 | expect_equal(inject(move_outside_info(!!!c, info = info)), b) 56 | expect_equal(inject(move_outside_info(!!!b, info = info)), a) 57 | expect_null(inject(move_outside_info(!!!a, info = info))) 58 | }) 59 | 60 | test_that("can move inside parens", { 61 | code <- "(a)(b)(c())" 62 | info <- parse_info(text = code) 63 | 64 | out <- map(1:11, function(col) move_inside_info(1, col, info = info)[[2]]) 65 | exp <- list(2, NULL, NULL, 5, NULL, NULL, 8, 10, 10, NULL, NULL) 66 | expect_equal(out, exp) 67 | }) 68 | 69 | test_that("can move inside prefix fn", { 70 | info <- parse_info(text = "function() {}") 71 | expect_equal( 72 | move_inside_info(1, 1, info = info), 73 | c(line = 1, col = 10) 74 | ) 75 | info <- parse_info(text = "if (a) {}") 76 | expect_equal( 77 | move_inside_info(1, 1, info = info), 78 | c(line = 1, col = 5) 79 | ) 80 | }) 81 | 82 | test_that("can't move inside binary ops", { 83 | info <- parse_info(text = "foo + bar()") 84 | expect_null(move_outside_info(1, 1, info = info)) 85 | }) 86 | 87 | test_that("can move to next and previous", { 88 | code <- 89 | "foo({ 90 | bar( 91 | point(1, 1) 92 | ) 93 | }) 94 | " 95 | info <- parse_info(text = code) 96 | 97 | a <- c(line = 1, col = 1) 98 | b <- c(line = 1, col = 4) 99 | c <- c(line = 1, col = 5) 100 | d <- c(line = 2, col = 6) 101 | e <- c(line = 3, col = 10) 102 | 103 | expect_equal(inject(move_next_info(!!!a, info = info)), b) 104 | expect_equal(inject(move_next_info(!!!b, info = info)), c) 105 | expect_equal(inject(move_next_info(!!!c, info = info)), d) 106 | expect_equal(inject(move_next_info(!!!d, info = info)), e) 107 | expect_null(inject(move_next_info(!!!e, info = info))) 108 | 109 | expect_equal(inject(move_previous_info(!!!e, info = info)), d) 110 | expect_equal(inject(move_previous_info(!!!d, info = info)), c) 111 | expect_equal(inject(move_previous_info(!!!c, info = info)), b) 112 | expect_null(inject(move_previous_info(!!!b, info = info))) 113 | expect_null(inject(move_previous_info(!!!a, info = info))) 114 | }) 115 | 116 | test_that("moving inside with cursor on whitespace", { 117 | info <- parse_info(text = " foo()") 118 | expect_equal( 119 | move_inside_info(1, 1, info = info), 120 | c(line = 1, col = 7) 121 | ) 122 | 123 | code <- 124 | "{ 125 | foo() 126 | }" 127 | info <- parse_info(text = code) 128 | expect_equal( 129 | move_inside_info(1, 2, info = info), 130 | c(line = 2, col = 7) 131 | ) 132 | expect_equal( 133 | move_inside_info(2, 1, info = info), 134 | c(line = 2, col = 7) 135 | ) 136 | 137 | code <- 138 | "function() { 139 | bar() 140 | 1 + foo() 141 | }" 142 | info <- parse_info(text = code) 143 | expect_equal( 144 | move_inside_info(3, 1, info = info), 145 | c(line = 3, col = 11) 146 | ) 147 | }) 148 | 149 | test_that("don't move past closing delims", { 150 | code <- 151 | "{ 152 | { 153 | NULL 154 | } 155 | foo() 156 | }" 157 | info <- parse_info(text = code) 158 | expect_null(move_inside_info(3, 1, info = info)) 159 | }) 160 | -------------------------------------------------------------------------------- /man/figures/README/reshape-call.svg: -------------------------------------------------------------------------------- 1 | list(a,b,c)list(a,b,c) -------------------------------------------------------------------------------- /R/reshape-call.R: -------------------------------------------------------------------------------- 1 | node_call_shape <- function(node) { 2 | check_call(node) 3 | 4 | set <- xml_children(node) 5 | args <- node_call_arguments(set) 6 | 7 | parens <- node_call_parens(node) 8 | left_paren <- parens[[1]] 9 | right_paren <- parens[[2]] 10 | 11 | if (!length(args)) { 12 | if (identical(xml_line1(left_paren), xml_line1(right_paren))) { 13 | return("wide") 14 | } else if (identical(xml_col1(left_paren), xml_col1(right_paren) - 1L)) { 15 | return("L") 16 | } else { 17 | return("long") 18 | } 19 | } 20 | 21 | # Simple heuristic: If first argument is on the same line as the 22 | # opening paren, it's horizontal. Otherwise, it's vertical. 23 | paren_line1 <- xml_line1(left_paren) 24 | arg_line1 <- min(xml_line1(args[[1]])) 25 | 26 | if (!identical(paren_line1, arg_line1)) { 27 | return("long") 28 | } 29 | if (length(args) <= 1) { 30 | return("wide") 31 | } 32 | 33 | paren_col1 <- xml_col1(left_paren) 34 | 35 | # Can't look into `args` because we need to deal with empty args. 36 | # Just look for node following first comma, which might also be a comma. 37 | first_comma <- which(xml_name(set) == "OP-COMMA")[[1]] 38 | arg_col1 <- min(xml_col1(set[[first_comma + 1L]])) 39 | 40 | if (identical(paren_col1, arg_col1 - 1L)) { 41 | "L" 42 | } else { 43 | "wide" 44 | } 45 | } 46 | 47 | node_call_longer <- function(node, ..., L = FALSE, info) { 48 | check_call(node) 49 | base_indent <- 2 50 | 51 | set <- xml_children(node) 52 | args_nodes <- node_call_arguments(set) 53 | n_args <- length(args_nodes) 54 | current_indent_n <- node_indentation(node, info = info) 55 | 56 | if (!n_args) { 57 | return(node_text(node, info = info)) 58 | } 59 | 60 | prefix <- node_call_type(node) == "prefix" 61 | 62 | if (node_call_needs_space_before_paren(node)) { 63 | left_paren_text <- " (" 64 | } else { 65 | left_paren_text <- "(" 66 | } 67 | 68 | if (prefix) { 69 | body <- node_text(node_call_body(node), info = info) 70 | suffix <- paste0(" ", body) 71 | } else { 72 | suffix <- "" 73 | } 74 | 75 | fn <- node_text(set[[1]], info = info) 76 | left_paren <- node_call_parens(node)[[1]] 77 | 78 | if (L) { 79 | fn <- paste0(fn, left_paren_text) 80 | new_indent_n <- xml_col2(left_paren) 81 | } else { 82 | fn <- paste0(fn, left_paren_text, "\n") 83 | new_indent_n <- current_indent_n + base_indent 84 | } 85 | 86 | if (L) { 87 | fn <- paste0(fn, node_text(args_nodes[[1]], info = info)) 88 | 89 | if (n_args == 1) { 90 | return(paste0(fn, ")", suffix)) 91 | } 92 | 93 | if (n_args > 1) { 94 | fn <- paste0(fn, ",\n") 95 | } 96 | 97 | n_args <- n_args - 1L 98 | args_nodes <- args_nodes[-1] 99 | } 100 | 101 | arg_text <- function(arg) { 102 | sep_line_ns <- xml_line1(node_call_separators(node)) 103 | 104 | if (length(arg)) { 105 | lines <- node_text_lines(arg, info = info) 106 | lines[[1]] <- line_reindent(lines[[1]], new_indent_n) 107 | 108 | arg_line_n <- xml_line1(arg)[[1]] 109 | if (any(arg_line_n == sep_line_ns)) { 110 | arg_parent_indent_n <- 0L 111 | } else { 112 | arg_parent_indent_n <- xml_col1(arg)[[1L]] + 1L 113 | } 114 | } else { 115 | lines <- "" 116 | arg_parent_indent_n <- 0L 117 | } 118 | 119 | if (L) { 120 | arg_indent_n <- new_indent_n - current_indent_n - arg_parent_indent_n 121 | } else { 122 | arg_indent_n <- base_indent - arg_parent_indent_n 123 | } 124 | 125 | if (length(arg)) { 126 | lines <- indent_adjust(lines, arg_indent_n, skip = 1) 127 | } else { 128 | lines <- spaces(arg_indent_n) 129 | } 130 | 131 | paste0(lines, collapse = "\n") 132 | } 133 | 134 | args <- map(args_nodes[-n_args], function(node) { 135 | paste0(arg_text(node), ",\n") 136 | }) 137 | args <- paste0(as.character(args), collapse = "") 138 | 139 | last <- paste0( 140 | arg_text(args_nodes[[n_args]]), 141 | if (!L) "\n", 142 | if (!L) spaces(current_indent_n), 143 | ")" 144 | ) 145 | 146 | paste0(fn, args, last, suffix) 147 | } 148 | 149 | node_call_wider <- function(node, ..., info) { 150 | check_call(node) 151 | 152 | set <- xml_children(node) 153 | args_nodes <- node_call_arguments(set) 154 | n_args <- length(args_nodes) 155 | 156 | if (!n_args) { 157 | return(node_text(node, info = info)) 158 | } 159 | if (any(xml_name(set) == "COMMENT")) { 160 | return(node_text(node, info = info)) 161 | } 162 | 163 | if (node_call_needs_space_before_paren(node)) { 164 | left_paren_text <- " (" 165 | } else { 166 | left_paren_text <- "(" 167 | } 168 | 169 | fn <- paste0(node_text(set[[1]], info = info), left_paren_text) 170 | 171 | base_indent <- 2 172 | arg_text <- function(node) { 173 | if (length(node)) { 174 | text <- node_text_lines(node, info = info) 175 | lines <- indent_adjust(text, -base_indent) 176 | paste0(lines, collapse = "\n") 177 | } else { 178 | "" 179 | } 180 | } 181 | 182 | args <- map(args_nodes[-n_args], function(node) { 183 | paste0(arg_text(node), ", ") 184 | }) 185 | 186 | args <- as.character(compact(args)) 187 | args <- paste0(args, collapse = "") 188 | 189 | if (node_call_type(node) == "prefix") { 190 | body <- node_text(node_call_body(node), info = info) 191 | suffix <- paste0(" ", body) 192 | } else { 193 | suffix <- "" 194 | } 195 | 196 | last <- paste0(arg_text(args_nodes[[n_args]]), ")") 197 | paste0(fn, args, last, suffix) 198 | } 199 | -------------------------------------------------------------------------------- /R/compat-purrr.R: -------------------------------------------------------------------------------- 1 | # nocov start - compat-purrr.R 2 | # Latest version: https://github.com/r-lib/rlang/blob/main/R/compat-purrr.R 3 | 4 | # This file provides a minimal shim to provide a purrr-like API on top of 5 | # base R functions. They are not drop-in replacements but allow a similar style 6 | # of programming. 7 | # 8 | # Changelog: 9 | # 10 | # 2022-06-07: 11 | # * `transpose()` is now more consistent with purrr when inner names 12 | # are not congruent (#1346). 13 | # 14 | # 2021-12-15: 15 | # * `transpose()` now supports empty lists. 16 | # 17 | # 2021-05-21: 18 | # * Fixed "object `x` not found" error in `imap()` (@mgirlich) 19 | # 20 | # 2020-04-14: 21 | # * Removed `pluck*()` functions 22 | # * Removed `*_cpl()` functions 23 | # * Used `as_function()` to allow use of `~` 24 | # * Used `.` prefix for helpers 25 | 26 | map <- function(.x, .f, ...) { 27 | .f <- as_function(.f, env = global_env()) 28 | lapply(.x, .f, ...) 29 | } 30 | walk <- function(.x, .f, ...) { 31 | map(.x, .f, ...) 32 | invisible(.x) 33 | } 34 | 35 | map_lgl <- function(.x, .f, ...) { 36 | .rlang_purrr_map_mold(.x, .f, logical(1), ...) 37 | } 38 | map_int <- function(.x, .f, ...) { 39 | .rlang_purrr_map_mold(.x, .f, integer(1), ...) 40 | } 41 | map_dbl <- function(.x, .f, ...) { 42 | .rlang_purrr_map_mold(.x, .f, double(1), ...) 43 | } 44 | map_chr <- function(.x, .f, ...) { 45 | .rlang_purrr_map_mold(.x, .f, character(1), ...) 46 | } 47 | .rlang_purrr_map_mold <- function(.x, .f, .mold, ...) { 48 | .f <- as_function(.f, env = global_env()) 49 | out <- vapply(.x, .f, .mold, ..., USE.NAMES = FALSE) 50 | names(out) <- names(.x) 51 | out 52 | } 53 | 54 | map2 <- function(.x, .y, .f, ...) { 55 | .f <- as_function(.f, env = global_env()) 56 | out <- mapply(.f, .x, .y, MoreArgs = list(...), SIMPLIFY = FALSE) 57 | if (length(out) == length(.x)) { 58 | set_names(out, names(.x)) 59 | } else { 60 | set_names(out, NULL) 61 | } 62 | } 63 | map2_lgl <- function(.x, .y, .f, ...) { 64 | as.vector(map2(.x, .y, .f, ...), "logical") 65 | } 66 | map2_int <- function(.x, .y, .f, ...) { 67 | as.vector(map2(.x, .y, .f, ...), "integer") 68 | } 69 | map2_dbl <- function(.x, .y, .f, ...) { 70 | as.vector(map2(.x, .y, .f, ...), "double") 71 | } 72 | map2_chr <- function(.x, .y, .f, ...) { 73 | as.vector(map2(.x, .y, .f, ...), "character") 74 | } 75 | imap <- function(.x, .f, ...) { 76 | map2(.x, names(.x) %||% seq_along(.x), .f, ...) 77 | } 78 | 79 | pmap <- function(.l, .f, ...) { 80 | .f <- as.function(.f) 81 | args <- .rlang_purrr_args_recycle(.l) 82 | do.call("mapply", c( 83 | FUN = list(quote(.f)), 84 | args, MoreArgs = quote(list(...)), 85 | SIMPLIFY = FALSE, USE.NAMES = FALSE 86 | )) 87 | } 88 | .rlang_purrr_args_recycle <- function(args) { 89 | lengths <- map_int(args, length) 90 | n <- max(lengths) 91 | 92 | stopifnot(all(lengths == 1L | lengths == n)) 93 | to_recycle <- lengths == 1L 94 | args[to_recycle] <- map(args[to_recycle], function(x) rep.int(x, n)) 95 | 96 | args 97 | } 98 | 99 | keep <- function(.x, .f, ...) { 100 | .x[.rlang_purrr_probe(.x, .f, ...)] 101 | } 102 | discard <- function(.x, .p, ...) { 103 | sel <- .rlang_purrr_probe(.x, .p, ...) 104 | .x[is.na(sel) | !sel] 105 | } 106 | map_if <- function(.x, .p, .f, ...) { 107 | matches <- .rlang_purrr_probe(.x, .p) 108 | .x[matches] <- map(.x[matches], .f, ...) 109 | .x 110 | } 111 | .rlang_purrr_probe <- function(.x, .p, ...) { 112 | if (is_logical(.p)) { 113 | stopifnot(length(.p) == length(.x)) 114 | .p 115 | } else { 116 | .p <- as_function(.p, env = global_env()) 117 | map_lgl(.x, .p, ...) 118 | } 119 | } 120 | 121 | compact <- function(.x) { 122 | Filter(length, .x) 123 | } 124 | 125 | transpose <- function(.l) { 126 | if (!length(.l)) { 127 | return(.l) 128 | } 129 | 130 | inner_names <- names(.l[[1]]) 131 | 132 | if (is.null(inner_names)) { 133 | fields <- seq_along(.l[[1]]) 134 | } else { 135 | fields <- set_names(inner_names) 136 | .l <- map(.l, function(x) { 137 | if (is.null(names(x))) { 138 | set_names(x, inner_names) 139 | } else { 140 | x 141 | } 142 | }) 143 | } 144 | 145 | # This way missing fields are subsetted as `NULL` instead of causing 146 | # an error 147 | .l <- map(.l, as.list) 148 | 149 | map(fields, function(i) { 150 | map(.l, .subset2, i) 151 | }) 152 | } 153 | 154 | every <- function(.x, .p, ...) { 155 | .p <- as_function(.p, env = global_env()) 156 | 157 | for (i in seq_along(.x)) { 158 | if (!rlang::is_true(.p(.x[[i]], ...))) return(FALSE) 159 | } 160 | TRUE 161 | } 162 | some <- function(.x, .p, ...) { 163 | .p <- as_function(.p, env = global_env()) 164 | 165 | for (i in seq_along(.x)) { 166 | if (rlang::is_true(.p(.x[[i]], ...))) return(TRUE) 167 | } 168 | FALSE 169 | } 170 | negate <- function(.p) { 171 | .p <- as_function(.p, env = global_env()) 172 | function(...) !.p(...) 173 | } 174 | 175 | reduce <- function(.x, .f, ..., .init) { 176 | f <- function(x, y) .f(x, y, ...) 177 | Reduce(f, .x, init = .init) 178 | } 179 | reduce_right <- function(.x, .f, ..., .init) { 180 | f <- function(x, y) .f(y, x, ...) 181 | Reduce(f, .x, init = .init, right = TRUE) 182 | } 183 | accumulate <- function(.x, .f, ..., .init) { 184 | f <- function(x, y) .f(x, y, ...) 185 | Reduce(f, .x, init = .init, accumulate = TRUE) 186 | } 187 | accumulate_right <- function(.x, .f, ..., .init) { 188 | f <- function(x, y) .f(y, x, ...) 189 | Reduce(f, .x, init = .init, right = TRUE, accumulate = TRUE) 190 | } 191 | 192 | detect <- function(.x, .f, ..., .right = FALSE, .p = is_true) { 193 | .p <- as_function(.p, env = global_env()) 194 | .f <- as_function(.f, env = global_env()) 195 | 196 | for (i in .rlang_purrr_index(.x, .right)) { 197 | if (.p(.f(.x[[i]], ...))) { 198 | return(.x[[i]]) 199 | } 200 | } 201 | NULL 202 | } 203 | detect_index <- function(.x, .f, ..., .right = FALSE, .p = is_true) { 204 | .p <- as_function(.p, env = global_env()) 205 | .f <- as_function(.f, env = global_env()) 206 | 207 | for (i in .rlang_purrr_index(.x, .right)) { 208 | if (.p(.f(.x[[i]], ...))) { 209 | return(i) 210 | } 211 | } 212 | 0L 213 | } 214 | .rlang_purrr_index <- function(x, right = FALSE) { 215 | idx <- seq_along(x) 216 | if (right) { 217 | idx <- rev(idx) 218 | } 219 | idx 220 | } 221 | 222 | # nocov end 223 | -------------------------------------------------------------------------------- /tests/testthat/test-ast-call.R: -------------------------------------------------------------------------------- 1 | test_that("can find function call node for position", { 2 | path <- test_path("fixtures", "calls.R") 3 | xml <- parse_xml(parse_info(path)) 4 | calls <- find_function_calls(xml) 5 | lines <- readLines(path) 6 | 7 | nodes <- function(line) { 8 | cols <- seq_len(nchar(lines[[line]])) 9 | vapply( 10 | cols, 11 | function(col) locate_node(calls, line, col, data = xml), 12 | integer(1) 13 | ) 14 | } 15 | 16 | call_nodes <- lapply(seq_along(lines), nodes) 17 | expect_snapshot({ 18 | "Node locations of function calls for all combinations of line and col" 19 | call_nodes 20 | }) 21 | 22 | node <- find_function_call(4, 4, data = xml) 23 | expect_snapshot({ 24 | "Positions of function call at 4:4" 25 | node_positions(node)[1:4] 26 | }) 27 | }) 28 | 29 | test_that("can retrieve function call text", { 30 | path <- test_path("fixtures", "calls.R") 31 | info <- parse_info(path) 32 | xml <- parse_xml(info) 33 | 34 | expect_snapshot({ 35 | "Cursor on `function`" 36 | node <- find_function_call(2, 13, data = xml) 37 | cat_line(node_text(node, info = info)) 38 | 39 | "Cursor on `quux`" 40 | node <- find_function_call(4, 4, data = xml) 41 | cat_line(node_text(node, info = info)) 42 | 43 | "Cursor on complex call" 44 | node <- find_function_call(5, 3, data = xml) 45 | cat_line(node_text(node, info = info)) 46 | 47 | "Cursor on `hop`" 48 | node <- find_function_call(11, 1, data = xml) 49 | cat_line(node_text(node, info = info)) 50 | }) 51 | }) 52 | 53 | test_that("find_function_calls() selects from current node", { 54 | info <- parse_info(text = "foo(bar())") 55 | xml <- parse_xml(info) 56 | 57 | calls <- find_function_calls(xml) 58 | expect_length(calls, 2) 59 | 60 | expect_equal( 61 | node_text(calls[[1]], info = info), 62 | "foo(bar())" 63 | ) 64 | expect_equal( 65 | node_text(calls[[2]], info = info), 66 | "bar()" 67 | ) 68 | 69 | expect_equal( 70 | find_function_calls(calls[[1]]), 71 | calls 72 | ) 73 | 74 | inner_calls <- find_function_calls(calls[[2]]) 75 | expect_length(inner_calls, 1) 76 | 77 | expect_equal( 78 | inner_calls[[1]], 79 | calls[[2]] 80 | ) 81 | }) 82 | 83 | test_that("check_call() detects calls", { 84 | expr <- parse_xml_one(parse_info(text = "foo()")) 85 | expect_true(node_is_call(expr)) 86 | 87 | expr <- parse_xml_one(parse_info(text = "foo(bar())")) 88 | expect_true(node_is_call(expr)) 89 | 90 | expr <- parse_xml_one(parse_info(text = "foo + bar")) 91 | expect_false(node_is_call(expr)) 92 | 93 | fn <- function(x) check_call(x) 94 | expect_snapshot({ 95 | (expect_error(fn(expr))) 96 | }) 97 | }) 98 | 99 | test_that("can retrieve arguments of calls", { 100 | expr <- parse_xml_one(parse_info(text = "foo()")) 101 | expect_equal( 102 | node_call_arguments(expr), 103 | list() 104 | ) 105 | 106 | info <- parse_info(text = "foo(1, 2, 3)") 107 | expr <- parse_xml_one(info) 108 | args <- node_call_arguments(expr) 109 | 110 | expect_equal( 111 | node_list_text(args, info = info), 112 | list("1", "2", "3") 113 | ) 114 | 115 | info <- parse_info(text = "foo(a = 1, b, c = 3 + \n4)") 116 | node <- parse_xml_one(info) 117 | args <- node_call_arguments(node) 118 | 119 | expect_equal( 120 | node_list_text(args, info = info), 121 | list("a = 1", "b", "c = 3 + \n4") 122 | ) 123 | }) 124 | 125 | test_that("can retrieve arguments of function definitions", { 126 | expr <- parse_xml_one(parse_info(text = "function() NULL")) 127 | expect_equal( 128 | node_call_arguments(expr), 129 | list() 130 | ) 131 | 132 | info <- parse_info(text = "function(a, b, c) NULL") 133 | expr <- parse_xml_one(info) 134 | args <- node_call_arguments(expr) 135 | 136 | expect_equal( 137 | node_list_text(args, info = info), 138 | list("a", "b", "c") 139 | ) 140 | 141 | info <- parse_info(text = "function(a = 1, b, c = 3) NULL") 142 | expr <- parse_xml_one(info) 143 | args <- node_call_arguments(expr) 144 | 145 | expect_equal( 146 | node_list_text(args, info = info), 147 | list("a = 1", "b", "c = 3") 148 | ) 149 | 150 | info <- parse_info(text = "function(a = 1, b, c = 3 + \n4) NULL") 151 | node <- parse_xml_one(info) 152 | args <- node_call_arguments(node) 153 | 154 | expect_equal( 155 | node_list_text(args, info = info), 156 | list("a = 1", "b", "c = 3 + \n4") 157 | ) 158 | }) 159 | 160 | test_that("can retrieve argument of if calls", { 161 | info <- parse_info(text = "if (a) b") 162 | node <- parse_xml_one(info) 163 | expect_equal( 164 | map(node_call_arguments(node), node_text, info = info), 165 | list("a") 166 | ) 167 | 168 | info <- parse_info(text = "if (a) b else c") 169 | node <- parse_xml_one(info) 170 | expect_equal( 171 | map(node_call_arguments(node), node_text, info = info), 172 | list("a") 173 | ) 174 | }) 175 | 176 | test_that("can retrieve body of prefix calls", { 177 | expect_null(node_call_body(p("foo()"))) 178 | 179 | info <- parse_info(text = "function(a) b") 180 | node <- parse_xml_one(info) 181 | expect_equal( 182 | map(node_call_body(node), node_text, info = info), 183 | list("b") 184 | ) 185 | 186 | info <- parse_info(text = "while (a) b") 187 | node <- parse_xml_one(info) 188 | expect_equal( 189 | map(node_call_body(node), node_text, info = info), 190 | list("b") 191 | ) 192 | 193 | info <- parse_info(text = "if (a) b") 194 | node <- parse_xml_one(info) 195 | expect_equal( 196 | map(node_call_body(node), node_text, info = info), 197 | list("b") 198 | ) 199 | 200 | info <- parse_info(text = "if (a) b else c") 201 | node <- parse_xml_one(info) 202 | expect_equal( 203 | map(node_call_body(node), node_text, info = info), 204 | list("b", "else", "c") 205 | ) 206 | 207 | expect_error( 208 | node_call_body(p("for (i in x) b")), 209 | "must be a function call node" 210 | ) 211 | }) 212 | 213 | test_that("can detect prefix calls", { 214 | expect_equal( 215 | node_call_type(p("function(a) NULL")), 216 | "prefix" 217 | ) 218 | expect_equal( 219 | node_call_type(p("if (a) NULL")), 220 | "prefix" 221 | ) 222 | expect_equal( 223 | node_call_type(p("while (a) NULL")), 224 | "prefix" 225 | ) 226 | 227 | # `for` calls are not ordinary parenthesised expressions 228 | expect_error( 229 | node_call_type(p("for (x in i) NULL")), 230 | "must be a function call node" 231 | ) 232 | }) 233 | 234 | test_that("node_call_arguments() supports empty arguments", { 235 | node <- p("foo(x = x, , y, z, )") 236 | children <- xml_children(node) 237 | empty <- children[0] 238 | 239 | expect_equal( 240 | node_call_arguments(node), 241 | list( 242 | children[3:5], 243 | empty, 244 | children[8], 245 | children[10], 246 | empty 247 | ) 248 | ) 249 | }) 250 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/reshape.md: -------------------------------------------------------------------------------- 1 | # reshape() cycles function calls and definitions 2 | 3 | Code 4 | code <- "foofybaz()" 5 | snap_reshape_cycle(2, code) 6 | Output 7 | i: 1 8 | foofybaz() 9 | 10 | i: 2 11 | foofybaz() 12 | 13 | Code 14 | code <- "foofybaz(a)" 15 | snap_reshape_cycle(3, code) 16 | Output 17 | i: 1 18 | foofybaz( 19 | a 20 | ) 21 | 22 | i: 2 23 | foofybaz(a) 24 | 25 | i: 3 26 | foofybaz( 27 | a 28 | ) 29 | 30 | Code 31 | code <- "foofybaz(a, b = 1, c)" 32 | snap_reshape_cycle(3, code) 33 | Output 34 | i: 1 35 | foofybaz( 36 | a, 37 | b = 1, 38 | c 39 | ) 40 | 41 | i: 2 42 | foofybaz(a, b = 1, c) 43 | 44 | i: 3 45 | foofybaz( 46 | a, 47 | b = 1, 48 | c 49 | ) 50 | 51 | Code 52 | code <- "function() NULL" 53 | snap_reshape_cycle(2, code) 54 | Output 55 | i: 1 56 | function() NULL 57 | 58 | i: 2 59 | function() NULL 60 | 61 | Code 62 | code <- "function(a) NULL" 63 | snap_reshape_cycle(3, code) 64 | Output 65 | i: 1 66 | function( 67 | a 68 | ) NULL 69 | 70 | i: 2 71 | function(a) NULL 72 | 73 | i: 3 74 | function( 75 | a 76 | ) NULL 77 | 78 | Code 79 | code <- "function(a, b = 1, c) NULL" 80 | snap_reshape_cycle(4, code) 81 | Output 82 | i: 1 83 | function(a, 84 | b = 1, 85 | c) NULL 86 | 87 | i: 2 88 | function( 89 | a, 90 | b = 1, 91 | c 92 | ) NULL 93 | 94 | i: 3 95 | function(a, b = 1, c) NULL 96 | 97 | i: 4 98 | function(a, 99 | b = 1, 100 | c) NULL 101 | 102 | 103 | # reshape() cycles other call-like constructs 104 | 105 | Code 106 | code <- "if (a) NULL" 107 | snap_reshape_cycle(2, code) 108 | Output 109 | i: 1 110 | if ( 111 | a 112 | ) NULL 113 | 114 | i: 2 115 | if (a) NULL 116 | 117 | Code 118 | code <- "if (a) b else c" 119 | snap_reshape_cycle(2, code) 120 | Output 121 | i: 1 122 | if ( 123 | a 124 | ) b else c 125 | 126 | i: 2 127 | if (a) b else c 128 | 129 | Code 130 | code <- "while (a) NULL" 131 | snap_reshape_cycle(2, code) 132 | Output 133 | i: 1 134 | while ( 135 | a 136 | ) NULL 137 | 138 | i: 2 139 | while (a) NULL 140 | 141 | Code 142 | code <- "for (i in x) NULL" 143 | snap_reshape_cycle(1, code) 144 | Output 145 | i: 1 146 | for (i in x) NULL 147 | 148 | 149 | # can reshape braced expressions 150 | 151 | Code 152 | code <- "expect_snapshot({\n a\n b\n})" 153 | snap_reshape_cycle(2, code) 154 | Output 155 | i: 1 156 | expect_snapshot( 157 | { 158 | a 159 | b 160 | } 161 | ) 162 | 163 | i: 2 164 | expect_snapshot({ 165 | a 166 | b 167 | }) 168 | 169 | Code 170 | code <- "{\n expect_snapshot({\n a\n b\n })\n}" 171 | snap_reshape_cycle(2, code, line = 2, col = 3) 172 | Output 173 | i: 1 174 | expect_snapshot( 175 | { 176 | a 177 | b 178 | } 179 | ) 180 | 181 | i: 2 182 | expect_snapshot({ 183 | a 184 | b 185 | }) 186 | 187 | Code 188 | code <- "test_that('desc', {\n a\n b\n})" 189 | snap_reshape_cycle(3, code) 190 | Output 191 | i: 1 192 | test_that( 193 | 'desc', 194 | { 195 | a 196 | b 197 | } 198 | ) 199 | 200 | i: 2 201 | test_that('desc', { 202 | a 203 | b 204 | }) 205 | 206 | i: 3 207 | test_that( 208 | 'desc', 209 | { 210 | a 211 | b 212 | } 213 | ) 214 | 215 | Code 216 | code <- "test_that({\n a\n b\n}, desc = 'desc')" 217 | snap_reshape_cycle(3, code) 218 | Output 219 | i: 1 220 | test_that( 221 | { 222 | a 223 | b 224 | }, 225 | desc = 'desc' 226 | ) 227 | 228 | i: 2 229 | test_that({ 230 | a 231 | b 232 | }, desc = 'desc') 233 | 234 | i: 3 235 | test_that( 236 | { 237 | a 238 | b 239 | }, 240 | desc = 'desc' 241 | ) 242 | 243 | 244 | # can reshape with multiple braced expressions 245 | 246 | Code 247 | code <- "foo({\n 1\n}, {\n 2\n})" 248 | snap_reshape_cycle(2, code) 249 | Output 250 | i: 1 251 | foo( 252 | { 253 | 1 254 | }, 255 | { 256 | 2 257 | } 258 | ) 259 | 260 | i: 2 261 | foo({ 262 | 1 263 | }, { 264 | 2 265 | }) 266 | 267 | 268 | # String arguments are correctly indented 269 | 270 | Code 271 | code <- "foo({\n 'baz'\n 'foofy'\n})" 272 | snap_reshape_cycle(3, code) 273 | Output 274 | i: 1 275 | foo( 276 | { 277 | 'baz' 278 | 'foofy' 279 | } 280 | ) 281 | 282 | i: 2 283 | foo({ 284 | 'baz' 285 | 'foofy' 286 | }) 287 | 288 | i: 3 289 | foo( 290 | { 291 | 'baz' 292 | 'foofy' 293 | } 294 | ) 295 | 296 | Code 297 | code <- "foo('desc', 'bar', {\n 'baz'\n 'foofy'\n})" 298 | snap_reshape_cycle(3, code) 299 | Output 300 | i: 1 301 | foo( 302 | 'desc', 303 | 'bar', 304 | { 305 | 'baz' 306 | 'foofy' 307 | } 308 | ) 309 | 310 | i: 2 311 | foo('desc', 'bar', { 312 | 'baz' 313 | 'foofy' 314 | }) 315 | 316 | i: 3 317 | foo( 318 | 'desc', 319 | 'bar', 320 | { 321 | 'baz' 322 | 'foofy' 323 | } 324 | ) 325 | 326 | 327 | # lines within strings are not indented 328 | 329 | Code 330 | code <- "foo('{\n 1\n 2\n}')" 331 | snap_reshape_cycle(2, code) 332 | Output 333 | i: 1 334 | foo( 335 | '{ 336 | 1 337 | 2 338 | }' 339 | ) 340 | 341 | i: 2 342 | foo('{ 343 | 1 344 | 2 345 | }') 346 | 347 | 348 | # can reshape calls with comments 349 | 350 | Code 351 | code <- "foo(\n x,\n y # comment\n)" 352 | snap_reshape_cycle(2, code) 353 | Output 354 | i: 1 355 | foo( 356 | x, 357 | y # comment 358 | ) 359 | 360 | i: 2 361 | foo( 362 | x, 363 | y # comment 364 | ) 365 | 366 | Code 367 | code <- "foo(x, y # comment\n)" 368 | snap_reshape_cycle(2, code) 369 | Output 370 | i: 1 371 | foo( 372 | x, 373 | y # comment 374 | ) 375 | 376 | i: 2 377 | foo( 378 | x, 379 | y # comment 380 | ) 381 | 382 | 383 | # can reshape calls with empty arguments 384 | 385 | Code 386 | code <- "foo(x, , , y, z, )" 387 | snap_reshape_cycle(2, code) 388 | Output 389 | i: 1 390 | foo( 391 | x, 392 | , 393 | , 394 | y, 395 | z, 396 | 397 | ) 398 | 399 | i: 2 400 | foo(x, , , y, z, ) 401 | 402 | 403 | -------------------------------------------------------------------------------- /R/ast.R: -------------------------------------------------------------------------------- 1 | parse_xml <- function(info) { 2 | check_info(info) 3 | 4 | ast <- parse(info$file, text = info$lines, keep.source = TRUE) 5 | data <- utils::getParseData(ast) 6 | 7 | xml_text <- xmlparsedata::xml_parse_data(data) 8 | read_xml(xml_text) 9 | } 10 | 11 | parse_info <- function(file = "", text = NULL, lines = NULL, xml = NULL) { 12 | if (!is_null(text)) { 13 | lines <- as_lines(text) 14 | } 15 | list( 16 | file = file, 17 | lines = lines, 18 | xml = xml 19 | ) 20 | } 21 | 22 | parse_info_complete <- function(info) { 23 | if (is.null(info$lines)) { 24 | info$lines <- readLines(info$file) 25 | } 26 | 27 | if (is.null(info$xml)) { 28 | info$xml <- parse_xml(info) 29 | } 30 | 31 | info 32 | } 33 | 34 | is_info <- function(x) { 35 | is.list(x) && all(c("file", "lines", "xml") %in% names(x)) 36 | } 37 | 38 | check_info <- function(info, 39 | arg = caller_arg(info), 40 | call = caller_env()) { 41 | if (!is_info(info)) { 42 | abort( 43 | sprintf("`%s` must be a list created by `parse_info()`.", arg), 44 | call = call, 45 | arg = arg 46 | ) 47 | } 48 | } 49 | 50 | parse_xml_one <- function(info) { 51 | out <- parse_xml(info) 52 | out <- xml_children(out) 53 | 54 | if (length(out) != 1) { 55 | abort("XML document must be length 1.") 56 | } 57 | 58 | out[[1]] 59 | } 60 | 61 | xml_attr_int <- function(data, attr) { 62 | as.integer(xml_attr(data, attr)) 63 | } 64 | 65 | xml_line1 <- function(data) { 66 | xml_attr_int(data, "line1") 67 | } 68 | xml_line2 <- function(data) { 69 | xml_attr_int(data, "line2") 70 | } 71 | xml_col1 <- function(data) { 72 | xml_attr_int(data, "col1") 73 | } 74 | xml_col2 <- function(data) { 75 | xml_attr_int(data, "col2") 76 | } 77 | xml_start <- function(data) { 78 | xml_attr_int(data, "start") 79 | } 80 | xml_end <- function(data) { 81 | xml_attr_int(data, "end") 82 | } 83 | 84 | as_position <- function(line, col, ..., data) { 85 | check_dots_empty() 86 | 87 | max <- max_col(data) + 1L 88 | line * max + col 89 | } 90 | 91 | # Useful to recreate a position in the same dimension than 92 | # xml_parse_data()'s `start` and `end` attributes 93 | max_col <- function(data) { 94 | nodes <- xml_find_all(data, "//*") 95 | 96 | max( 97 | xml_col1(nodes), 98 | xml_col2(nodes), 99 | na.rm = TRUE 100 | ) 101 | } 102 | 103 | node_positions <- function(data) { 104 | data.frame( 105 | line1 = xml_line1(data), 106 | col1 = xml_col1(data), 107 | line2 = xml_line2(data), 108 | col2 = xml_col2(data), 109 | start = xml_start(data), 110 | end = xml_end(data) 111 | ) 112 | } 113 | 114 | df_pos <- function(line, col) { 115 | data.frame( 116 | line = line, 117 | col = col 118 | ) 119 | } 120 | as_df_pos <- function(data) { 121 | df_pos( 122 | line = xml_line1(data), 123 | col = xml_col1(data) 124 | ) 125 | } 126 | as_df_pos2 <- function(data) { 127 | df_pos( 128 | line = xml_line2(data), 129 | col = xml_col2(data) 130 | ) 131 | } 132 | 133 | merge_positions <- function(pos) { 134 | line1 <- min(pos$line1) 135 | line2 <- max(pos$line2) 136 | 137 | min_lines <- pos$line1 == line1 138 | max_lines <- pos$line2 == line2 139 | 140 | col1 <- min(pos$col1[min_lines]) 141 | start <- min(pos$start[min_lines]) 142 | 143 | col2 <- max(pos$col2[max_lines]) 144 | end <- max(pos$end[max_lines]) 145 | 146 | data.frame( 147 | line1 = line1, 148 | col1 = col1, 149 | line2 = line2, 150 | col2 = col2, 151 | start = start, 152 | end = end 153 | ) 154 | } 155 | 156 | node_at_position <- function(line, col, ..., data) { 157 | all <- xml_find_all(data, "//*") 158 | loc <- locate_node(all, line, col, data = data) 159 | 160 | if (loc) { 161 | all[[loc]] 162 | } else { 163 | NULL 164 | } 165 | } 166 | 167 | is_delim_open <- function(data) { 168 | xml_name(data) %in% delim_open_node_names 169 | } 170 | delim_open_node_names <- c( 171 | "OP-LEFT-PAREN", 172 | "OP-LEFT-BRACE", 173 | "OP-LEFT-BRACKET", 174 | "LBB" 175 | ) 176 | 177 | is_delim_close <- function(data) { 178 | xml_name(data) %in% delim_close_node_names 179 | } 180 | delim_close_node_names <- c( 181 | "OP-RIGHT-PAREN", 182 | "OP-RIGHT-BRACE", 183 | "OP-RIGHT-BRACKET" 184 | ) 185 | 186 | is_prefix_fn <- function(data) { 187 | xml_name(data) %in% prefix_fn_node_names 188 | } 189 | prefix_fn_node_names <- c( 190 | "FUNCTION", 191 | "IF", 192 | "FOR", 193 | "WHILE" 194 | ) 195 | 196 | is_terminal <- function(data) { 197 | !xml_name(data) %in% non_terminal_node_names 198 | } 199 | 200 | # LBB is technically non-terminal 201 | non_terminal_node_names <- c( 202 | "expr", 203 | "exprlist", 204 | "expr_or_help", 205 | "expr_or_assign_or_help", 206 | "formlist", 207 | "sublist", 208 | "cond", 209 | "ifcond", 210 | "forcond" 211 | ) 212 | 213 | node_non_terminal_parent <- function(node) { 214 | if (is_terminal(node) && !is.na(parent <- node_parent(node))) { 215 | parent 216 | } else { 217 | node 218 | } 219 | } 220 | 221 | node_parent <- function(node) { 222 | if (is.na(node)) { 223 | node 224 | } else { 225 | xml_find_first(node, "./parent::*") 226 | } 227 | } 228 | 229 | node_children <- function(data) { 230 | if (inherits(data, "xml_nodeset")) { 231 | data 232 | } else { 233 | xml_children(data) 234 | } 235 | } 236 | 237 | node_text <- function(data, ..., info) { 238 | lines <- node_text_lines(data, ..., info = info) 239 | paste(lines, collapse = "\n") 240 | } 241 | node_text_lines <- function(data, ..., info) { 242 | check_dots_empty() 243 | 244 | pos <- node_positions(data) 245 | pos <- merge_positions(pos) 246 | 247 | if (nrow(pos) != 1) { 248 | abort("Can't find positions in `data`.") 249 | } 250 | 251 | lines <- lines(info) 252 | line_range <- pos$line1:pos$line2 253 | lines <- lines[line_range] 254 | 255 | if (!length(lines)) { 256 | abort("Can't find text in `data`.") 257 | } 258 | 259 | n <- length(lines) 260 | lines[[n]] <- substr(lines[[n]], 1, pos$col2) 261 | lines[[1]] <- substr(lines[[1]], pos$col1, nchar(lines[[1]])) 262 | 263 | lines 264 | } 265 | 266 | node_list_text <- function(data, ..., info) { 267 | lapply(data, node_text, info = info) 268 | } 269 | 270 | locate_node <- function(set, line, col, ..., data) { 271 | check_dots_empty() 272 | 273 | if (!length(set)) { 274 | return(0L) 275 | } 276 | 277 | pos <- node_positions(set) 278 | 279 | start <- pos$start 280 | end <- pos$end 281 | cursor <- as_position(line, col, data = data) 282 | 283 | in_range <- cursor >= start & cursor <= end 284 | if (!any(in_range, na.rm = TRUE)) { 285 | return(0L) 286 | } 287 | 288 | width <- end - start 289 | min_width <- min(width[in_range], na.rm = TRUE) 290 | innermost <- which(width == min_width & in_range) 291 | 292 | # In case of multiple matches (e.g. an expr with literal node as 293 | # single child), select innermost 294 | innermost[[length(innermost)]] 295 | } 296 | 297 | check_node <- function(node, 298 | arg = caller_arg(node), 299 | call = caller_env()) { 300 | if (!inherits(node, "xml_node")) { 301 | abort( 302 | sprintf("`%s` must be an XML node.", arg), 303 | call = call, 304 | arg = arg 305 | ) 306 | } 307 | } 308 | 309 | check_node_set <- function(set, 310 | arg = caller_arg(set), 311 | call = caller_env()) { 312 | if (!inherits(set, "xml_nodeset")) { 313 | abort( 314 | sprintf("`%s` must be an XML nodeset.", arg), 315 | call = call, 316 | arg = arg 317 | ) 318 | } 319 | } 320 | 321 | check_node_or_nodeset <- function(node, 322 | arg = caller_arg(node), 323 | call = caller_env()) { 324 | if (!inherits_any(node, c("xml_node", "xml_nodeset"))) { 325 | abort( 326 | sprintf("`%s` must be an XML node or nodeset.", arg), 327 | call = call, 328 | arg = arg 329 | ) 330 | } 331 | } 332 | 333 | tree_prefix <- function(node) { 334 | nodes <- xml_find_all(node, "//*") 335 | loc <- detect_index(nodes, function(x) identical(x, node)) 336 | 337 | if (loc) { 338 | nodes[seq(1, loc)] 339 | } else { 340 | nodes[0] 341 | } 342 | } 343 | 344 | tree_suffix <- function(node) { 345 | nodes <- xml_find_all(node, "//*") 346 | loc <- detect_index(nodes, function(x) identical(x, node)) 347 | 348 | if (loc) { 349 | nodes[seq(loc, length(nodes))] 350 | } else { 351 | nodes[0] 352 | } 353 | } 354 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/reshape-call.md: -------------------------------------------------------------------------------- 1 | # can reshape call longer 2 | 3 | Code 4 | print_longer("()") 5 | Output 6 | foofybaz() 7 | 8 | function() NULL 9 | Code 10 | print_longer("(a)") 11 | Output 12 | foofybaz( 13 | a 14 | ) 15 | 16 | function( 17 | a 18 | ) NULL 19 | Code 20 | print_longer("(b, c)") 21 | Output 22 | foofybaz( 23 | b, 24 | c 25 | ) 26 | 27 | function( 28 | b, 29 | c 30 | ) NULL 31 | Code 32 | print_longer("(a, b, c)") 33 | Output 34 | foofybaz( 35 | a, 36 | b, 37 | c 38 | ) 39 | 40 | function( 41 | a, 42 | b, 43 | c 44 | ) NULL 45 | Code 46 | print_longer("(a = 1, b, c = 3)") 47 | Output 48 | foofybaz( 49 | a = 1, 50 | b, 51 | c = 3 52 | ) 53 | 54 | function( 55 | a = 1, 56 | b, 57 | c = 3 58 | ) NULL 59 | Code 60 | # Leading indentation is preserved. First line is not indented 61 | # because the reshaped text is meant to be inserted at the node 62 | # coordinates. 63 | print_longer(" ()") 64 | Output 65 | foofybaz() 66 | 67 | function() NULL 68 | Code 69 | print_longer(" (a)") 70 | Output 71 | foofybaz( 72 | a 73 | ) 74 | 75 | function( 76 | a 77 | ) NULL 78 | Code 79 | print_longer(" (a, b)") 80 | Output 81 | foofybaz( 82 | a, 83 | b 84 | ) 85 | 86 | function( 87 | a, 88 | b 89 | ) NULL 90 | Code 91 | # Multiline args are indented as is 92 | print_longer("(a, b = foo(\n bar\n), c)") 93 | Output 94 | foofybaz( 95 | a, 96 | b = foo( 97 | bar 98 | ), 99 | c 100 | ) 101 | 102 | function( 103 | a, 104 | b = foo( 105 | bar 106 | ), 107 | c 108 | ) NULL 109 | Code 110 | print_longer("(a, b =\n 2, c)") 111 | Output 112 | foofybaz( 113 | a, 114 | b = 115 | 2, 116 | c 117 | ) 118 | 119 | function( 120 | a, 121 | b = 122 | 2, 123 | c 124 | ) NULL 125 | Code 126 | print_longer(" (a, b = foo(\n bar \n ), c)") 127 | Output 128 | foofybaz( 129 | a, 130 | b = foo( 131 | bar 132 | ), 133 | c 134 | ) 135 | 136 | function( 137 | a, 138 | b = foo( 139 | bar 140 | ), 141 | c 142 | ) NULL 143 | Code 144 | # Wrong indentation is preserved 145 | print_longer("(a, b = foo(\nbar\n), c)") 146 | Output 147 | foofybaz( 148 | a, 149 | b = foo( 150 | bar 151 | ), 152 | c 153 | ) 154 | 155 | function( 156 | a, 157 | b = foo( 158 | bar 159 | ), 160 | c 161 | ) NULL 162 | Code 163 | print_longer(" (a, b = foo(\n bar\n), c)") 164 | Output 165 | foofybaz( 166 | a, 167 | b = foo( 168 | bar 169 | ), 170 | c 171 | ) 172 | 173 | function( 174 | a, 175 | b = foo( 176 | bar 177 | ), 178 | c 179 | ) NULL 180 | 181 | # can reshape call longer (L shape) 182 | 183 | Code 184 | print_longer_l("()") 185 | Output 186 | foofybaz() 187 | 188 | function() NULL 189 | Code 190 | print_longer_l("(a)") 191 | Output 192 | foofybaz(a) 193 | 194 | function(a) NULL 195 | Code 196 | print_longer_l("(a, b)") 197 | Output 198 | foofybaz(a, 199 | b) 200 | 201 | function(a, 202 | b) NULL 203 | Code 204 | print_longer_l("(a, b, c)") 205 | Output 206 | foofybaz(a, 207 | b, 208 | c) 209 | 210 | function(a, 211 | b, 212 | c) NULL 213 | Code 214 | print_longer_l("(a = 1, b, c = 3)") 215 | Output 216 | foofybaz(a = 1, 217 | b, 218 | c = 3) 219 | 220 | function(a = 1, 221 | b, 222 | c = 3) NULL 223 | Code 224 | # Leading indentation is preserved. First line is not indented 225 | # because the reshaped text is meant to be inserted at the node 226 | # coordinates. 227 | print_longer_l(" ()") 228 | Output 229 | foofybaz() 230 | 231 | function() NULL 232 | Code 233 | print_longer_l(" (a)") 234 | Output 235 | foofybaz(a) 236 | 237 | function(a) NULL 238 | Code 239 | print_longer_l(" (a, b)") 240 | Output 241 | foofybaz(a, 242 | b) 243 | 244 | function(a, 245 | b) NULL 246 | Code 247 | # Multiline args are indented as is 248 | print_longer_l("(a, b = foo(\n bar\n), c)") 249 | Output 250 | foofybaz(a, 251 | b = foo( 252 | bar 253 | ), 254 | c) 255 | 256 | function(a, 257 | b = foo( 258 | bar 259 | ), 260 | c) NULL 261 | Code 262 | print_longer_l("(a, b =\n 2, c)") 263 | Output 264 | foofybaz(a, 265 | b = 266 | 2, 267 | c) 268 | 269 | function(a, 270 | b = 271 | 2, 272 | c) NULL 273 | Code 274 | print_longer_l(" (a, b = foo(\n bar \n ), c)") 275 | Output 276 | foofybaz(a, 277 | b = foo( 278 | bar 279 | ), 280 | c) 281 | 282 | function(a, 283 | b = foo( 284 | bar 285 | ), 286 | c) NULL 287 | Code 288 | # Wrong indentation is preserved 289 | print_longer_l("(a, b = foo(\nbar\n), c)") 290 | Output 291 | foofybaz(a, 292 | b = foo( 293 | bar 294 | ), 295 | c) 296 | 297 | function(a, 298 | b = foo( 299 | bar 300 | ), 301 | c) NULL 302 | Code 303 | print_longer_l(" (a, b = foo(\n bar\n), c)") 304 | Output 305 | foofybaz(a, 306 | b = foo( 307 | bar 308 | ), 309 | c) 310 | 311 | function(a, 312 | b = foo( 313 | bar 314 | ), 315 | c) NULL 316 | 317 | # can reshape call wider 318 | 319 | Code 320 | print_wider("()") 321 | Output 322 | foofybaz() 323 | 324 | function() NULL 325 | Code 326 | print_wider("(\n a\n)") 327 | Output 328 | foofybaz(a) 329 | 330 | function(a) NULL 331 | Code 332 | print_wider("(\n\n a\n\n)") 333 | Output 334 | foofybaz(a) 335 | 336 | function(a) NULL 337 | Code 338 | print_wider("(\n a, \n b\n)") 339 | Output 340 | foofybaz(a, b) 341 | 342 | function(a, b) NULL 343 | Code 344 | print_wider("(\n a, \n b, \n c\n)") 345 | Output 346 | foofybaz(a, b, c) 347 | 348 | function(a, b, c) NULL 349 | Code 350 | print_wider("(\n a = 1,\n b,\n c = 3\n)") 351 | Output 352 | foofybaz(a = 1, b, c = 3) 353 | 354 | function(a = 1, b, c = 3) NULL 355 | Code 356 | # Leading indentation is ignored 357 | print_wider(" ()") 358 | Output 359 | foofybaz() 360 | 361 | function() NULL 362 | Code 363 | print_wider(" (\n a\n)") 364 | Output 365 | foofybaz(a) 366 | 367 | function(a) NULL 368 | Code 369 | print_wider(" (\n\n a\n\n,\n b)") 370 | Output 371 | foofybaz(a, b) 372 | 373 | function(a, b) NULL 374 | Code 375 | # Multiline args are indented as is 376 | print_wider("(\n a,\n b = foo(\n bar\n ),\n c)") 377 | Output 378 | foofybaz(a, b = foo( 379 | bar 380 | ), c) 381 | 382 | function(a, b = foo( 383 | bar 384 | ), c) NULL 385 | Code 386 | print_wider("(\n a,\n b =\n 2,\n c\n)") 387 | Output 388 | foofybaz(a, b = 389 | 2, c) 390 | 391 | function(a, b = 392 | 2, c) NULL 393 | 394 | -------------------------------------------------------------------------------- /man/figures/README/reshape-def.svg: -------------------------------------------------------------------------------- 1 | foo<-function(a,b,c){NULL}foo<-function(a,b,c){foo<-function(a,b,c){ -------------------------------------------------------------------------------- /man/figures/README/move-reshape.svg: -------------------------------------------------------------------------------- 1 | foo<-function(){list(a=1,b=c(2,3))}list(a=1,b=c(2,3))list(a=1,b=c(2,3)) --------------------------------------------------------------------------------