Start writing config pluck helpers (#2514)

* Refactor `yaml_character()` to `config_pluck_character()`
* Implement new `config_check_list()`
* Implement `config_pluck_string()`

R/build-home-index.R

@@ -97,61 +97,65 @@ data_home_sidebar <- function(pkg = ".", call = caller_env()) {
     return(sidebar_html)
   }
 
-  # compute any custom component
-  components <- pkg$meta$home$sidebar$components
+  custom <- pkg$meta$home$sidebar$components
+  sidebar_custom <- unwrap_purrr_error(purrr::map(
+    set_names(names2(custom)),
+    function(comp) {
+      data_home_component(
+        custom[[comp]],
+        error_pkg = pkg,
+        error_path = paste0("home.sidebar.components.", comp),
+        error_call = call
+      )
+    }
+  ))
+  sidebar_components <- utils::modifyList(sidebar_components, sidebar_custom)
 
-  sidebar_components <- utils::modifyList(
+  config_check_list(
     sidebar_components,
-    unwrap_purrr_error(purrr::map2(
-      components,
-      names(components),
-      data_home_component,
-      pkg = pkg,
-      call = call
-    )) %>%
-      set_names(names(components))
-  )
-
-  check_yaml_has(
-    setdiff(sidebar_structure, names(sidebar_components)),
-    where = c("home", "sidebar", "components"),
-    pkg = pkg,
-    call = call
+    has_names = sidebar_structure,
+    error_pkg = pkg,
+    error_path = "home.sidebar.components",
+    error_call = call
   )
 
   sidebar_final_components <- purrr::compact(
     sidebar_components[sidebar_structure]
   )
 
   paste0(sidebar_final_components, collapse = "\n")
-
 }
 
 # Update sidebar-configuration.Rmd if this changes
 default_sidebar_structure <- function() {
   c("links", "license", "community", "citation", "authors", "dev")
 }
 
-data_home_component <- function(component, component_name, pkg, call = caller_env()) {
-
-  check_yaml_has(
-    setdiff(c("title", "text"), names(component)),
-    where = c("home", "sidebar", "components", component_name),
-    pkg = pkg,
-    call = call
-  )
-
-  sidebar_section(
+data_home_component <- function(component,
+                                error_pkg,
+                                error_path,
+                                error_call = caller_env()) {
+  title <- config_check_string(
     component$title,
-    bullets = markdown_text_block(component$text)
+    error_pkg = error_pkg,
+    error_path = paste0(error_path, ".title"),
+    error_call = error_call
+  )
+  text <- config_check_string(
+    component$text,
+    error_pkg = error_pkg,
+    error_path = paste0(error_path, ".text"),
+    error_call = error_call
   )
+
+  sidebar_section(title, bullets = markdown_text_block(text))
 }
 
 data_home_sidebar_links <- function(pkg = ".") {
   pkg <- as_pkgdown(pkg)
 
   repo <- cran_link(pkg$package)
-  links <- purrr::pluck(pkg, "meta", "home", "links")
+  links <- config_pluck(pkg, "home.links")
 
   links <- c(
     link_url(sprintf(tr_("View on %s"), repo$repo), repo$url),

R/config.R

@@ -1,45 +1,126 @@
-check_yaml_has <- function(missing, where, pkg, call = caller_env()) {
-  if (length(missing) == 0) {
-    return()
-  }
+config_pluck <- function(pkg, path, default = NULL) {
+  check_string(path, allow_empty = FALSE, .internal = TRUE)
 
-  missing_components <- lapply(missing, function(x) c(where, x))
-  msg_flds <- purrr::map_chr(missing_components, paste, collapse = ".")
+  where <- strsplit(path, ".", fixed = TRUE)[[1]]
+  purrr::pluck(pkg$meta, !!!where, .default = default)
+}
 
-  config_abort(
-    pkg, 
-    "Can't find {cli::qty(missing)} component{?s} {.field {msg_flds}}.",
-    call = call
+config_pluck_character <- function(pkg,
+                                   path,
+                                   default = character(),
+                                   call = caller_env()) {
+  x <- config_pluck(pkg, path, default)
+  config_check_character(
+    x,
+    error_path = path,
+    error_pkg = pkg,
+    error_call = call
   )
 }
 
-yaml_character <- function(pkg, where) {
-  x <- purrr::pluck(pkg$meta, !!!where)
+config_pluck_string <- function(pkg,
+                                path,
+                                default = "",
+                                call = caller_env()) {
+  x <- config_pluck(pkg, path, default)
+  config_check_string(
+    x,
+    error_path = path,
+    error_pkg = pkg,
+    error_call = call
+  )
+}
+
+# checks ---------------------------------------------------------------------
 
-  if (identical(x, list()) || is.null(x)) {
+config_check_character <- function(x,
+                                   error_pkg,
+                                   error_path,
+                                   error_call = caller_env()) {
+  if (is.character(x)) {
+    x
+  } else if (identical(x, list())) {
     character()
-  } else if (is.character(x)) {
+  } else {
+    config_abort_type(
+      must_be = "a character vector",
+      not = x,
+      error_pkg = error_pkg,
+      error_path = error_path,
+      error_call = error_call
+    )
+  }
+}
+
+config_check_string <- function(x,
+                                error_pkg,
+                                error_path,
+                                error_call = caller_env()) {
+
+  if (is_string(x)) {
     x
   } else {
-    path <- paste0(where, collapse = ".")
+    config_abort_type(
+      must_be = "a string",
+      not = x,
+      error_pkg = error_pkg,
+      error_path = error_path,
+      error_call = error_call
+    )
+  }
+}
+
+config_abort_type <- function(must_be, not, error_pkg, error_path, error_call) {
+  not_str <- obj_type_friendly(not)
+  config_abort(
+    error_pkg,
+    "{.field {error_path}} must be {must_be}, not {not_str}.",
+    call = error_call
+  )
+
+}
+
+config_check_list <- function(x,
+                              has_names = NULL,
+                              error_pkg,
+                              error_path,
+                              error_call = caller_env()) {
+  if (is_list(x)) {
+    if (!is.null(has_names) && !all(has_name(x, has_names))) {
+      missing <- setdiff(has_names, names(x))
+      config_abort(
+        error_pkg,
+        c(
+          "{.field {error_path}} must have {cli::qty(has_names)} component{?s} {.str {has_names}}.",
+          "{length(missing)} missing component{?s}: {.str {missing}}."
+        ),
+        call = error_call
+      )
+    } else {
+      x
+    }
+  } else {
+    not <- obj_type_friendly(x)
     config_abort(
-      pkg,
-      "{.field {path}} must be a character vector.",
-      call = caller_env()
+      error_pkg,
+      "{.field {error_path}} must be a list, not {not}.",
+      call = error_call
     )
   }
 }
 
+# generic error ---------------------------------------------------------------
+
 config_abort <- function(pkg,
                          message,
                          ...,
                          call = caller_env(),
                          .envir = caller_env()) {
+
+  edit <- cli::format_inline("Edit {config_path(pkg)} to fix the problem.")
+
   cli::cli_abort(
-    c(
-      message,
-      i = "Edit {config_path(pkg)} to fix the problem."
-    ),
+    c(message, i = edit),
     ...,
     call = call,
     .envir = .envir

R/init.R

@@ -54,7 +54,7 @@ init_site <- function(pkg = ".") {
 
 copy_assets <- function(pkg = ".") {
   pkg <- as_pkgdown(pkg)
-  template <- purrr::pluck(pkg$meta, "template", .default = list())
+  template <- config_pluck(pkg, "template")
 
   # pkgdown assets
   if (!identical(template$default_assets, FALSE)) {

R/navbar.R

@@ -1,7 +1,7 @@
 data_navbar <- function(pkg = ".", depth = 0L) {
   pkg <- as_pkgdown(pkg)
 
-  navbar <- purrr::pluck(pkg, "meta", "navbar")
+  navbar <- config_pluck(pkg, "navbar")
 
   style <- navbar_style(
     navbar = navbar,
@@ -36,27 +36,29 @@ navbar_structure <- function() {
 }
 
 navbar_links <- function(pkg, depth = 0L) {
-  navbar <- purrr::pluck(pkg, "meta", "navbar")
-
   # Combine default components with user supplied
-  components <- navbar_components(pkg)
-  components_meta <- navbar$components %||% list()
-  components[names(components_meta)] <- components_meta
-  components <- purrr::compact(components)
+  components <- modify_list(
+    navbar_components(pkg),
+    config_pluck(pkg, "navbar.components")
+  )
 
   # Combine default structure with user supplied
-  pkg$meta$navbar$structure <- modify_list(navbar_structure(), pkg$meta$navbar$structure)
+  # (must preserve NULLs in yaml to mean display nothing)
+  pkg$meta$navbar$structure <- modify_list(
+    navbar_structure(),
+    config_pluck(pkg, "navbar.structure")
+  )
   right_comp <- intersect(
-    yaml_character(pkg, c("navbar", "structure", "right")),
+    config_pluck_character(pkg, "navbar.structure.right"),
     names(components)
   )
   left_comp <- intersect(
-    yaml_character(pkg, c("navbar", "structure", "left")),
+    config_pluck_character(pkg, "navbar.structure.left"),
     names(components)
   )
   # Backward compatibility
-  left <- navbar$left %||% components[left_comp]
-  right <- navbar$right %||% components[right_comp]
+  left <- config_pluck(pkg, "navbar.left") %||% components[left_comp]
+  right <- config_pluck(pkg, "navbar.right") %||% components[right_comp]
 
   list(
     left = render_navbar_links(

R/render.R

@@ -106,8 +106,8 @@ data_template <- function(pkg = ".", depth = 0L) {
     css = path_first_existing(pkg$src_path, "pkgdown", "extra.css"),
     js = path_first_existing(pkg$src_path, "pkgdown", "extra.js")
   )
-  out$includes <- purrr::pluck(pkg, "meta", "template", "includes", .default = list())
-  out$yaml <- purrr::pluck(pkg, "meta", "template", "params", .default = list())
+  out$includes <- config_pluck(pkg, "template.includes")
+  out$yaml <- config_pluck(pkg, "template.params")
   # Force inclusion so you can reliably refer to objects inside yaml
   # in the mustache templates
   out$yaml$.present <- TRUE

R/theme.R

@@ -56,7 +56,7 @@ bs_theme <- function(pkg = ".") {
 bs_theme_rules <- function(pkg) {
   paths <- path_pkgdown("BS5", "assets", "pkgdown.scss")
 
-  theme <- purrr::pluck(pkg, "meta", "template", "theme", .default = "arrow-light")
+  theme <- config_pluck_string(pkg, "template.theme", default = "arrow-light")
   theme_path <- path_pkgdown("highlight-styles", paste0(theme, ".scss"))
   if (!file_exists(theme_path)) {
     cli::cli_abort(c(
@@ -66,8 +66,8 @@ bs_theme_rules <- function(pkg) {
   }
   paths <- c(paths, theme_path)
 
-  package <- purrr::pluck(pkg, "meta", "template", "package")
-  if (!is.null(package)) {
+  package <- config_pluck_string(pkg, "template.package")
+  if (package != "") {
     package_extra <- path_package_pkgdown("extra.scss", package, pkg$bs_version)
     if (file_exists(package_extra)) {
       paths <- c(paths, package_extra)

tests/testthat/_snaps/build-home-index.md

@@ -75,7 +75,8 @@
       data_home_sidebar(pkg)
     Condition
       Error:
-      ! Can't find component home.sidebar.components.fancy.
+      ! home.sidebar.components must have component "fancy".
+      1 missing component: "fancy".
       i Edit _pkgdown.yml to fix the problem.
 
 ---
@@ -84,7 +85,8 @@
       data_home_sidebar(pkg)
     Condition
       Error:
-      ! Can't find components home.sidebar.components.fancy and home.sidebar.components.cool.
+      ! home.sidebar.components must have components "fancy" and "cool".
+      2 missing components: "fancy" and "cool".
       i Edit _pkgdown.yml to fix the problem.
 
 ---
@@ -93,7 +95,7 @@
       data_home_sidebar(pkg)
     Condition
       Error:
-      ! Can't find component home.sidebar.components.fancy.title.
+      ! home.sidebar.components.fancy.title must be a string, not `NULL`.
       i Edit _pkgdown.yml to fix the problem.
 
 ---
@@ -102,6 +104,6 @@
       data_home_sidebar(pkg)
     Condition
       Error:
-      ! Can't find components home.sidebar.components.fancy.title and home.sidebar.components.fancy.text.
+      ! home.sidebar.components.fancy.title must be a string, not `NULL`.
       i Edit _pkgdown.yml to fix the problem.