add tree-sitter tag parser for #4

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: pkgstats
 Title: Metrics of R Packages
-Version: 0.1.6.017
+Version: 0.1.6.021
 Authors@R: 
     person("Mark", "Padgham", , "[email protected]", role = c("aut", "cre"),
            comment = c(ORCID = "0000-0003-2172-5265"))
@@ -25,6 +25,8 @@ Imports:
     methods,
     readr,
     sys,
+    treesitter,
+    treesitter.r,
     withr
 Suggests: 
     callr,

R/external-calls.R

@@ -1,4 +1,3 @@
-
 #' Map calls from within each function to external packages
 #'
 #' @param path Path to package being analysed
@@ -8,19 +7,37 @@
 #' @noRd
 external_call_network <- function (tags_r, path, pkg_name) {
 
-    calls <- extract_call_content (tags_r)
+    tags_are_treesitter <- "grammar_type" %in% names (tags_r)
+
+    if (tags_are_treesitter) {
+        calls <- data.frame (
+            tags_line = tags_r$start,
+            call = tags_r$node_text,
+            tag = tags_r$grammar_type,
+            file = paste0 ("R/", basename (tags_r$file))
+        )
+        tags_r$kind <- "function"
+        index <- seq_len (nrow (tags_r))
+    } else { # ctags
+        calls <- extract_call_content (tags_r)
+        index <- calls$tags_line
+    }
 
     if (length (calls) == 0L || nrow (calls) == 0L) {
         return (NULL)
     }
 
-    calls$kind <- tags_r$kind [calls$tags_line]
-    calls$start <- tags_r$start [calls$tags_line]
-    calls$end <- tags_r$end [calls$tags_line]
+    calls$kind <- tags_r$kind [index]
+    calls$start <- tags_r$start [index]
+    calls$end <- tags_r$end [index]
 
     calls$package <- NA_character_
-    pkg_fns <- unique (tags_r$tag [tags_r$kind == "function"])
-    pkg_fns <- pkg_fns [which (!grepl ("^anonFunc", pkg_fns))]
+    if (tags_are_treesitter) {
+        pkg_fns <- unique (tags_r$fn_name)
+    } else {
+        pkg_fns <- unique (tags_r$tag [tags_r$kind == "function"])
+        pkg_fns <- pkg_fns [which (!grepl ("^anonFunc", pkg_fns))]
+    }
     calls$package [which (calls$call %in% pkg_fns)] <- pkg_name
 
     calls <- add_base_recommended_pkgs (calls)
@@ -39,6 +56,13 @@
 
     calls <- calls [which (!is.na (calls$package)), ]
 
+    # Some of these from tree-sitter flag sub-setting operations as calls;
+    # these are removed here:
+    index <- grep ("\\\"|\\(|\\)|\\]|\\]", calls$call)
+    if (length (index) > 0L) {
+        calls <- calls [-index, ]
+    }
+
     rownames (calls) <- NULL
 
     return (calls)

R/tag-data-tree-sitter.R

@@ -0,0 +1,91 @@
+#' Get tags using tree-sitter
+#'
+#' Currently extracts tags from the "R" directory only, and only for R-language files.
+#'
+#' @inheritParams tags_data
+#' @noRd
+get_treesitter_tags <- function (path) {
+
+    language <- treesitter.r::language ()
+    parser <- treesitter::parser (language)
+
+    tree_sitter_calls (parser, path)
+}
+
+tree_sitter_calls <- function (parser, path, d = "R") {
+    flist <- fs::dir_ls (fs::path (path, d), pattern = "\\.R$")
+    fn_calls <- lapply (flist, function (f) {
+        parse_list <- control_parse (f)
+        fn_calls <- lapply (parse_list, function (p) {
+            txt <- paste0 (as.character (p), collapse = "\n")
+            tree <- treesitter::parser_parse (parser, txt)
+            walk_one_tree (tree)
+        })
+        res <- do.call (rbind, fn_calls)
+        cbind (file = rep (f, nrow (res)), res)
+    })
+    fn_calls <- do.call (rbind, fn_calls)
+    rownames (fn_calls) <- NULL
+    return (fn_calls)
+}
+
+walk_one_tree <- function (tree) {
+
+    it <- treesitter::tree_walk (tree)
+
+    get_row_start_end <- function (it) {
+        point_start <- treesitter::node_start_point (it$node ())
+        point_end <- treesitter::node_end_point (it$node ())
+        c (treesitter::point_row (point_start), treesitter::point_row (point_end))
+    }
+
+    reached_foot <- FALSE
+    first_identifier <- TRUE
+    get_next_open <- FALSE
+
+    grammar_types <- node_text <- next_open <- fn_name <- character (0L)
+    row_start <- row_end <- integer (0L)
+
+    while (!reached_foot) {
+        field_name <- NA_to_char (it$field_name ())
+        grammar_type <- NA_to_char (treesitter::node_grammar_type (it$node ()))
+        if (field_name == "function" && !grammar_type %in% c ("call", "extract_operator")) {
+            grammar_types <- c (grammar_types, grammar_type)
+            node_text <- c (node_text, treesitter::node_text (it$node ()))
+            row <- get_row_start_end (it)
+            row_start <- c (row_start, row [1L])
+            row_end <- c (row_end, row [1L])
+            get_next_open <- TRUE
+        } else if (grammar_type == "identifier" && first_identifier) {
+            fn_name <- treesitter::node_text (it$node ())
+            first_identifier <- FALSE
+        } else if (get_next_open && field_name == "open") {
+            next_open <- c (next_open, grammar_type)
+            get_next_open <- FALSE
+        }
+
+        if (it$goto_first_child ()) next
+        if (it$goto_next_sibling ()) next
+
+        retracing <- TRUE
+        while (retracing) {
+            if (!it$goto_parent ()) {
+                retracing <- FALSE
+                reached_foot <- TRUE
+            }
+            if (it$goto_next_sibling ()) {
+                retracing <- FALSE
+            }
+        }
+    }
+
+    # This line ensures fn_name is also length 0 when no data are parsed:
+    fn_name <- rep (fn_name, length (grammar_types))
+    data.frame (
+        fn_name = fn_name,
+        grammar_type = grammar_types,
+        node_text = node_text,
+        start = row_start,
+        end = row_end
+    ) [which (next_open != "["), ]
+}

R/tag-data.R

@@ -1,4 +1,3 @@
-
 #' use ctags and gtags to parse call data
 #'
 #' @param path Path to local repository
@@ -61,7 +60,8 @@ tags_data <- function (path, has_tabs = NULL, pkg_name = NULL) {
 
     tags_r <- withr::with_dir (path, get_ctags ("R", has_tabs))
 
-    external_calls <- external_call_network (tags_r, path, pkg_name)
+    tags_treesitter <- get_treesitter_tags (path)
+    external_calls <- external_call_network (tags_treesitter, path, pkg_name)
 
     tags_src <- withr::with_dir (path, get_ctags ("src", has_tabs))
     tags_inst <- withr::with_dir (path, get_ctags ("inst", has_tabs))

R/utils.R

@@ -1,3 +1,4 @@
+NA_to_char <- function (i) ifelse (is.na (i), "", i)
 
 get_Rd_metadata <- utils::getFromNamespace (".Rd_get_metadata", "tools") # nolint
 

codemeta.json

@@ -8,7 +8,7 @@
   "codeRepository": "https://github.com/ropensci-review-tools/pkgstats",
   "issueTracker": "https://github.com/ropensci-review-tools/pkgstats/issues",
   "license": "https://spdx.org/licenses/GPL-3.0",
-  "version": "0.1.6.017",
+  "version": "0.1.6.021",
   "programmingLanguage": {
     "@type": "ComputerLanguage",
     "name": "R",