@@ -60,21 +60,15 @@ return_linter <- function(
6060 return_style <- match.arg(return_style )
6161
6262 if (return_style == " implicit"
63- xpath <- "
64- (//FUNCTION | //OP-LAMBDA)
65- /following-sibling::expr[1][*[1][self::OP-LEFT-BRACE]]
66- /expr[last()][
67- expr[1][
68- not(OP-DOLLAR or OP-AT)
69- and SYMBOL_FUNCTION_CALL[text() = 'return']
70- ]
71- ]
72- "
73- msg <- " Use implicit return behavior; explicit return() is not needed."
63+ body_xpath <- " (//FUNCTION | //OP-LAMBDA)/following-sibling::expr[1]"
64+ # nolint next: object_usage. False positive from {codetools} says 'params' isn't used.
65+ params <- list (
66+ implicit = TRUE ,
67+ type = " style"
68+ lint_xpath = " SYMBOL_FUNCTION_CALL[text() = 'return']"
69+ lint_message = " Use implicit return behavior; explicit return() is not needed."
70+ )
7471 } else {
75- # See `?.onAttach`; these functions are all exclusively used for their
76- # side-effects, so implicit return is generally acceptable
77-
7872 except <- union(special_funs , except )
7973
8074 base_return_functions <- c(
@@ -94,80 +88,67 @@ return_linter <- function(
9488
9589 return_functions <- union(base_return_functions , return_functions )
9690
97- control_calls <- c(" IF" " FOR" " WHILE" " REPEAT"
98-
99- # from top, look for a FUNCTION definition that uses { (one-line
100- # function definitions are excepted), then look for failure to find
101- # return() on the last() expr of the function definition.
102- # exempt .onLoad which shows up in the tree like
103- # <expr><expr><SYMBOL>.onLoad</></><LEFT_ASSIGN></><expr><FUNCTION>...
104- # simple final expression (no control flow) must be
105- # <expr><expr> CALL( <expr> ) </expr></expr>
106- # NB: if this syntax _isn't_ used, the node may not be <expr>, hence
107- # the use of /*[...] below and self::expr here. position() = 1 is
108- # needed to guard against a few other cases.
109- # We also need to make sure that this expression isn't followed by a pipe
110- # symbol, which would indicate that we need to also check the last
111- # expression.
112- # pipe expressions are like
113- # ...
114- # <SPECIAL>%>%</SPECIAL>
115- # <expr><expr><SYMBOL_FUNCTION_CALL>return</SYMBOL_FUNCTION_CALL>
116- # </expr></expr>
117- # Unlike the following case, the return should be the last expression in
118- # the sequence.
119- # conditional expressions are like
120- # <expr><IF> ( <expr> ) <expr> [ <ELSE> <expr>] </expr>
121- # we require _any_ call to return() in either of the latter two <expr>, i.e.,
122- # we don't apply recursive logic to check every branch, only that the
123- # two top level branches have at least two return()s
124- # because of special 'in' syntax for 'for' loops, the condition is
125- # tagged differently than for 'if'/'while' conditions (simple PAREN)
126- xpath <- glue("
91+ body_xpath <- glue("
12792 (//FUNCTION | //OP-LAMBDA)[parent::expr[not(
12893 preceding-sibling::expr[SYMBOL[{ xp_text_in_table(except) }]]
12994 )]]
13095 /following-sibling::expr[OP-LEFT-BRACE and expr[last()]/@line1 != @line1]
13196 /expr[last()]
132- /*[
133- (
134- position() = 1
135- and (
136- (
137- { xp_or(paste0('self::', setdiff(control_calls, 'IF'))) }
138- ) or (
139- not({ xp_or(paste0('self::', control_calls)) })
140- and not(
141- following-sibling::PIPE
142- or following-sibling::SPECIAL[text() = '%>%']
143- )
144- and not(self::expr/SYMBOL_FUNCTION_CALL[
145- { xp_text_in_table(return_functions) }
146- ])
147- )
148- )
149- ) or (
150- preceding-sibling::IF
151- and self::expr
152- and position() > 4
153- and not(.//SYMBOL_FUNCTION_CALL[{ xp_text_in_table(return_functions) }])
154- )
155- ]
15697 " )
157- msg <- " All functions must have an explicit return()."
98+ params <- list (
99+ implicit = FALSE ,
100+ type = " warning"
101+ lint_xpath = glue(" self::*[not(
102+ (self::expr | following-sibling::SPECIAL[text() = '%>%']/following-sibling::expr/expr[1])
103+ /SYMBOL_FUNCTION_CALL[{ xp_text_in_table(return_functions) }]
104+ )]" ),
105+ lint_message = " All functions must have an explicit return()."
106+ )
158107 }
159108
160109 Linter(linter_level = " expression" function (source_expression ) {
161110 xml <- source_expression $ xml_parsed_content
162111 if (is.null(xml )) return (list ())
163112
164- xml_nodes <- xml_find_all(xml , xpath )
113+ body_expr <- xml_find_all(xml , body_xpath )
114+
115+ params $ source_expression <- source_expression
116+ # nested_return_lints not "vectorized" due to xml_children()
117+ lapply(body_expr , nested_return_lints , params )
118+ })
119+ }
120+
121+ nested_return_lints <- function (expr , params ) {
122+ child_expr <- xml_children(expr )
123+ if (length(child_expr ) == 0L ) {
124+ return (list ())
125+ }
126+ child_node <- xml_name(child_expr )
165127
128+ if (child_node [1L ] == " OP-LEFT-BRACE"
129+ expr_idx <- which(child_node %in% c(" expr" " equal_assign" " expr_or_assign_or_help"
130+ if (length(expr_idx ) == 0L ) { # empty brace expression {}
131+ if (params $ implicit ) {
132+ return (list ())
133+ } else {
134+ return (list (xml_nodes_to_lints(
135+ expr ,
136+ source_expression = params $ source_expression ,
137+ lint_message = params $ lint_message ,
138+ type = params $ type
139+ )))
140+ }
141+ }
142+ nested_return_lints(child_expr [[tail(expr_idx , 1L )]], params )
143+ } else if (child_node [1L ] == " IF"
144+ expr_idx <- which(child_node %in% c(" expr" " equal_assign" " expr_or_assign_or_help"
145+ lapply(child_expr [expr_idx [- 1L ]], nested_return_lints , params )
146+ } else {
166147 xml_nodes_to_lints(
167- xml_nodes ,
168- source_expression = source_expression ,
169- lint_message = msg ,
170- type = " style "
148+ xml_find_first( child_expr [[ 1L ]], params $ lint_xpath ) ,
149+ source_expression = params $ source_expression ,
150+ lint_message = params $ lint_message ,
151+ type = params $ type
171152 )
172- })
153+ }
173154}
0 commit comments