1#' trace each call with a srcref attribute
2#'
3#' This function calls itself recursively so it can properly traverse the AST.
4#' @param x the call
5#' @param parent_functions the functions which this call is a child of.
6#' @param parent_ref argument used to set the srcref of the current call during
7#'   the recursion.
8#' @seealso <http://adv-r.had.co.nz/Expressions.html>
9#' @return a modified expression with count calls inserted before each previous
10#' call.
11#' @keywords internal
12trace_calls <- function (x, parent_functions = NULL, parent_ref = NULL) {
13
14  # Construct the calls by hand to avoid a NOTE from R CMD check
15  count <- function(key, val) {
16    call("if", TRUE,
17      call("{",
18        as.call(list(call(":::", as.symbol("covr"), as.symbol("count")), key)),
19        val
20      )
21    )
22  }
23
24  if (is.null(parent_functions)) {
25    parent_functions <- deparse(substitute(x))
26  }
27  recurse <- function(y) {
28    lapply(y, trace_calls, parent_functions = parent_functions)
29  }
30
31  if (is.atomic(x) || is.name(x)) {
32    if (is.null(parent_ref)) {
33      x
34    }
35    else {
36      if (is_na(x) || is_brace(x)) {
37        x
38      } else {
39        key <- new_counter(parent_ref, parent_functions) # nolint
40        count(key, x)
41      }
42    }
43  }
44  else if (is.call(x)) {
45    src_ref <- attr(x, "srcref") %||% impute_srcref(x, parent_ref)
46    if ((identical(x[[1]], as.name("<-")) || identical(x[[1]], as.name("="))) && # nolint
47      (is.call(x[[3]]) && identical(x[[3]][[1]], as.name("function")))) {
48      parent_functions <- c(parent_functions, as.character(x[[2]]))
49    }
50
51    # do not try to trace curly curly
52    if (identical(x[[1]], as.name("{")) && length(x) == 2 && is.call(x[[2]]) && identical(x[[2]][[1]], as.name("{"))) {
53      as.call(x)
54    } else if (!is.null(src_ref)) {
55      as.call(Map(trace_calls, x, src_ref, MoreArgs = list(parent_functions = parent_functions)))
56    } else if (!is.null(parent_ref)) {
57      key <- new_counter(parent_ref, parent_functions)
58      count(key, as.call(recurse(x)))
59    } else {
60      as.call(recurse(x))
61    }
62  }
63  else if (is.function(x)) {
64
65    # We cannot trace primitive functions
66    if (is.primitive(x)) {
67      return(x)
68    }
69
70    fun_body <- body(x)
71
72    if (!is.null(attr(x, "srcref")) &&
73       (is.symbol(fun_body) || !identical(fun_body[[1]], as.name("{")))) {
74      src_ref <- attr(x, "srcref")
75      key <- new_counter(src_ref, parent_functions)
76      fun_body <- count(key, trace_calls(fun_body, parent_functions))
77    } else {
78      fun_body <- trace_calls(fun_body, parent_functions)
79    }
80
81    new_formals <- trace_calls(formals(x), parent_functions)
82    if (is.null(new_formals)) new_formals <- list()
83    formals(x) <- new_formals
84    body(x) <- fun_body
85    x
86  }
87  else if (is.pairlist(x)) {
88    as.pairlist(recurse(x))
89  }
90  else if (is.expression(x)) {
91    as.expression(recurse(x))
92  }
93  else if (is.list(x)) {
94    recurse(x)
95  }
96  else {
97    message("Unknown language class: ", paste(class(x), collapse = "/"),
98      call. = FALSE)
99    x
100  }
101}
102
103.counters <- new.env(parent = emptyenv())
104
105#' initialize a new counter
106#'
107#' @param src_ref a [base::srcref()]
108#' @param parent_functions the functions that this srcref is contained in.
109#' @keywords internal
110new_counter <- function(src_ref, parent_functions) {
111  key <- key(src_ref)
112  .counters[[key]]$value <- 0
113  .counters[[key]]$srcref <- src_ref
114  .counters[[key]]$functions <- parent_functions
115  key
116}
117
118#' increment a given counter
119#'
120#' @param key generated with [key()]
121#' @keywords internal
122count <- function(key) {
123  .counters[[key]]$value <- .counters[[key]]$value + 1
124}
125
126#' clear all previous counters
127#'
128#' @keywords internal
129clear_counters <- function() {
130  rm(envir = .counters, list = ls(envir = .counters))
131}
132
133#' Generate a key for a  call
134#'
135#' @param x the srcref of the call to create a key for
136#' @keywords internal
137key <- function(x) {
138  paste(collapse = ":", c(get_source_filename(x), x))
139}
140
141f1 <- function() {
142  f2 <- function() {
143    2
144  }
145  f2()
146}
147