-
Notifications
You must be signed in to change notification settings - Fork 7
/
print.R
133 lines (110 loc) · 3.46 KB
/
print.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
#' Pretty Print R Code in the Terminal
#'
#' Replace the standard print method for functions with one that performs
#' syntax highlighting, using ANSI colors, if the terminal supports them.
#'
#' @export
#' @param warn_conflicts logical. If \code{TRUE}, warnings are printed
#' about conflicts from replacing the standard print method.
prettycode <- function(warn_conflicts = TRUE) {
register_s3_method("prettycode", "print", "function", print.function)
if (! obj_name %in% search()) {
env <- new.env(parent = emptyenv())
env$print.function <- print.function
env$`!` <- exclam
do.call("attach", list(env, name = obj_name, warn.conflicts = warn_conflicts))
}
}
register_s3_method <- function(pkg, generic, class, fun = NULL) {
stopifnot(is.character(pkg), length(pkg) == 1)
envir <- asNamespace(pkg)
stopifnot(is.character(generic), length(generic) == 1)
stopifnot(is.character(class), length(class) == 1)
if (is.null(fun)) {
fun <- get(paste0(generic, ".", class), envir = parent.frame())
}
stopifnot(is.function(fun))
if (pkg %in% loadedNamespaces()) {
registerS3method(generic, class, fun, envir = envir)
}
# Always register hook in case package is later unloaded & reloaded
setHook(
packageEvent(pkg, "onLoad"),
function(...) {
registerS3method(generic, class, fun, envir = envir)
}
)
}
#' Print a function with syntax highlighting
#'
#' To turn on pretty printing of functions, you need to call
#' `prettycode::prettycode()`. It might be a good idea to call it
#' from your `.Rprofile`.
#'
#' @param x Function to print.
#' @param useSource Whether to use the stored source code, if available.
#' @param style The highlight style to use, see [default_style()].
#' @param ... Not used currently, for compatibility with the `print`
#' generic.
#' @return The function, invisibly.
#'
#' @importFrom utils capture.output
print.function <- function(x, useSource = TRUE,
style = default_style(), ...) {
if (!can_pretty_print()) return(base::print.function(x, useSource))
srcref <- getSrcref(x)
src <- if (useSource && ! is.null(srcref)) {
as.character(srcref)
} else {
deparse(x)
}
err <- FALSE
hisrc <- tryCatch(
highlight(src, style = style),
error = function(e) err <<- TRUE)
if (err) return(base::print.function(x, useSource))
## Environment of the function
if (!is.primitive(x)) {
hisrc <- c(hisrc, capture.output(print(environment(x))))
}
if (!should_page(hisrc)) {
cat(hisrc, sep = "\n")
} else {
cat(hisrc, sep = "\n", file = tmp <- tempfile())
on.exit(unlink(tmp), add = TRUE)
less <- Sys.getenv("LESS", NA_character_)
if (is.na(less)) {
on.exit(Sys.unsetenv("LESS"), add = TRUE)
} else {
on.exit(Sys.setenv(LESS = less), add = TRUE)
}
Sys.setenv(LESS = paste0("-R", if (!is.na(less)) less))
file.show(tmp)
}
invisible(x)
}
obj_name <- "tools:prettycode"
exclam <- function(x) {
if (is.function(x)) print.function(x) else base::`!`(x)
}
.onUnload <- function(package) {
if (obj_name %in% search()) {
do.call("detach", list(obj_name))
}
}
#' @importFrom crayon has_color
can_pretty_print <- function() {
has_color()
}
num_lines <- function() {
tryCatch(
as.numeric(system("tput lines", intern = TRUE)),
error = function(e) NA_integer_
)
}
should_page <- function(src) {
is_interactive() &&
is_terminal() &&
getOption("prettycode.should_page", TRUE) &&
(length(src) > num_lines())
}