1
2# as future expansion becomes a thing, look into `selectr::parse(selector)`
3# https://github.com/sjp/selectr/blob/master/R/parser.R
4# selectr:::parse("#a.warning > b.mine:not(.theres) d")[[1]]$show()
5#> CombinedSelector[CombinedSelector[Class[Hash[Element[*]#a].warning] > Negation[Class[Element[b].mine]:not(Class[Element[*].theres])]] <followed> Element[d]]
6## ^^ R6 output
7
8SELECTOR_EVERYTHING <- "everything"
9SELECTOR_REGULAR <- "regular"
10
11SELECTOR_SPACE <- "space"
12SELECTOR_CHILD <- "child"
13
14selectorClass <- "htmltools.selector"
15selectorListClass <- "htmltools.selector.list"
16isSelector <- function(x) {
17  inherits(x, selectorClass)
18}
19isSelectorList <- function(x) {
20  inherits(x, selectorListClass)
21}
22
23# only handles id and classes
24asSelector <- function(selector) {
25  if (isSelector(selector) || isSelectorList(selector)) {
26    return(selector)
27  }
28
29  # make sure it's a trimmed string
30  selector <- txt_trim(paste0(selector, collapse = " "))
31
32  if (txt_detect(selector, ",", fixed = TRUE)) {
33    stop("CSS selectors that contain `,` aren't (yet) implemented.", call. = FALSE)
34  }
35  if (txt_detect(selector, "[", fixed = TRUE)) {
36    stop("CSS selectors that contain `[` aren't (yet) implemented.", call. = FALSE)
37  }
38  if (txt_detect(selector, "~", fixed = TRUE)) {
39    stop("CSS selectors that contain `~` aren't (yet) implemented.", call. = FALSE)
40  }
41  if (txt_detect(selector, "+", fixed = TRUE)) {
42    stop("CSS selectors that contain `+` aren't (yet) implemented.", call. = FALSE)
43  }
44  if (txt_detect(selector, ":", fixed = TRUE)) {
45    stop(
46      "Pseudo CSS selectors (e.g., `:first-child`, `:not()`, etc)",
47      " aren't (yet) implemented.",
48      call. = FALSE
49    )
50  }
51
52  # Check here to avoid inf recursion
53  if (txt_detect(selector, ">", fixed = TRUE)) {
54    # If there is a `>`, pad it with spaces
55    if (txt_detect(selector, "(^>)|(>$)")) {
56      stop(
57        "Direct children selector, `>`, must not be the first element or last element",
58        " in a css selector. Please add more selector information, such as `*`."
59      )
60    }
61    # While there are any consecutive `> >` items...
62    while(txt_detect(selector, ">\\s*>")) {
63      # If there are any `>>`, replace them with `> * >`
64      selector <- txt_replace_all(selector, ">\\s*>", "> * >")
65    }
66
67    # Split by `>` and convert to selectors
68    # Alter parts (execpt first) to say they are a direct child
69    # Return selector list
70    selectorItems <- lapply(strsplit(selector, ">")[[1]], asSelector)
71    selectorListItems <- Map(
72      selectorItems,
73      seq_along(selectorItems),
74      f = function(selectorItem, i) {
75        if (isSelector(selectorItem)) {
76          if (i > 1) selectorItem$traversal <- SELECTOR_CHILD
77          asSelectorList(selectorItem)
78        } else {
79          if (i > 1) selectorItem[[1]]$traversal <- SELECTOR_CHILD
80          selectorItem
81        }
82      }
83    )
84    selectorList <- asSelectorList(
85      unlist(selectorListItems, recursive = FALSE, use.names = FALSE)
86    )
87    return(selectorList)
88  }
89
90  # Split into a selector parts and recurse one more time
91  if (txt_detect(selector, "\\s")) {
92    selectorItems <- lapply(strsplit(selector, "\\s+")[[1]], asSelector)
93    selectorList <- asSelectorList(selectorItems)
94    return(selectorList)
95  }
96
97  # https://www.w3.org/TR/selectors-3/#selectors
98
99  type <- NULL
100  traversal <- SELECTOR_SPACE
101  element <- NULL
102  id <- NULL
103  classes <- NULL
104
105  if (isTRUE(selector == "*")) {
106    type <- SELECTOR_EVERYTHING
107  } else {
108    type <- SELECTOR_REGULAR
109
110    ## Not needed as the regex values below work around this.
111    # # if there is more than a `*`, such as `*.warning`, treat as `.warning`
112    # if (txt_detect(selector, "^\\*"))
113    #   selector <- sub("^\\*", "", selector)
114    #   if (grepl("^\\*", selector)) {
115    #     stop("malformed css selector. Found at least two `**` that were not separated by a space")
116    #   }
117    # }
118
119    elementRegex <- "^[a-zA-Z0-9]+"
120    element <- txt_match_first(selector, elementRegex)
121    if (!is.null(element)) {
122      selector <- txt_remove(selector, elementRegex)
123    }
124
125    ## https://www.w3.org/TR/CSS21/syndata.html#value-def-identifier
126    ##  In CSS, identifiers (including element names, classes, and IDs in selectors) can contain only the characters [a-zA-Z0-9] and ISO 10646 characters U+00A0 and higher, plus the hyphen (-) and the underscore (_); they cannot start with a digit, two hyphens, or a hyphen followed by a digit. Identifiers can also contain escaped characters and any ISO 10646 character as a numeric code (see next item). For instance, the identifier "B&W?" may be written as "B\&W\?" or "B\26 W\3F".
127    # # define simpler (maybe not accurate) regex
128    # id_regex <- "^#[^#.:[\\s]+" # `#` then everything that isn't a `#`, `.`, `:`, or white space
129    # class_regex <- "^\\.[^#.:[\\s]+" # `.` then everything that isn't a `.`, `:`, or white space
130
131    tmpId <- txt_match_first(selector, "#[^.:[]+")
132    if (!is.null(tmpId)) {
133      id <- txt_remove(tmpId, "^#")
134      selector <- txt_remove(selector, tmpId, fixed = TRUE)
135    }
136
137    classes <- txt_remove(txt_match_all(selector, "\\.[^.:[]+"), "^\\.")
138    if (length(classes) == 0) {
139      classes <- NULL
140    }
141    # if (!is.null(classes)) {
142    #   selector <- txt_remove(selector, "\\.[^.:[]+")
143    # }
144  }
145
146  structure(class = selectorClass, list(
147    element = element,
148    id = id,
149    classes = classes,
150    type = type,
151    traversal = traversal
152  ))
153}
154
155
156asSelectorList <- function(selector) {
157  if (isSelectorList(selector)) {
158    return(selector)
159  }
160  if (is.character(selector)) {
161    selector <- asSelector(selector)
162  }
163  if (isSelector(selector)) {
164    selector <- list(selector)
165  }
166  if (!is.list(selector)) {
167    stop("Do not know how to convert non list object into a `htmltools.selector.list`")
168  }
169
170  isSelectorVals <- vapply(selector, isSelector, logical(1))
171  if (!all(isSelectorVals)) {
172    stop("Can only convert a list of selectors to a `htmltools.selector.list`")
173  }
174  structure(class = selectorListClass, selector)
175}
176
177#' @export
178format.htmltools.selector <- function(x, ...) {
179  paste0(
180    c(
181      if (x$traversal == SELECTOR_CHILD) "> ",
182      if (x$type == SELECTOR_EVERYTHING) {
183        "*"
184      } else {
185        paste0(c(
186          x$element,
187          if (!is.null(x$id)) paste0("#", x$id),
188          if (!is.null(x$classes)) paste0(".", x$classes)
189        ))
190      }
191    ),
192    collapse = ""
193  )
194}
195#' @export
196format.htmltools.selector.list <- function(x, ...) {
197  paste0(as.character(lapply(x, format, ...)), collapse = " ")
198}
199
200#' @export
201print.htmltools.selector <- function(x, ...) {
202  cat("// htmltools css selector\n")
203  cat(format(x, ...), "\n")
204}
205#' @export
206print.htmltools.selector.list <- function(x, ...) {
207  cat("// htmltools css selector list\n")
208  cat(format(x, ...), "\n")
209}
210
211
212
213# When `fixed = TRUE`, `sub()`, `gsub()`, `grepl()` perform ~4x faster
214# #> bench::mark(grepl("* ", "A B * C"), grepl("* ", "A B * C", fixed = TRUE))
215#   expression                               min median
216#   <bch:expr>                           <bch:t> <bch:>
217# 1 grepl("* ", "A B * C")                3.91µs 5.23µs
218# 2 grepl("* ", "A B * C", fixed = TRUE)   1.1µs 1.34µs
219txt_replace <- function(text, pattern, replacement, fixed = FALSE) {
220  sub(pattern = pattern, replacement = replacement, x = text, perl = !fixed, fixed = fixed)
221}
222
223txt_replace_all <- function(text, pattern, replacement, fixed = FALSE) {
224  gsub(pattern = pattern, replacement = replacement, x = text, perl = !fixed, fixed = fixed)
225}
226
227txt_remove <- function(x, pattern, ...) {
228  txt_replace(x, pattern, "", ...)
229}
230txt_remove_all <- function(x, pattern, ...) {
231  txt_replace_all(x, pattern, "", ...)
232}
233
234trim_leading <- function(text) {
235  txt_remove_all(text, pattern = "^\\s+")
236}
237
238trim_trailing <- function(text) {
239  txt_remove_all(text, pattern = "\\s+$")
240}
241
242txt_trim <- function(text, side = "both") {
243  if (side == "both" || side == "left") {
244    text <- trim_leading(text)
245  }
246  if (side == "both" || side == "right") {
247    text <- trim_trailing(text)
248  }
249  text
250}
251
252txt_detect <- function(text, pattern, fixed = FALSE) {
253  grepl(pattern = pattern, x = text, perl = !fixed, fixed = fixed)
254}
255
256# finds first, NOT all
257txt_match_first <- function(x, pattern, ...) {
258  regInfo <- regexpr(pattern, x, ...)
259  if (length(regInfo) == 1 && regInfo == -1) {
260    return(NULL)
261  }
262
263  regmatches(x, regInfo)
264}
265
266# return a vector of matches or NULL
267txt_match_all <- function(x, pattern, ...) {
268  if (length(x) != 1) {
269    stop("`x` must have a length of 1")
270  }
271  regInfo <- gregexpr(pattern, x, ...)
272  first <- regInfo[[1]]
273  if (length(first) == 1 && first == -1) {
274    return(NULL)
275  }
276
277  regmatches(x, regInfo)[[1]]
278}
279