Trouver le projet quarto sans lancer quarto inspect (squash 1.3.1)

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: squash
 Title: Several Quarto As Single HTML
-Version: 1.3.0
+Version: 1.3.1
 Authors@R: c(
     person("Antoine", "Languillaume", , "antoine@thinkr.fr", role = c("aut", "cre")),
     person("Colin", "Fay", , "colin@thinkr.fr", role = "aut"),
@@ -32,6 +32,7 @@ Suggests:
     pagedown,
     rmarkdown,
     testthat,
+    withr,
     yesno
 VignetteBuilder:
     knitr

NAMESPACE

@@ -33,7 +33,6 @@ importFrom(purrr,map)
 importFrom(purrr,map_lgl)
 importFrom(purrr,walk)
 importFrom(purrr,walk2)
-importFrom(quarto,quarto_inspect)
 importFrom(quarto,quarto_render)
 importFrom(quarto,quarto_version)
 importFrom(rvest,html_attr)

NEWS.md

@@ -1,3 +1,7 @@
+# squash 1.3.1
+
+* Quarto project detection before compilation no longer runs one `quarto inspect` process per qmd folder: the project root is found by walking up the folders to the closest `_quarto.yml` or `_quarto.yaml`, which is the root `quarto inspect` reports (like quarto, the folders are those of the path as written, symlinks are not resolved). Measured on 10 chapter folders: 14.7 s down to 0.01 s, i.e. about 1.5 s saved per folder on every compilation.
+
 # squash 1.3.0
 
 * Each qmd is now rendered inside an isolated throwaway copy of the quarto project (option `squash.isolate_render`, `TRUE` by default). Concurrent renders no longer share the project state (`.quarto/` crossref index, `_extensions/` resolution), which removes the random `Failed to render` errors of parallel compilation (quarto-dev/quarto-cli#2749).

R/add_extension.R

@@ -3,7 +3,6 @@
 #' @param vec_qmd_path character. Path to the qmd files targeted for compilation
 #' @param quiet logical. Warn user of project status.
 #'
-#' @importFrom quarto quarto_inspect
 #' @importFrom cli cli_alert_info
 #' @importFrom purrr map map_lgl
 #' @importFrom fs dir_create

R/fetch_project.R

@@ -1,12 +1,15 @@
 #' List detected quarto project
 #'
+#' A folder belongs to the closest quarto project found by walking up its
+#' parents, a project being a folder holding a `_quarto.yml` or
+#' `_quarto.yaml`. This is the project root `quarto inspect` reports, found
+#' without spawning one quarto process per folder.
+#'
 #' @param vec_qmd_path character. Path to the qmd files targeted for compilation
 #' @param quiet logical. Warn user of project status.
 #'
-#' @importFrom quarto quarto_inspect
-#' @importFrom purrr map map_lgl
-#'
-#' @return List of quarto projects detected for each qmd.
+#' @return character. Quarto project root of each qmd, or the qmd folder
+#'   when it belongs to no project, without duplicates.
 #'
 #' @noRd
 #' @examples
@@ -31,23 +34,76 @@ fetch_project <- function(
   # _extensions will be added to project root
   qmd_dir <- unique(dirname(vec_qmd_path))
 
-  quarto_proj <- map(
-    .x = qmd_dir,
-    .f = \(x){
-      # return NULL if dir is not a quarto project
-      tryCatch(
-        expr = {
-          quarto_inspect(x)$dir
-        },
-        error = \(e){
-          NULL
-        }
-      )
-    }
-  ) |> as.vector()
+  quarto_proj <- vapply(
+    X = qmd_dir,
+    FUN = find_quarto_project_root,
+    FUN.VALUE = character(1),
+    USE.NAMES = FALSE
+  )
 
-  dir_is_proj <- !map_lgl(quarto_proj, is.null)
+  dir_is_proj <- !is.na(quarto_proj)
   qmd_proj_dir <- unique(c(qmd_dir[!dir_is_proj], quarto_proj[dir_is_proj]))
 
   return(qmd_proj_dir)
 }
+
+#' Find the root of the quarto project holding a folder
+#'
+#' @param dir character. A folder path.
+#'
+#' @return character. Absolute path of the closest parent folder (the
+#'   folder itself included) holding a `_quarto.yml` or `_quarto.yaml`,
+#'   `NA` when there is none. Like quarto, the parents are those of the
+#'   path as written: symlinks are not resolved.
+#'
+#' @noRd
+find_quarto_project_root <- function(dir) {
+  current <- absolute_path(dir)
+  repeat {
+    config_found <- file.exists(
+      file.path(current, c("_quarto.yml", "_quarto.yaml"))
+    )
+    if (any(config_found)) {
+      return(current)
+    }
+    parent <- dirname(current)
+    if (identical(x = parent, y = current)) {
+      return(NA_character_)
+    }
+    current <- parent
+  }
+}
+
+#' Make a path absolute without resolving symlinks
+#'
+#' @param path character. A path, relative to the working directory or
+#'   absolute.
+#'
+#' @return character. The absolute path, with `/` separators and the `.`
+#'   and `..` segments collapsed.
+#'
+#' @noRd
+absolute_path <- function(path) {
+  path <- gsub(pattern = "\\\\", replacement = "/", x = path)
+  if (!grepl(pattern = "^([A-Za-z]:)?/", x = path)) {
+    path <- file.path(gsub(pattern = "\\\\", replacement = "/", x = getwd()), path)
+  }
+  root <- regmatches(x = path, m = regexpr(pattern = "^([A-Za-z]:)?/", text = path))
+  segments <- strsplit(
+    x = substring(text = path, first = nchar(root) + 1),
+    split = "/",
+    fixed = TRUE
+  )[[1]]
+  kept <- character(0)
+  for (a_segment in segments) {
+    if (a_segment %in% c("", ".")) {
+      next
+    }
+    if (identical(x = a_segment, y = "..")) {
+      kept <- kept[-length(kept)]
+      next
+    }
+    kept <- c(kept, a_segment)
+  }
+  return(paste0(root, paste(kept, collapse = "/")))
+}

tests/testthat/test-fetch_project.R

@@ -0,0 +1,202 @@
+# quarto renvoie le chemin tel qu il est ecrit : les comparaisons portent sur
+# le dossier designe, pas sur sa forme (/var contre /private/var sur macOS,
+# noms courts et antislashs sur Windows)
+same_dir <- function(paths) {
+  return(normalizePath(paths, winslash = "/", mustWork = FALSE))
+}
+
+make_project_tree <- function() {
+  root <- tempfile(pattern = "fetchproj")
+  dirs <- c(
+    proj_yml = "proj_yml",
+    proj_yml_sub = file.path("proj_yml", "chap", "sub"),
+    proj_yaml = "proj_yaml",
+    inner = file.path("proj_yml", "inner"),
+    inner_sub = file.path("proj_yml", "inner", "x"),
+    no_proj = file.path("no_proj", "deep"),
+    profile_only = "profile_only",
+    empty_yml = "empty_yml"
+  )
+  for (a_dir in dirs) {
+    dir.create(file.path(root, a_dir), recursive = TRUE)
+  }
+  project_yaml <- "project:\n  type: default"
+  writeLines(project_yaml, con = file.path(root, "proj_yml", "_quarto.yml"))
+  writeLines(project_yaml, con = file.path(root, "proj_yaml", "_quarto.yaml"))
+  writeLines(project_yaml, con = file.path(root, "proj_yml", "inner", "_quarto.yml"))
+  writeLines(project_yaml, con = file.path(root, "profile_only", "_quarto-init.yml"))
+  writeLines("", con = file.path(root, "empty_yml", "_quarto.yml"))
+
+  qmd <- file.path(root, dirs, "dummy.qmd")
+  file.create(qmd)
+  names(qmd) <- names(dirs)
+  return(list(root = root, qmd = qmd))
+}
+
+test_that("fetch_project finds project roots without running quarto", {
+  tree <- make_project_tree()
+  on.exit(unlink(tree$root, recursive = TRUE), add = TRUE)
+  root <- normalizePath(tree$root, winslash = "/")
+
+  # an unusable quarto binary: only a filesystem lookup can succeed
+  withr::local_envvar(QUARTO_PATH = file.path(tree$root, "no-quarto"))
+
+  expect_equal(
+    object = same_dir(unlist(fetch_project(vec_qmd_path = tree$qmd["proj_yml_sub"]))),
+    expected = same_dir(file.path(root, "proj_yml"))
+  )
+  expect_equal(
+    object = same_dir(unlist(fetch_project(vec_qmd_path = tree$qmd["proj_yaml"]))),
+    expected = same_dir(file.path(root, "proj_yaml"))
+  )
+  expect_equal(
+    object = same_dir(unlist(fetch_project(vec_qmd_path = tree$qmd["inner_sub"]))),
+    expected = same_dir(file.path(root, "proj_yml", "inner"))
+  )
+  expect_equal(
+    object = same_dir(unlist(fetch_project(vec_qmd_path = tree$qmd["empty_yml"]))),
+    expected = same_dir(file.path(root, "empty_yml"))
+  )
+})
+
+test_that("fetch_project returns the qmd folder when no project is found", {
+  tree <- make_project_tree()
+  on.exit(unlink(tree$root, recursive = TRUE), add = TRUE)
+
+  qmd <- tree$qmd[c("no_proj", "profile_only")]
+  expect_equal(
+    object = same_dir(unlist(fetch_project(vec_qmd_path = qmd))),
+    expected = same_dir(unname(dirname(qmd)))
+  )
+})
+
+test_that("fetch_project deduplicates folders and projects", {
+  tree <- make_project_tree()
+  on.exit(unlink(tree$root, recursive = TRUE), add = TRUE)
+  root <- normalizePath(tree$root, winslash = "/")
+
+  qmd <- tree$qmd[c("proj_yml", "proj_yml_sub", "no_proj")]
+  qmd <- c(qmd, file.path(dirname(tree$qmd["no_proj"]), "other.qmd"))
+  expect_equal(
+    object = same_dir(unlist(fetch_project(vec_qmd_path = qmd))),
+    expected = same_dir(c(
+      unname(dirname(tree$qmd["no_proj"])),
+      file.path(root, "proj_yml")
+    ))
+  )
+})
+
+test_that("fetch_project agrees with quarto inspect", {
+  skip_if_not(quarto::quarto_available(), message = "quarto is not installed")
+  tree <- make_project_tree()
+  on.exit(unlink(tree$root, recursive = TRUE), add = TRUE)
+
+  for (a_qmd in tree$qmd) {
+    inspected <- tryCatch(
+      expr = {
+        quarto::quarto_inspect(dirname(a_qmd))$dir
+      },
+      error = function(e) {
+        NULL
+      }
+    )
+    expected <- if (is.null(inspected)) {
+      dirname(a_qmd)
+    } else {
+      inspected
+    }
+    expect_equal(
+      object = same_dir(unlist(fetch_project(vec_qmd_path = a_qmd))),
+      expected = same_dir(expected),
+      label = a_qmd
+    )
+  }
+})
+
+test_that("fetch_project returns a character vector", {
+  tree <- make_project_tree()
+  on.exit(unlink(tree$root, recursive = TRUE), add = TRUE)
+
+  expect_type(
+    object = fetch_project(vec_qmd_path = tree$qmd),
+    type = "character"
+  )
+})
+
+make_symlink_tree <- function() {
+  root <- normalizePath(tempfile(pattern = "fetchlink"), winslash = "/", mustWork = FALSE)
+  dir.create(file.path(root, "proj", "chap"), recursive = TRUE)
+  dir.create(file.path(root, "elsewhere", "chap"), recursive = TRUE)
+  dir.create(file.path(root, "outside"))
+  writeLines("project:\n  type: default", con = file.path(root, "proj", "_quarto.yml"))
+  linked <- c(
+    file.symlink(
+      from = file.path(root, "proj", "chap"),
+      to = file.path(root, "outside", "link_in")
+    ),
+    file.symlink(
+      from = file.path(root, "elsewhere", "chap"),
+      to = file.path(root, "proj", "link_out")
+    )
+  )
+  return(list(root = root, linked = all(linked)))
+}
+
+test_that("fetch_project follows the path as written, not the symlink target", {
+  tree <- make_symlink_tree()
+  on.exit(unlink(tree$root, recursive = TRUE), add = TRUE)
+  skip_if_not(tree$linked, message = "symlinks are not supported here")
+
+  # a folder linked from outside a project is not in the project
+  link_in <- file.path(tree$root, "outside", "link_in")
+  expect_equal(
+    object = same_dir(unlist(fetch_project(vec_qmd_path = file.path(link_in, "a.qmd")))),
+    expected = same_dir(link_in)
+  )
+  # a folder linked into a project belongs to it
+  expect_equal(
+    object = same_dir(unlist(fetch_project(
+      vec_qmd_path = file.path(tree$root, "proj", "link_out", "a.qmd")
+    ))),
+    expected = same_dir(file.path(tree$root, "proj"))
+  )
+})
+
+test_that("fetch_project agrees with quarto inspect through symlinks", {
+  skip_if_not(quarto::quarto_available(), message = "quarto is not installed")
+  tree <- make_symlink_tree()
+  on.exit(unlink(tree$root, recursive = TRUE), add = TRUE)
+  skip_if_not(tree$linked, message = "symlinks are not supported here")
+
+  for (a_dir in file.path(tree$root, c("outside/link_in", "proj/link_out"))) {
+    inspected <- tryCatch(
+      expr = {
+        quarto::quarto_inspect(a_dir)$dir
+      },
+      error = function(e) {
+        a_dir
+      }
+    )
+    expect_equal(
+      object = same_dir(unlist(fetch_project(vec_qmd_path = file.path(a_dir, "a.qmd")))),
+      expected = same_dir(inspected),
+      label = a_dir
+    )
+  }
+})
+
+test_that("fetch_project resolves relative paths and dot segments", {
+  tree <- make_project_tree()
+  on.exit(unlink(tree$root, recursive = TRUE), add = TRUE)
+  root <- normalizePath(tree$root, winslash = "/")
+
+  withr::local_dir(file.path(root, "proj_yml", "chap"))
+  expect_equal(
+    object = same_dir(unlist(fetch_project(vec_qmd_path = file.path("sub", "..", "sub", ".", "dummy.qmd")))),
+    expected = same_dir(file.path(root, "proj_yml"))
+  )
+  expect_equal(
+    object = same_dir(unlist(fetch_project(vec_qmd_path = file.path("..", "..", "no_proj", "deep", "dummy.qmd")))),
+    expected = same_dir(file.path("..", "..", "no_proj", "deep"))
+  )
+})