Various speed improvements (#98)

Co-authored-by: cpsievert <[email protected]>

DESCRIPTION

@@ -39,7 +39,7 @@ License: MIT + file LICENSE
 URL: https://rstudio.github.io/sass/, https://github.com/rstudio/sass
 BugReports: https://github.com/rstudio/sass/issues
 Encoding: UTF-8
-RoxygenNote: 7.1.1
+RoxygenNote: 7.1.2
 Roxygen: list(markdown = TRUE)
 SystemRequirements: GNU make
 Imports:

NEWS.md

@@ -1,5 +1,8 @@
 # sass 0.4.0.9000
 
+## Improvements
+
+* Several speed improvements for `sass()` and `as_sass_layer()`, particularly when `sass(write_attachments = TRUE)` encounters a `cache` hit. (#98)
 
 # sass 0.4.0
 

R/fonts.R

@@ -366,7 +366,7 @@ font_dep_face <- function(x) {
   dir.create(src_dir)
   writeLines(x$css, file.path(src_dir, "font.css"))
   htmlDependency(
-    font_dep_name(x), packageVersion("sass"),
+    font_dep_name(x), get_package_version("sass"),
     src = src_dir,
     stylesheet = "font.css",
     all_files = FALSE
@@ -375,7 +375,7 @@ font_dep_face <- function(x) {
 
 font_dep_link <- function(x) {
   htmlDependency(
-    font_dep_name(x), packageVersion("sass"),
+    font_dep_name(x), get_package_version("sass"),
     head = format(tags$link(
       href = utils::URLencode(x$href),
       rel = "stylesheet"
@@ -454,7 +454,7 @@ font_dep_google_local <- function(x) {
   }
 
   htmltools::htmlDependency(
-    font_dep_name(x), packageVersion("sass"),
+    font_dep_name(x), get_package_version("sass"),
     src = dirname(css_file),
     stylesheet = basename(css_file),
     all_files = TRUE
@@ -483,7 +483,7 @@ extract_group <- function(x, pattern, which = 1) {
 #' @importFrom stats na.omit
 #' @importFrom utils download.file packageVersion
 download_file <- function(url, dest, headers = NULL, ...) {
-  if (is_available("curl")) {
+  if (is_installed("curl")) {
     if (!curl::has_internet()) {
       warning(
         "Looks like you don't have internet access, which is needed to ",

R/layers.R

@@ -157,27 +157,28 @@ sass_layer_struct <- function(
   rules = NULL,
   declarations = NULL,
   html_deps = NULL,
-  file_attachments = character(0)
+  file_attachments = character(0),
+  validate = TRUE
 ) {
 
-  validate_layer_param(functions, "functions")
-  validate_layer_param(defaults, "defaults")
-  validate_layer_param(mixins, "mixins")
-  validate_layer_param(rules, "rules")
-  validate_layer_param(declarations, "declarations")
-
-  validate_attachments(file_attachments)
+  if (validate) {
+    validate_layer_param(functions, "functions")
+    validate_layer_param(defaults, "defaults")
+    validate_layer_param(mixins, "mixins")
+    validate_layer_param(rules, "rules")
+    validate_layer_param(declarations, "declarations")
 
-  if (!is.null(html_deps)) {
-    if (is_dependency_maybe(html_deps)) {
-      html_deps <- list(html_deps)
-    }
-    if (!is.list(html_deps)) {
-      stop("`html_deps` must be a collection of htmlDependency() and/or tagFunction() objects")
-    }
-    is_dependency <- vapply(html_deps, is_dependency_maybe, logical(1))
-    if (any(!is_dependency)) {
-      stop("`html_deps` must be a collection of htmlDependency() and/or tagFunction() objects")
+    if (!is.null(html_deps)) {
+      if (is_dependency_maybe(html_deps)) {
+        html_deps <- list(html_deps)
+      }
+      if (!is.list(html_deps)) {
+        stop("`html_deps` must be a collection of htmlDependency() and/or tagFunction() objects")
+      }
+      is_dependency <- vapply(html_deps, is_dependency_maybe, logical(1))
+      if (any(!is_dependency)) {
+        stop("`html_deps` must be a collection of htmlDependency() and/or tagFunction() objects")
+      }
     }
   }
 
@@ -342,15 +343,11 @@ sass_bundle_remove <- function(bundle, name) {
 }
 
 
-
-
 # sass_layer Check if `x` is a Sass layer object
 is_sass_layer <- function(x) {
   inherits(x, "sass_layer")
 }
 
-
-
 #' @describeIn sass_layer Check if `x` is a Sass bundle object
 #' @param x object to inspect
 #' @export
@@ -359,7 +356,6 @@ is_sass_bundle <- function(x) {
 }
 
 
-
 #' Sass Bundle to Single Sass Layer
 #'
 #' Converts a [sass_bundle()] to a single Sass layer object.
@@ -373,56 +369,37 @@ is_sass_bundle <- function(x) {
 as_sass_layer <- function(x) {
   if (is_sass_layer(x)) return(x)
   # sass_bundle(x) will auto upgrade to a sass bundle object
-  Reduce(function(y1, y2) { sass_layers_join(y1, y2) }, sass_bundle(x)$layers)
-}
-sass_layers_join <- function(layer1, layer2) {
+  layers <- rlang::set_names(sass_bundle(x)$layers, NULL)
   sass_layer_struct(
-    functions = join_non_null_values(layer1$functions, layer2$functions),
-    defaults = join_non_null_values(layer2$defaults, layer1$defaults),
-    mixins = join_non_null_values(layer1$mixins, layer2$mixins),
-    rules = join_non_null_values(layer1$rules, layer2$rules),
-    declarations = join_non_null_values(layer1$declarations, layer2$declarations),
-    html_deps = c(layer1$html_deps, layer2$html_deps),
-    file_attachments = join_attachments(layer1$file_attachments, layer2$file_attachments)
+    functions = pluck(layers, "functions"),
+    defaults = pluck(rev(layers), "defaults"),
+    mixins = pluck(layers, "mixins"),
+    rules = pluck(layers, "rules"),
+    declarations = pluck(layers, "declarations"),
+    html_deps = pluck(layers, "html_deps"),
+    file_attachments = pluck(layers, "file_attachments"),
+    validate = FALSE
   )
 }
-join_non_null_values <- function(x, y) {
-  ret <- dropNulls(list(x, y))
-  if (length(ret) == 0) return(NULL)
-  if (length(ret) == 1) return(ret[[1]])
-  ret
-}
-# attach2 takes precedence
-join_attachments <- function(attach1, attach2) {
-  # I thought about removing duplicates here, but it's hard to do so reliably
-  # because the paths can be files or directories.
-  c(attach1, attach2)
-}
 
-
-# Given the `input` to `sass()`, returns either NULL or a single sass_layer
-# that merges any sass_bundle found in the input
-# returns a single `sass_layer()` / `NULL`
-extract_layer <- function(input) {
-  if (is_sass_layer(input)) {
-    return(input)
-  }
-  if (is_sass_bundle(input)) {
-    return(as_sass_layer(input))
-  }
-  if (!identical(class(input), "list")) {
+pluck <- function(x, y) {
+  res <- dropNulls(lapply(x, `[[`, y))
+  if (length(res) == 0) {
     return(NULL)
   }
+  unlist(res, recursive = FALSE, use.names = TRUE)
+}
 
-  layers <- lapply(input, function(x) extract_layer(x))
-  layers <- dropNulls(layers)
-  if (length(layers) == 0) {
+extract_file_attachments <- function(x) {
+  if (is_sass_bundle_like(x)) {
+    return(as_sass_layer(x)$file_attachments)
+  }
+  if (!is.list(x)) {
     return(NULL)
   }
-  # convert to a sass layer object
-  as_sass_layer(
-    # merge all sass layers
-    sass_bundle(!!!layers)
+  unlist(
+    lapply(x, extract_file_attachments),
+    recursive = FALSE, use.names = TRUE
   )
 }
 

R/sass.R

@@ -151,7 +151,6 @@ sass <- function(
     stop("sass(write_attachments=TRUE) cannot be used when output=NULL")
   }
 
-
   if (identical(cache, FALSE)) {
     cache <- NULL
   } else if (is.character(cache)) {
@@ -164,9 +163,9 @@ sass <- function(
   }
 
   css <- NULL
-  layer <- extract_layer(input)
   sass_input <- as_sass(input)
   html_deps <- htmlDependencies(sass_input)
+  file_attachments <- extract_file_attachments(input)
 
   # If caching is active, compute the hash key
   cache_key <- if (!is.null(cache)) {
@@ -177,17 +176,23 @@ sass <- function(
       # 3. May include a temp directory
       discard_dependencies(input),
       options, cache_key_extra,
-      # Detect if any attachments have changed
-      if (is_sass_layer(layer) && !is.null(layer$file_attachments)) get_file_mtimes(layer$file_attachments)
+
+      if (isTRUE(write_attachments)) get_file_mtimes(file_attachments)
     ))
   }
 
   # Resolve output_template(), if need be
   if (is.function(output)) {
     output <- output(options, cache_key)
   }
-  if (!is.null(output) && !dir.exists(fs::path_dir(output))) {
-    stop("The output directory '", fs::path_dir(output), "' does not exist")
+
+  # Check the output dir exists (if relevant)
+  outdir <- NULL
+  if (!is.null(output)) {
+    outdir <- fs::path_dir(output)
+    if (!dir.exists(outdir)) {
+      stop("The output directory '", outdir, "' does not exist")
+    }
   }
 
   if (!is.null(cache)) {
@@ -199,12 +204,12 @@ sass <- function(
         cache_hit <- TRUE
       }
     } else {
-      cache_hit <- cache$get_file(cache_key, outfile = output)
+      if (cache$exists(cache_key)) {
+        key_file <- file.path(outdir, ".sass_cache_keys")
+        cache_hit <- file.exists(output) && file.exists(key_file) &&
+          isTRUE(cache_key %in% readLines(key_file, warn = FALSE))
+      }
       if (cache_hit) {
-        if (isTRUE(write_attachments == FALSE)) {
-          return(attachDependencies(output, html_deps))
-        }
-        maybe_write_attachments(layer, output, write_attachments)
         return(attachDependencies(output, html_deps))
       }
     }
@@ -214,6 +219,12 @@ sass <- function(
       css <- compile_data(sass_input, options)
       Encoding(css) <- "UTF-8"
 
+      # Save a note in the output directory that we've already written
+      # all the necessary files to this location
+      if (!is.null(output)) {
+        cat(cache_key, file = file.path(outdir, ".sass_cache_keys"), append = TRUE)
+      }
+
       # In case this same code is running in two processes pointed at the same
       # cache dir, this could return FALSE (if the file didn't exist when we
       # tried to get it, but does exist when we try to write it here), but
@@ -231,7 +242,7 @@ sass <- function(
 
   if (!is.null(output)) {
     write_utf8(css, output)
-    maybe_write_attachments(layer, output, write_attachments)
+    maybe_write_attachments(file_attachments, outdir, write_attachments)
     return(
       attachDependencies(output, html_deps)
     )
@@ -332,16 +343,13 @@ output_template <- function(basename = "sass", dirname = basename, fileext = NUL
   }
 }
 
-maybe_write_attachments <- function(layer, output, write_attachments) {
-  if (!(is_sass_layer(layer) && length(layer$file_attachments))) {
+maybe_write_attachments <- function(file_attachments, outdir, write_attachments) {
+  if (length(file_attachments) == 0) {
     return()
   }
 
   if (isTRUE(write_attachments)) {
-    write_file_attachments(
-      layer$file_attachments,
-      fs::path_dir(output)
-    )
+    write_file_attachments(file_attachments, outdir)
     return()
   }
 

R/sass_cache.R

@@ -208,7 +208,7 @@ sass_cache_context_dir <- function() {
 #' @noRd
 sass_hash <- function(x) {
   rlang::hash(
-    add_sass_file_mtime(list(x, utils::packageVersion("sass")))
+    add_sass_file_mtime(list(x, get_package_version("sass")))
   )
 }
 

R/staticimports.R

@@ -0,0 +1,48 @@
+# Generated by staticimports; do not edit by hand.
+# ======================================================================
+# Imported from pkg:staticimports
+# ======================================================================
+
+get_package_version <- function(pkg) {
+  # `utils::packageVersion()` can be slow, so first try the fast path of
+  # checking if the package is already loaded.
+  ns <- .getNamespace(pkg)
+  if (is.null(ns)) {
+    utils::packageVersion(pkg)
+  } else {
+    as.package_version(ns$.__NAMESPACE__.$spec[["version"]])
+  }
+}
+
+is_installed <- function(pkg, version = NULL) {
+  installed <- isNamespaceLoaded(pkg) || nzchar(system_file_cached(package = pkg))
+  if (is.null(version)) {
+    return(installed)
+  }
+  installed && isTRUE(get_package_version(pkg) >= version)
+}
+
+# A wrapper for `system.file()`, which caches the results, because
+# `system.file()` can be slow. Note that because of caching, if
+# `system_file_cached()` is called on a package that isn't installed, then the
+# package is installed, and then `system_file_cached()` is called again, it will
+# still return "".
+system_file_cached <- local({
+  pkg_dir_cache <- character()
+
+  function(..., package = "base") {
+    if (!is.null(names(list(...)))) {
+      stop("All arguments other than `package` must be unnamed.")
+    }
+
+    not_cached <- is.na(match(package, names(pkg_dir_cache)))
+    if (not_cached) {
+      pkg_dir <- system.file(package = package)
+      pkg_dir_cache[[package]] <<- pkg_dir
+    } else {
+      pkg_dir <- pkg_dir_cache[[package]]
+    }
+
+    file.path(pkg_dir, ...)
+  }
+})