diff --git a/.Rbuildignore b/.Rbuildignore
index f7bd7e96..9808936c 100644
--- a/.Rbuildignore
+++ b/.Rbuildignore
@@ -14,3 +14,4 @@
^renovate\.json$
^doc$
^Meta$
+^sub$
diff --git a/sub/PACKAGE_STRUCTURE.md b/sub/PACKAGE_STRUCTURE.md
new file mode 100644
index 00000000..e9a1ce8d
--- /dev/null
+++ b/sub/PACKAGE_STRUCTURE.md
@@ -0,0 +1,87 @@
+# Constructive Package Structure
+
+## Overview
+
+This directory contains extracted sub-packages from the constructive ecosystem.
+
+## constructive.core
+
+The `constructive.core` package contains the core infrastructure for code generation:
+
+### Included Components
+
+#### Infrastructure Files (34 files)
+- Core functions: `construct.R`, `construct_*.R` (clip, diff, dput, dump, reprex, signature)
+- Helper utilities: `construct-helpers.R`, `character-helpers.R`, `deparse_*.R`, `format_atomic.R`
+- Options system: `opts.R`, `global-options.R`
+- Attribute handling: `repair_attributes.R`, `contains_self_reference.R`
+- Templates: `templates.R`, `custom_constructors.R`
+- Package infrastructure: `constructive-package.R`, `zzz.R`, `00_meta.R`
+- Error handling: `abort.R`, `bypass.R`
+- Other utilities: `utils.R`, `environment_utils.R`, `s3_register.R`, `roxygen2-tags.R`
+- Documentation: `document-other-opts.R`, `expect_construct.R`
+- Lifecycle management: `import-standalone-lifecycle.R`
+
+#### Base Type Methods (18 files)
+Files implementing constructors for base R types:
+- `s3-NULL.R` - NULL type
+- `s3-atomic.R` - Base atomic vectors
+- `s3-character.R` - Character vectors
+- `s3-integer.R` - Integer vectors
+- `s3-double.R` - Double/numeric vectors
+- `s3-complex.R` - Complex numbers
+- `s3-logical.R` - Logical vectors
+- `s3-raw.R` - Raw vectors
+- `s3-list.R` - Lists
+- `s3-array.R` - Arrays
+- `s3-matrix.R` - Matrices
+- `s3-environment.R` - Environments
+- `s3-function.R` - Functions
+- `s3-language.R` - Language objects (calls, expressions)
+- `s3-pairlist.R` - Pairlists
+- `s3-dots.R` - ... (dots)
+- `s3-externalptr.R` - External pointers
+- `s3-object.R` - Object type
+
+#### S4 Support
+- `s4.R` - S4 object construction
+
+#### C++ Code
+- `src/constructive.cpp` - C functions for external pointer handling and environment retrieval
+
+#### Tests
+26 test files covering core functionality:
+- Infrastructure tests: `test-construct-*.R`, `test-deparse_call.R`, `test-opts.R`, etc.
+- Type tests: `test-s3-array.R`, `test-s3-list.R`, `test-s3-environment.R`, etc.
+- Utility tests: `test-utils.R`, `test-repair_attributes.R`, etc.
+
+### Purpose
+
+The `constructive.core` package serves as a lightweight, low-dependency foundation that:
+1. Provides the default `.cstr_construct()` method
+2. Handles all base R types
+3. Supplies infrastructure functions used by extension packages
+4. Can be independently installed and tested
+
+### Dependencies
+
+Imports:
+- cli (>= 3.1.0)
+- diffobj
+- methods
+- rlang (>= 1.0.0)
+- waldo
+
+## Future Packages
+
+Additional packages will be extracted in future iterations:
+- `constructive.base` - Base R class methods (Date, POSIXct, factor, data.frame, etc.)
+- `constructive.ggplot2` - ggplot2 constructors
+- `constructive.methods` - Other package-specific methods
+
+## Notes
+
+Currently, the main `constructive` package still contains all code. The extraction to `constructive.core` is the first step in the modularization process. Future work will:
+1. Update the main package to import from `constructive.core`
+2. Remove duplicated code from the main package
+3. Extract additional specialized packages
diff --git a/sub/constructive.core/.Rbuildignore b/sub/constructive.core/.Rbuildignore
new file mode 100644
index 00000000..58bbdabb
--- /dev/null
+++ b/sub/constructive.core/.Rbuildignore
@@ -0,0 +1,3 @@
+^constructive\.core\.Rproj$
+^\.Rproj\.user$
+^LICENSE\.md$
diff --git a/sub/constructive.core/DESCRIPTION b/sub/constructive.core/DESCRIPTION
new file mode 100644
index 00000000..e28a9530
--- /dev/null
+++ b/sub/constructive.core/DESCRIPTION
@@ -0,0 +1,34 @@
+Package: constructive.core
+Title: Core Infrastructure for Constructive Code Generation
+Version: 0.1.0
+Authors@R: c(
+ person("Antoine", "Fabri", , "antoine.fabri@gmail.com", role = c("aut", "cre")),
+ person("Kirill", "Müller", , "kirill@cynkra.com", role = "ctb",
+ comment = c(ORCID = "0000-0002-1416-3412")),
+ person("Jacob", "Scott", , "jscott2718@gmail.com", role = "ctb"),
+ person("cynkra GmbH", , , "mail@cynkra.com", role = "fnd",
+ comment = c(ROR = "0335t7e62"))
+ )
+Description: Provides core infrastructure for generating R code that can
+ recreate R objects. This package contains the default method and
+ essential helper functions used by the 'constructive' package ecosystem.
+License: MIT + file LICENSE
+URL: https://github.com/cynkra/constructive
+BugReports: https://github.com/cynkra/constructive/issues
+Imports:
+ cli (>= 3.1.0),
+ diffobj,
+ methods,
+ rlang (>= 1.0.0),
+ waldo
+Suggests:
+ clipr,
+ reprex,
+ rstudioapi,
+ S7,
+ testthat (>= 3.0.0),
+ withr
+Config/testthat/edition: 3
+Encoding: UTF-8
+Roxygen: list(markdown = TRUE)
+RoxygenNote: 7.3.3.9000
diff --git a/sub/constructive.core/LICENSE b/sub/constructive.core/LICENSE
new file mode 100644
index 00000000..9720f35c
--- /dev/null
+++ b/sub/constructive.core/LICENSE
@@ -0,0 +1,2 @@
+YEAR: 2023
+COPYRIGHT HOLDER: constructive authors
diff --git a/sub/constructive.core/LICENSE.md b/sub/constructive.core/LICENSE.md
new file mode 100644
index 00000000..adb1eb8c
--- /dev/null
+++ b/sub/constructive.core/LICENSE.md
@@ -0,0 +1,21 @@
+# MIT License
+
+Copyright (c) 2023 constructive authors
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
diff --git a/sub/constructive.core/R/00_meta.R b/sub/constructive.core/R/00_meta.R
new file mode 100644
index 00000000..ac3f86f1
--- /dev/null
+++ b/sub/constructive.core/R/00_meta.R
@@ -0,0 +1,47 @@
+# functions used to build functions of the package
+new_constructive_opts_function <- function(class, constructors, ...) {
+
+ env <- parent.frame()
+ DOTS <- eval(substitute(alist(...)))
+ CONSTRUCTOR <- substitute(constructors)
+ FORWARDED_DOTS <- DOTS
+ FORWARDED_DOTS[] <- lapply(names(DOTS), as.symbol)
+ CLASS <- substitute(class)
+ eval(bquote(
+ splice = TRUE,
+ as.function(
+ alist(constructor = .(CONSTRUCTOR), ... =, ..(DOTS), {
+ .cstr_combine_errors(
+ constructor <- .cstr_match_constructor(constructor, .(CLASS)),
+ check_dots_empty()
+ )
+ .cstr_options(.(CLASS), constructor = constructor, ..(FORWARDED_DOTS))
+ }),
+ envir = env
+ )
+ ))
+}
+
+new_constructive_method <- function(class, constructors, ...) {
+ env <- parent.frame()
+ CLASS <- substitute(class)
+ CLASS_CHR <- as.character(CLASS)
+ IS_CORRUPTED_FUN <- as.symbol(paste0("is_corrupted_", class))
+ CONSTRUCTOR_ARGS <- sapply(constructors, as.symbol)
+ DOTS <- eval(substitute(alist(...)))
+ FORWARDED_DOTS <- DOTS
+ FORWARDED_DOTS[] <- lapply(names(DOTS), function(x) call("$", quote(opts), as.symbol(x)))
+ OPTS_FUN = as.symbol(sprintf("opts_%s", CLASS_CHR))
+ eval(bquote(
+ splice = TRUE,
+ as.function(
+ alist(x = , opts =, ... = ,{
+ opts_local <- opts[[.(CLASS_CHR)]] %||% .(OPTS_FUN)()
+ if (.(IS_CORRUPTED_FUN)(x) || opts_local[["constructor"]] == "next") return(NextMethod())
+ constructor <- constructors[[.(CLASS)]][[opts_local[["constructor"]]]]
+ constructor(x, opts = opts, ..(FORWARDED_DOTS), ...)
+ }),
+ envir = env
+ )
+ ))
+}
diff --git a/sub/constructive.core/R/C_wrappers.R b/sub/constructive.core/R/C_wrappers.R
new file mode 100644
index 00000000..c9615a6e
--- /dev/null
+++ b/sub/constructive.core/R/C_wrappers.R
@@ -0,0 +1,34 @@
+#' @useDynLib constructive.core
+NULL
+
+#' Build a pointer from a memory address
+#'
+#' Base R doesn't provide utilities to build or manipulate external pointers
+#' (objects of type "externalptr"), so we provide our own.
+#' Objects defined with `.xptr()` are not stable across sessions,
+#'
+#' @param address Memory address
+#' @return The external pointer (type "externalptr") that the memory address points to.
+#' @export
+.xptr <- function(address) {
+ if (!missing(address) && is.character(address) && length(address) == 1L) {
+ ptr <- globals[["external_pointers"]][[address]]
+ if (!is.null(ptr)) return(ptr)
+ }
+ abort(paste0("No external pointer registered for key ", address))
+}
+
+external_pointer_address <- function(s) {
+ if (identical(Sys.getenv("TESTTHAT"), "true")) return("0x123456789")
+ .Call("external_pointer_address", PACKAGE = "constructive.core", s)
+}
+
+env_impl <- function(address) {
+ .Call("objectFromAddress", PACKAGE = "constructive.core", address)
+}
+
+promise_env <- function(name, env = parent.frame()) {
+ enquo_call <- substitute(rlang::enquo(X), list(X = rlang::sym(name)))
+ quo <- eval(enquo_call, env)
+ rlang::quo_get_env(quo)
+}
diff --git a/sub/constructive.core/R/abort.R b/sub/constructive.core/R/abort.R
new file mode 100644
index 00000000..323d6a76
--- /dev/null
+++ b/sub/constructive.core/R/abort.R
@@ -0,0 +1,165 @@
+#' Combine errors
+#'
+#' Exported for custom constructor design. This function allows combining independent checks so information is given about
+#' all failing checks rather than the first one. All parameters except `...` are
+#' forwarded to `rlang::abort()`
+#'
+#' @param ... check expressions
+#' @param header An optional header to precede the errors
+#' @inheritParams rlang::abort
+#'
+#' @return Returns `NULL` invisibly, called for side effects.
+#' @export
+.cstr_combine_errors <- function(
+ ..., # unnamed expresions and named arg to forward to abort, such as `class`
+ class = NULL,
+ call,
+ header = NULL,
+ body = NULL,
+ footer = NULL,
+ trace = NULL,
+ parent = NULL,
+ use_cli_format = NULL,
+ .internal = FALSE,
+ .file = NULL,
+ .frame = parent.frame(),
+ .trace_bottom = NULL) {
+ env <- parent.frame()
+ dots <- eval(substitute(alist(...)))
+ unnamed_dots <- dots[rlang::names2(dots) == ""]
+ named_dots <- dots[rlang::names2(dots) != ""]
+ named_dots <- eval(named_dots, env)
+ err <- header
+ for (expr in unnamed_dots) {
+ err <- tryCatch({
+ eval(expr, env)
+ err
+ }, error = function(e) {
+ c(err, "!" = e$message, e$body)
+ }
+ )
+ }
+ if (!is.null(err)) {
+ names(err)[1] <- ""
+ do.call(rlang::abort, c(list(
+ err,
+ class = class,
+ call = if (missing(call)) env else call,
+ body = body,
+ footer = footer,
+ trace = trace,
+ parent = parent,
+ use_cli_format = use_cli_format,
+ .internal = .internal,
+ .file = .file,
+ .frame = .frame,
+ .trace_bottom = .trace_bottom
+ ),
+ named_dots))
+ }
+}
+
+describe <- function(x) {
+ type <- typeof(x)
+ code <- construct(x, check = FALSE)$code
+ code <- highlight_code(code)
+ code <- paste(code, collapse = "\n")
+ if (type %in% c("logical", "integer", "double", "complex", "character", "raw", "list")) {
+ info <- sprintf("It has type '%s' and length %s:\n", typeof(x), length(x))
+ } else {
+ info <- sprintf("It has type '%s':\n", typeof(x))
+ }
+ paste0(info, code)
+}
+
+abort_not_boolean <- function(x) {
+ var <- as.character(substitute(x))
+ if (!rlang::is_bool(x)) {
+ msg <- sprintf("`%s` is not a boolean (scalar `TRUE` or `FALSE`)", var)
+ abort(c(msg, i = describe(x)), call = parent.frame())
+ }
+}
+
+abort_not_string <- function(x) {
+ var <- as.character(substitute(x))
+ if (!rlang::is_string(x)) {
+ msg <- sprintf("`%s` must be a string.", var)
+ abort(c(msg, i = describe(x)), call = parent.frame())
+ }
+}
+
+abort_not_null_or_integerish <- function(x) {
+ var <- as.character(substitute(x))
+ if (!rlang::is_null(x) && !rlang::is_integerish(x, 1)) {
+ msg <- sprintf("`%s` is not `NULL` or a scalar integerish ", var)
+ abort(c(msg, i = describe(x)), call = parent.frame())
+ }
+}
+
+abort_not_env_or_named_list <- function(x) {
+ var <- as.character(substitute(x))
+ env_or_named_list_bool <-
+ !is_environment(x) &&
+ !(is_list(x) && is_named(x))
+ if (env_or_named_list_bool) {
+ msg <- sprintf("`%s` must be a named list or an environment.", var)
+ info <- if (is_list(x)) {
+ "It is a list with unnamed elements."
+ } else {
+ describe(x)
+ }
+ abort(c(msg, i = info), call = parent.frame())
+ }
+}
+
+abort_wrong_data <- function(x) {
+ if (is.null(x) || is.environment(x)) return(invisible(NULL))
+ if (is.character(x)) {
+ if (length(x) != 1) {
+ msg <- "`data` has an unexpected value."
+ info <- describe(x)
+ abort(c(msg, i = info), call = parent.frame())
+ }
+ if (!is_installed(x)) {
+ msg <- "`data` can be a string only if it's an installed package name."
+ info <- sprintf("There is no installed package called '%s'", x)
+ abort(c(msg, i = info), call = parent.frame())
+ }
+ return(invisible(NULL))
+ }
+ if (!is.environment(x) && !is.list(x)) {
+ msg <- "`data` has an unexpected value."
+ info <- describe(x)
+ abort(c(msg, i = info), call = parent.frame())
+ }
+ nms <- names2(x)
+ for (i in seq_along(x)) {
+ if (nms[[i]] != "") next
+ if (is.character(x[[i]])) {
+ if (length(x[[i]]) != 1) {
+ msg <- sprintf("`data[[%s]]` has an unexpected value", i)
+ info <- describe(x[[i]])
+ abort(c(msg, i = info), call = parent.frame())
+ }
+ if (!is_installed(x[[i]])) {
+ msg <- "`data` can contain unnamed strings only if it's an installed package name."
+ info1 <- sprintf("`data[[%s]]` is \"%s\".", i, x[[i]])
+ info2 <- sprintf("There is no installed package called '%s'", x[[i]])
+ abort(c(msg, i = info1, i = info2), call = parent.frame())
+ }
+ next
+ }
+ if (!is.environment(x[[i]]) && !(is.list(x[[i]]) && is_named2(x[[i]]))) {
+ msg <- sprintf("`data[[%s]]` is unnamed and has an unexpected value.", i)
+ info <- describe(x[[i]])
+ abort(c(msg, i = info), call = parent.frame())
+ }
+ }
+ invisible(NULL)
+}
+
+abort_self_reference <- function() {
+ msg <- "The object contains self-references (environments depending pointing to themselves)"
+ info <- "Consider using `opts_environment(\"predefine\")` or less reliably `recurse = FALSE`"
+ rlang::abort(c(msg, i = info), call = parent.frame())
+}
diff --git a/sub/constructive.core/R/bypass.R b/sub/constructive.core/R/bypass.R
new file mode 100644
index 00000000..f45ecd35
--- /dev/null
+++ b/sub/constructive.core/R/bypass.R
@@ -0,0 +1,129 @@
+# This script defines shims of base R functions that don't trigger S3 dispatch.
+# Indeed in this package S3 dispatch is more likely to be accidental than desired.
+# When dispatch is actually desired, we should use the `base::fun` form.
+# Ultimately we should use the {bypass} package, more specifically `global_bypass()`
+
+# vectors ======================================================================
+
+c <- function(...) base::c(NULL, ...)
+
+unlist <- function(x, recursive = TRUE, use.names = TRUE) {
+ base::unlist(unclass(x))
+}
+
+lapply <- function(X, FUN, ...) {
+ base::lapply(unclass(X), FUN, ...)
+}
+
+sapply <- function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {
+ base::sapply(unclass(X), FUN, ..., simplify = simplify, USE.NAMES = USE.NAMES)
+}
+
+vapply <- function(X, FUN, FUN.VALUE, ..., USE.NAMES = TRUE) {
+ base::vapply(unclass(X), FUN, FUN.VALUE, ..., USE.NAMES = USE.NAMES)
+}
+
+# dimensions ===================================================================
+
+length <- function(x) {
+ if (is.environment(x)) return(base::length(ls(x, all.names = TRUE)))
+ base::length(unclass(x))
+}
+
+lengths <- function(x, use.names = TRUE) {
+ sapply(x, length, USE.NAMES = use.names)
+}
+
+dim <- function(x) {
+ attr(x, "dim")
+}
+
+`dim<-` <- function(x, value) {
+ attr(x, "dim") <- value
+ x
+}
+
+dimnames <- function(x) {
+ attr(x, "dimnames")
+}
+
+`dimnames<-` <- function(x, value) {
+ attr(x, "dimnames") <- value
+ x
+}
+
+names <- function(x) {
+ if (is.environment(x)) return(ls(x, all.names = TRUE, sorted = FALSE))
+ base::names(unclass(x))
+}
+
+`names<-` <- function(x, value) {
+ attr(x, "names") <- value
+ x
+}
+
+# subset =======================================================================
+
+`$` <- function(e1, e2) {
+ .subset2(e1, as.character(substitute(e2)))
+}
+
+`[` <- function(x, ...) {
+ cl <- oldClass(x)
+ x <- unclass(x)
+ out <- base::`[`(x, ...)
+ oldClass(out) <- cl
+ out
+}
+
+`[<-` <- function(x, ..., value) {
+ cl <- oldClass(x)
+ x <- unclass(x)
+ x <- base::`[<-`(x, ..., value = value)
+ oldClass(x) <- cl
+ x
+}
+
+`[[<-` <- function(x, ..., value) {
+ cl <- oldClass(x)
+ x <- unclass(x)
+ x <- base::`[[<-`(x, ..., value = value)
+ oldClass(x) <- cl
+ x
+}
+
+`$<-` <- function(e1, e2, value) {
+ e1[[as.character(substitute(e2))]] <- value
+ e1
+}
+
+# comparison ops ===============================================================
+
+`==` <- function(e1, e2) {
+ base::`==`(unclass(e1), unclass(e2))
+}
+
+`!=` <- function(e1, e2) {
+ base::`!=`(unclass(e1), unclass(e2))
+}
+
+`>` <- function(e1, e2) {
+ base::`>`(unclass(e1), unclass(e2))
+}
+
+`<` <- function(e1, e2) {
+ base::`<`(unclass(e1), unclass(e2))
+}
+
+`>=` <- function(e1, e2) {
+ base::`>=`(unclass(e1), unclass(e2))
+}
+
+`<=` <- function(e1, e2) {
+ base::`<=`(unclass(e1), unclass(e2))
+}
+
+`/` <- function(e1, e2) {
+ base::`/`(unclass(e1), unclass(e2))
+}
+
diff --git a/sub/constructive.core/R/character-helpers.R b/sub/constructive.core/R/character-helpers.R
new file mode 100644
index 00000000..fe82b4cb
--- /dev/null
+++ b/sub/constructive.core/R/character-helpers.R
@@ -0,0 +1,163 @@
+
+compress_character <- function(x, ...) {
+ if (length(x) > 2 && isTRUE(all(x == ""))) return(sprintf("character(%s)", length(x)))
+ format_rep(x, ...)
+}
+
+# construct a vector of code that can be parsed to strings
+construct_strings <- function(x, unicode_representation.chr = "ascii", escape.chr = FALSE, mode = "string", ...) {
+ out <- sapply(
+ x,
+ construct_string,
+ unicode_representation = unicode_representation.chr,
+ escape = escape.chr,
+ mode,
+ USE.NAMES = FALSE
+ )
+ names(out) <- names(x)
+ out
+}
+
+
+# construct a string with relevant format, incl quotes, so it can be parsed to a string
+# We need modes "string", "name" and "symbol"
+# * "string" always produces strings
+# * names should not have double quotes unless backslash in the name, and backquotes if not syntatic
+# * symbols can't use \U but can use \x (but then are dependent on native encoding),
+# if `protect` is FALSE we don't use backquotes
+construct_string <- function(x, unicode_representation, escape, mode = "string", protect = TRUE) {
+ # deal with NA early
+ if (is_na(x)) return("NA_character_")
+
+ encoding <- Encoding(x)
+ locale_is_utf8 <- l10n_info()$`UTF-8`
+ if (encoding == "latin1" || !locale_is_utf8) {
+ return(construct_string_from_byte_value(x, encoding, mode, protect))
+ }
+
+ # If the encoding was not UTF-8 we impose it so we can use utf-8 construction
+ # The encoding will be repaired if necessary
+ out <- construct_utf8_string(
+ x,
+ encoding,
+ unicode_representation,
+ escape,
+ mode,
+ protect
+ )
+
+ out
+}
+
+construct_utf8_string <- function(x, encoding, unicode_representation, escape, mode = "string", protect = TRUE) {
+ # Deal with corrupted strings
+ x_utf8 <- iconv(x, to = "UTF-8") # NA on corrupted
+ x_is_corrupted <- is_na(x_utf8)
+ if (x_is_corrupted) {
+ out <- construct_string_from_byte_value(x, encoding, mode, protect)
+ return(out)
+ }
+
+ # Split the string into chars, fetch codepoints, and deparse without surrounding quotes
+ chars <- suppressWarnings(strsplit(x_utf8, "")[[1]])
+ codepoints <- sapply(chars, utf8ToInt) # NAs stay NA
+ codepoints[is.na(chars)] <- -1
+ deparsed_chars <- deparse_no_quotes(chars)
+ # repair the corrupted items
+ deparsed_chars[is.na(chars)] <- sapply(chars[is.na(chars)], deparse)
+
+ # Use the "\U{}" notation where relevant
+ limit <- switch(
+ unicode_representation,
+ ascii = 128,
+ latin = 256,
+ character = 0x1F000,
+ unicode = Inf
+ )
+ uses_u <- any(codepoints >= limit)
+ if (uses_u && mode == "symbol") {
+ out <- construct_string_from_byte_value(x, encoding, mode, protect)
+ return(out)
+ }
+
+ deparsed_chars <- ifelse(
+ codepoints >= limit,
+ sprintf("\\U{%X}", codepoints),
+ deparsed_chars
+ )
+
+ # gather info about usage of special characters in string, necessary to
+ # know what simplification can be applied
+ uses_special_backlashes <- any(
+ grepl("\\", deparsed_chars, fixed = TRUE) &
+ chars != "\\" &
+ chars != "\""
+ )
+ uses_regular_backslashes <- "\\" %in% chars
+ uses_sq <- "'" %in% chars
+ uses_dbq <- "\"" %in% chars
+
+ # define conditions
+ surround_with_single_quotes <- !escape && uses_dbq && !uses_sq
+ use_raw_strings <- !escape && !uses_special_backlashes &&
+ (uses_regular_backslashes | (uses_sq && uses_dbq))
+
+ # finalize the code with the right format and surrounding quotes
+ if (use_raw_strings) {
+ out <- sprintf('r"[%s]"', paste(chars, collapse = ""))
+ } else if (surround_with_single_quotes) {
+ # unescape double quotes
+ deparsed_chars[deparsed_chars == "\\\""] <- "\""
+ out <- sprintf("'%s'", paste(deparsed_chars, collapse = ""))
+ } else if (protect && (mode == "symbol" || (mode == "name" && !uses_u))) {
+ out <- protect(paste(deparsed_chars, collapse = ""))
+ } else if (protect) {
+ out <- paste(c('"', deparsed_chars, '"'), collapse = "")
+ } else {
+ out <- paste(deparsed_chars, collapse = "")
+ }
+
+ # repair encoding with |> (`Encoding<-`)() when relevant
+ string_is_ascii <- !x_is_corrupted && Encoding(x_utf8) == "unknown"
+ repair_encoding(out, string_is_ascii, encoding)
+}
+
+construct_string_from_byte_value <- function(x, encoding, mode = "string", protect = TRUE) {
+ bytes <- charToRaw(x)
+ string_is_ascii <- all(bytes < 128)
+ chars <- ifelse(
+ bytes < 128,
+ deparse_no_quotes(sapply(bytes, rawToChar)),
+ sprintf("\\x%s", as.character(bytes))
+ )
+ out <- paste(chars, collapse = "")
+ if (mode == "string") {
+ out <- paste0('"', out, '"')
+ } else if (protect) {
+ out <- protect(out)
+ }
+
+ repair_encoding(out, string_is_ascii, encoding)
+}
+
+repair_encoding <- function(code, string_is_ascii, encoding) {
+ locale_is_like_encoding <-
+ (encoding == "UTF-8" && l10n_info()$`UTF-8`) ||
+ (encoding == "latin1" && l10n_info()$`Latin-1`)
+
+ no_repair_needed <-
+ string_is_ascii ||
+ locale_is_like_encoding ||
+ (!(globals$pedantic_encoding %||% FALSE) && encoding == "unknown")
+ if (no_repair_needed) return(code)
+ .cstr_pipe(
+ code,
+ sprintf("(`Encoding<-`)(\"%s\")", encoding),
+ one_liner = TRUE
+ )
+}
+
+# a vectorized deparse() that trims the surrounding double quotes
+deparse_no_quotes <- function(x) {
+ sub("^.(.*).$", "\\1", sapply(x, deparse))
+}
diff --git a/sub/constructive.core/R/construct-helpers.R b/sub/constructive.core/R/construct-helpers.R
new file mode 100644
index 00000000..dc4ec1e4
--- /dev/null
+++ b/sub/constructive.core/R/construct-helpers.R
@@ -0,0 +1,399 @@
+# Functions that are called in construct, or functions called only by the former
+
+#' Options for waldo::compare
+#'
+#' Builds options that will be passed to `waldo::compare()` down the line.
+#'
+#' @inheritParams waldo::compare
+#'
+#' @return A list
+#' @export
+compare_options <- function(ignore_srcref = TRUE, ignore_attr = FALSE, ignore_function_env = FALSE, ignore_formula_env = FALSE) {
+ .cstr_combine_errors(
+ abort_not_boolean(ignore_srcref),
+ abort_not_boolean(ignore_attr),
+ abort_not_boolean(ignore_function_env),
+ abort_not_boolean(ignore_formula_env)
+ )
+ structure(
+ list(
+ ignore_srcref = ignore_srcref,
+ ignore_attr = ignore_attr,
+ ignore_function_env = ignore_function_env,
+ ignore_formula_env = ignore_formula_env
+ ),
+ class = "constructive_compare_options"
+ )
+}
+
+process_data <- function(data, main = TRUE) {
+ if (is.character(data) && length(data) == 1) return(namespace_as_list(data, main = main))
+ if (is.environment(data)) return(as.list(data))
+ # recurse into unnamed elements
+ nms <- rlang::names2(data)
+ named_elts <- data[nms != ""]
+ unnamed_elts <- data[nms == ""]
+ objs <- c(named_elts, do.call(c, lapply(unnamed_elts, process_data, main = FALSE)))
+ if (main) {
+ if (anyDuplicated(names(objs))) {
+ dupes <- names(objs)[duplicated(names(objs))]
+ msg <- "`data` must contain must one definition per name"
+ info <- sprintf("Found duplicate definitions for %s", collapse(dupes, quote = "`"))
+ abort(c(msg, x = info), call = parent.frame())
+ }
+ short_nms <- sub("^[^:]+::", "", names(objs))
+ dupes_lgl <- duplicated(short_nms) | duplicated(short_nms, fromLast = TRUE)
+ names(objs)[!dupes_lgl] <- short_nms[!dupes_lgl]
+ }
+ objs
+}
+
+try_construct <- function(x, ...) {
+ # deal early with special case x = quote(expr=)
+ if (identical(x, quote(expr=))) return("quote(expr = )")
+ caller <- caller_env()
+ rlang::try_fetch(.cstr_construct(x, ...), error = function(e) {
+ #nocov start
+ abort("{constructive} could not build the requested code.", parent = e, call = caller)
+ #nocov end
+ })
+}
+
+try_parse <- function(code, one_liner) {
+ caller <- caller_env()
+ rlang::try_fetch(
+ rlang::parse_expr(paste0("{\n", paste(code, collapse = "\n"), "\n}\n")),
+ error = function(e) {
+ #nocov start
+ abort("The code built by {constructive} could not be parsed.", parent = e, call = caller)
+ #nocov end
+ }
+ )
+ code <- as_constructive_code(code)
+ code
+}
+
+try_eval <- function(styled_code, data, check, caller) {
+ # use local_bindings rather than `enclos =` so the expression is really evaled
+ # in the proper env, this makes a difference for calls that capture the env
+ local_bindings(!!!data, .env = caller)
+ rlang::try_fetch(
+ suppress_all_output(eval(parse(text = styled_code), caller)),
+ error = function(e) {
+ #nocov start
+ msg <- "The code built by {constructive} could not be evaluated."
+ if (isTRUE(check)) {
+ print(styled_code)
+ abort(msg, parent = e, call = caller)
+ }
+ # not sure if `e$message` can have length > 1 but playing safe
+ rlang::inform(c("!" = msg, "!" = paste("Due to error:", paste(e$message, collapse = "\n"))))
+ #nocov end
+ }
+ )
+}
+
+suppress_all_output <- function(expr) {
+ sink(tempfile())
+ on.exit(sink())
+ withCallingHandlers(
+ expr,
+ warning = function(w) tryInvokeRestart("muffleWarning"),
+ message = function(c) tryInvokeRestart("muffleMessage")
+ )
+}
+
+check_round_trip <- function(x, styled_code, data, check, compare, caller) {
+ # return early if no check
+ if (isFALSE(check)) return(NULL)
+
+ # attempt to eval and fail explicitly if we can't
+ evaled <- try_eval(styled_code, data, check, caller)
+ if (missing(evaled) || (is.null(evaled) && !is.null(x))) return(NULL)
+
+ if (compare$ignore_srcref) {
+ rlang::local_bindings(
+ compare_proxy.S7_object = compare_proxy_S7_object,
+ .env = .GlobalEnv
+ )
+ }
+ # set custom method for waldo
+ rlang::local_bindings(
+ compare_proxy.LayerInstance = compare_proxy_LayerInstance,
+ compare_proxy.ggplot = compare_proxy_ggplot,
+ compare_proxy.weakref = compare_proxy_weakref,
+ compare_proxy.R6ClassGenerator = compare_proxy_R6ClassGenerator,
+ .env = .GlobalEnv)
+ issues <-
+ waldo::compare(
+ x,
+ evaled,
+ x_arg = "original",
+ y_arg = "recreated",
+ ignore_srcref = compare$ignore_srcref,
+ ignore_attr = compare$ignore_attr,
+ ignore_encoding = TRUE,
+ ignore_function_env = compare$ignore_function_env,
+ ignore_formula_env = compare$ignore_formula_env,
+ max_diffs = Inf
+ )
+
+ # special case ggplot2 NSE artifacts
+ max_diffs <- attr(issues, "max_diffs")
+ issues <- issues[!detect_ggplot_nse_artifacts(issues)]
+ attr(issues, "max_diffs") <- max_diffs
+ # return early if no issue
+ if (!length(issues)) return(NULL)
+
+ # set and signal issues
+ globals$issues <- issues
+ msg <- "{constructive} couldn't create code that reproduces perfectly the input"
+ if (isTRUE(check)) {
+ print(styled_code)
+ msg <- paste0(msg, "\n", paste(issues, collapse = "\n"))
+ abort(c(msg))
+ }
+ info <- "Call `construct_issues()` to inspect the last issues\n"
+ rlang::inform(c(msg, i = info))
+
+ # return issues
+ issues
+}
+
+detect_ggplot_nse_artifacts <- function(issues) {
+ # concatenate multiline
+ issues <- gsub("`\033\\[39m +\033\\[32m` +", "", issues)
+ # detect errors that are the same except for a `ggplot2::` prefix
+ cli::ansi_grepl("^(.*?)original(.*?): *`(.*?)` +\n\\1recreated\\2: *`(ggplot2::\\3)`", issues)
+}
+
+
+new_constructive <- function(code, compare) {
+ structure(list(code = code, compare = compare), class = "constructive")
+}
+
+#' Generic for object code generation
+#'
+#' Exported for custom constructor design. `.cstr_construct()` is basically a
+#' naked `construct()`, without the checks, the style, the object post processing etc...
+#'
+#' @inheritParams construct
+#'
+#' @return A character vector
+#' @export
+.cstr_construct <- function(x, ..., data = NULL, classes = NULL) {
+ data_name <- perfect_match(x, data)
+ if (!is.null(data_name)) return(data_name)
+ if (is.null(classes)) {
+ UseMethod(".cstr_construct")
+ } else if (identical(classes, "-")) {
+ .cstr_construct.default(x, ..., classes = classes)
+ } else if (classes[[1]] == "-") {
+ cl <- setdiff(.class2(x), classes[-1])
+ UseMethod(".cstr_construct", structure(NA_integer_, class = cl))
+ } else {
+ cl <- intersect(.class2(x), classes)
+ UseMethod(".cstr_construct", structure(NA_integer_, class = cl))
+ }
+}
+
+process_classes <- function(classes) {
+ if (!length(classes)) return(NULL)
+ classes <- setdiff(classes, "*none*")
+ if ("*base*" %in% classes) {
+ base_packages <- c("base", "utils", "stats", "methods", "grid")
+ classes <- setdiff(c(classes, unlist(all_classes[base_packages])), "*base*")
+ }
+ exclude <- classes[startsWith(classes, "-")]
+ include <- setdiff(classes, exclude)
+ if (length(exclude)) {
+ exclude <- sub("^-", "", exclude)
+ packages_lgl <- grepl("^\\{.*\\}$", exclude)
+ package_nms <- sub("^\\{(.*)\\}$", "\\1", exclude[packages_lgl])
+ exclude <- unique(c(exclude[!packages_lgl], unlist(all_classes[package_nms])))
+ }
+ if (!length(include)) return(c("-", exclude))
+ packages_lgl <- grepl("^\\{.*\\}$", include)
+ package_nms <- sub("^\\{(.*)\\}$", "\\1", include[packages_lgl])
+ include <- unique(c(all_classes[[1]], include[!packages_lgl], unlist(all_classes[package_nms])))
+ include
+}
+
+# cat(sprintf('"%s"', sub("^opts_", "", ls(envir = asNamespace("constructive"), pattern = "^opts_"))), sep = ",\n")
+all_classes <- list(
+ c(
+ ## low level classes that we can't remove
+ "array",
+ "character",
+ "complex",
+ "dots",
+ "double",
+ "environment",
+ "expression",
+ "externalptr",
+ "function",
+ "integer",
+ "language",
+ "list",
+ "logical",
+ "NULL",
+ "object",
+ "pairlist",
+ "raw",
+ "S4",
+ "weakref"
+ ),
+ base = c(
+ "AsIs",
+ "data.frame",
+ "Date",
+ "difftime",
+ "error",
+ "factor",
+ "formula",
+ "hexmode",
+ "matrix",
+ "noquote",
+ "numeric_version",
+ "octmode",
+ "ordered",
+ "package_version",
+ "POSIXct",
+ "POSIXlt",
+ "R_system_version",
+ "simpleCondition",
+ "simpleError",
+ "simpleMessage",
+ "simpleWarning",
+ "warning"
+ ),
+ utils = c(
+ "bibentry",
+ "citationFooter",
+ "citationHeader",
+ "person"
+ ),
+ stats = c(
+ "mts",
+ "ts"
+ ),
+ methods = c(
+ "classGeneratorFunction",
+ "classPrototypeDef",
+ "classRepresentation"
+ ),
+ bit64 = c("integer64"),
+ blob = c(
+ "blob"
+ ),
+ constructive = c(
+ "constructive_options"
+ ),
+ ellmer = c(
+ "ellmer::TypeArray",
+ "ellmer::TypeBasic",
+ "ellmer::TypeEnum",
+ "ellmer::TypeJsonSchema",
+ "ellmer::TypeObject"
+ ),
+ ggplot2 = c(
+ "CoordCartesian",
+ "CoordFixed",
+ "CoordFlip",
+ "CoordMap",
+ "CoordMunch",
+ "CoordPolar",
+ "CoordQuickmap",
+ "CoordRadial",
+ "CoordSf",
+ "CoordTrans",
+ "CoordTransform",
+ "element_blank",
+ "element_grob",
+ "element_line",
+ "element_rect",
+ "element_render",
+ "element_text",
+ "FacetGrid",
+ "FacetNull",
+ "FacetWrap",
+ "ggplot",
+ "ggplot2::element_blank",
+ "ggplot2::element_geom",
+ "ggplot2::element_line",
+ "ggplot2::element_point",
+ "ggplot2::element_polygon",
+ "ggplot2::element_rect",
+ "ggplot2::element_text",
+ "ggplot2::ggplot",
+ "ggplot2::labels",
+ "ggplot2::mapping",
+ "ggplot2::margin",
+ "ggplot2::theme",
+ "ggproto",
+ "Guide",
+ "GuideAxis",
+ "GuideAxisLogticks",
+ "GuideAxisStack",
+ "GuideAxisTheta",
+ "GuideBins",
+ "GuideColourbar",
+ "GuideColoursteps",
+ "GuideCustom",
+ "GuideLegend",
+ "GuideNone",
+ "Guides",
+ "labels",
+ "Layer",
+ "margin",
+ "rel",
+ "Scale",
+ "ScalesList",
+ "theme",
+ "uneval",
+ "waiver"
+ ),
+ data.table = c("data.table"),
+ dm = c("dm"),
+ dplyr = c(
+ "grouped_df",
+ "rowwise_df"
+ ),
+ grid = c(
+ "simpleUnit"
+ ),
+ R6 = c(
+ "R6",
+ "R6ClassGenerator"
+ ),
+ rlang = c(
+ "quosure",
+ "quosures"
+ ),
+ S7 = c(
+ "S7_any",
+ "S7_base_class",
+ "S7_class",
+ "S7_external_generic",
+ "S7_generic",
+ "S7_object",
+ "S7_property",
+ "S7_S3_class",
+ "S7_union"
+ ),
+ tibble = c(
+ "tbl_df"
+ ),
+ vctrs = c(
+ "vctrs_list_of"
+ ),
+ xts = c(
+ "xts"
+ ),
+ zoo = c(
+ "yearmon",
+ "yearqtr",
+ "zoo",
+ "zooreg"
+ )
+)
diff --git a/sub/constructive.core/R/construct.R b/sub/constructive.core/R/construct.R
new file mode 100644
index 00000000..1fe7baa8
--- /dev/null
+++ b/sub/constructive.core/R/construct.R
@@ -0,0 +1,340 @@
+#' Build code to recreate an object
+#'
+#' * `construct()` builds the code to reproduce one object,
+#' * `construct_multi()` builds the code to reproduce objects stored in a named
+#' list or environment.
+#'
+#' @details
+#'
+#' `construct_multi()` recognizes promises (also called lazy bindings),
+#' this means that for instance `construct_multi(environment())` can be called
+#' when debugging a function and will construct unevaluated arguments using
+#' `delayedAssign()`.
+#'
+#' @seealso [construct_dput()] [construct_base()] [construct_clip()]
+#' [construct_dump()] [construct_reprex()] [construct_diff()]
+#'
+#' @param x An object, for `construct_multi()` a named list or an environment.
+#' @param data Named list or environment of objects we want to detect and mention by name (as opposed to
+#' deparsing them further). Can also contain unnamed nested lists, environments, or
+#' package names, in the latter case package exports and datasets will be considered.
+#' In case of conflict, the last provided name is considered.
+#' @param pipe Which pipe to use, either `"base"` or `"magrittr"`.
+#' Defaults to `"base"` for R >= 4.2, otherwise to `"magrittr"`.
+#' @param check Boolean. Whether to check if the created code reproduces the object
+#' using `waldo::compare()`.
+#' @param unicode_representation By default "ascii", which means only ASCII characters
+#' (code point < 128) will be used to construct strings and variable names. This makes sure that
+#' homoglyphs (different spaces and other identically displayed unicode characters)
+#' are printed differently, and avoid possible unfortunate copy and paste
+#' auto conversion issues. "latin" is more lax and uses all latin characters
+#' (code point < 256). "character" shows all characters, but not emojis. Finally
+#' "unicode" displays all characters and emojis, which is what `dput()` does.
+#' @param escape Boolean. Whether to escape double quotes and backslashes. If `FALSE` we use
+#' single quotes to surround strings (including variable and element names)
+#' containing double quotes, and raw strings for strings that contain backslashes
+#' and/or a combination of single and double quotes. Depending on
+#' `unicode_representation` `escape = FALSE` cannot be applied on all strings.
+#' @param pedantic_encoding Boolean. Whether to mark strings with the "unknown" encoding
+#' rather than an explicit native encoding ("UTF-8" or "latin1") when it's
+#' necessary to reproduce the binary representation exactly. This detail is
+#' normally of very little significance. The reason why we're not pedantic by default is that
+#' the constructed code might be different in the console and in snapshot
+#' tests and reprexes due to the latter rounding some angles, and it would
+#' be confusing for users.
+#' @param compare Parameters passed to `waldo::compare()`, built with `compare_options()`.
+#' @param ... Constructive options built with the `opts_*()` family of functions. See the "Constructive options"
+#' section below.
+#' @param one_liner Boolean. Whether to collapse the output to a single line of code.
+#' @param template A list of constructive options built with `opts_*()` functions,
+#' they will be overriden by `...`. Use it to set a default
+#' behavior for `{constructive}`.
+#' @param classes A character vector of classes for which to use idiomatic
+#' constructors when available, we can provide a package instead of all its
+#' classes, in the "\{pkg\}" form, and we can use a minus sign (inside the quotes)
+#' to exclude rather than include. By default we use idiomatic constructors
+#' whenever possible. The special values `"*none*"` and `"*base*"` can be used
+#' to restrict the idiomatic construction to the objects. See `construct_dput()`
+#' and `construct_base()` for wrappers around this feature.
+#' @param include_dotted Whether to include names starting with dots, this includes
+#' `.Random.seed` in the global environment and objects like `.Class` and
+#' `.Generic` in the execution environments of S3 methods.
+#' @return An object of class 'constructive'.
+#' @enumerateOptFunctions
+#'
+#' @export
+#' @examples
+#' construct(head(cars))
+#' construct(head(cars), opts_data.frame("read.table"))
+#' construct(head(cars), opts_data.frame("next"))
+#' construct(iris$Species)
+#' construct(iris$Species, opts_atomic(compress = FALSE), opts_factor("new_factor"))
+#' construct_multi(list(a = head(cars), b = iris$Species))
+construct <- function(
+ x,
+ ...,
+ data = NULL,
+ pipe = NULL,
+ check = NULL,
+ unicode_representation = c("ascii", "latin", "character", "unicode"),
+ escape = FALSE,
+ pedantic_encoding = FALSE,
+ compare = compare_options(), one_liner = FALSE,
+ template = getOption("constructive_opts_template"),
+ classes = NULL) {
+
+ # reset globals
+ globals$predefinition <- character()
+ globals$envs <- data.frame(hash = character(), name = character())
+ globals$pedantic_encoding <- pedantic_encoding
+
+ # check inputs
+ .cstr_combine_errors(
+ # force so we might fail outside of the try_fetch() when x is not properly provided
+ force(x),
+ check_dots_unnamed(),
+ abort_wrong_data(data),
+ abort_not_boolean(one_liner),
+ abort_not_boolean(escape),
+ { unicode_representation <- rlang::arg_match(unicode_representation) }
+ )
+
+ opts <- collect_opts(..., template = template)
+
+ # process data into a flat named list of objects
+ data <- process_data(data)
+ classes <- process_classes(classes)
+
+ # build code that produces the object, prepend with predefinitions if relevant
+ caller <- user_env()
+ code <- try_construct(
+ x,
+ opts = opts,
+ template = template,
+ data = data,
+ pipe = pipe,
+ unicode_representation = unicode_representation,
+ unicode_representation.chr =
+ opts$character$unicode_representation %||%
+ opts$atomic$unicode_representation %||%
+ unicode_representation,
+ escape = escape,
+ escape.chr =
+ opts$character$escape %||%
+ opts$atomic$escape %||%
+ escape,
+ one_liner = one_liner,
+ env = caller,
+ classes = classes
+ )
+ code <- c(globals$predefinition, code)
+
+ # attempt to parse, and style if successful
+ styled_code <- try_parse(code, one_liner)
+
+ # check output fidelity if relevant, signal issues and update globals$issues
+ compare <- check_round_trip(x, styled_code, data, check, compare, caller)
+
+ # build a new constructive object, leave the display work to the print method
+ new_constructive(styled_code, compare)
+}
+
+#' @export
+#' @rdname construct
+construct_multi <- function(
+ x,
+ ...,
+ data = NULL,
+ pipe = NULL,
+ check = NULL,
+ unicode_representation = c("ascii", "latin", "character", "unicode"),
+ escape = FALSE,
+ pedantic_encoding = FALSE,
+ compare = compare_options(),
+ one_liner = FALSE,
+ template = getOption("constructive_opts_template"),
+ classes = NULL,
+ include_dotted = TRUE
+ ) {
+ abort_not_env_or_named_list(x)
+ data <- process_data(data)
+ unicode_representation <- match.arg(unicode_representation)
+
+ if (is.list(x)) {
+ if (!include_dotted) {
+ nms <- grep("^[^.]|([.][.][.])", names(x), value = TRUE)
+ x <- x[nms]
+ }
+
+ constructives <- lapply(
+ x, construct, ...,
+ data = data, pipe = pipe, check = check,
+ unicode_representation = unicode_representation,
+ escape = escape,
+ pedantic_encoding = pedantic_encoding,
+ compare = compare,
+ one_liner = one_liner,
+ template = template,
+ classes = classes
+ )
+ } else if (is.environment(x)) {
+ opts <- collect_opts(..., template = template)
+ constructives <- list()
+
+ # ls() sorts names alphabetically while names() displays from most to least
+ # recently defined. Taking the reverse of names() will create the most
+ # natural looking reprexes
+ nms <- rev(names(x))
+ if (!include_dotted) {
+ nms <- grep("^[^.]|([.][.][.])", nms, value = TRUE)
+ }
+
+ for (nm in nms) {
+ if (rlang::env_binding_are_lazy(x, nm)) {
+ code <- do.call(substitute, list(as.name(nm), x))
+ env <- promise_env(as.symbol(nm), x)
+
+ name_code <- .cstr_construct(
+ nm,
+ opts = opts,
+ unicode_representation.chr = unicode_representation,
+ escape.chr = escape,
+ unicode_representation = unicode_representation,
+ escape = escape
+ )
+
+ value_code <- deparse_call(
+ code,
+ style = FALSE,
+ unicode_representation = unicode_representation,
+ escape = escape,
+ pedantic_encoding = pedantic_encoding
+ )
+
+ env_code <- .cstr_construct(
+ env,
+ opts = opts,
+ unicode_representation.chr = unicode_representation,
+ escape.chr = escape,
+ unicode_representation = unicode_representation,
+ escape = escape
+ )
+
+ code <- .cstr_apply(
+ list(
+ name_code,
+ value = value_code,
+ eval.env = env_code
+ ),
+ "delayedAssign",
+ recurse = FALSE
+ )
+ # FIXME: we don't collect issues yet here
+ constructives[[nm]] <- new_constructive(code, NULL)
+ } else {
+ constructives[[nm]] <- construct(
+ x[[nm]],
+ ...,
+ data = data,
+ pipe = pipe,
+ check = check,
+ unicode_representation = unicode_representation,
+ escape = escape,
+ pedantic_encoding = pedantic_encoding,
+ compare = compare,
+ one_liner = one_liner,
+ template = template,
+ classes = classes
+ )
+ }
+ }
+ } else {
+ abort("wrong input!")
+ }
+
+ code <- lapply(constructives, `[[`, "code")
+ issues <- lapply(constructives, `[[`, "compare")
+ issues <- Filter(Negate(is.null), issues)
+ globals$issues <- issues
+ code <- Map(
+ code, names(code),
+ f = function(x, y) {
+ if (startsWith(x[[1]], "delayedAssign(")) return(x)
+ y <- construct_string(y, unicode_representation, escape, mode = "name")
+ x[[1]] <- paste(y, "<-", x[[1]])
+ c(x, "")
+ })
+ code <- unlist(code)
+ Encoding(code) <- "UTF-8"
+ if (is.null(code)) code <- character(0)
+ code <- as_constructive_code(unname(code))
+ new_constructive(code, issues)
+}
+
+#' @export
+print.constructive <- function(
+ x,
+ print_mode = getOption("constructive_print_mode", default = "console"),
+ ...) {
+ print_mode <- arg_match(
+ print_mode,
+ values = c("console", "script", "reprex", "clipboard"),
+ multiple = TRUE
+ )
+
+ if ("clipboard" %in% print_mode) {
+ check_installed("clipr")
+ cli::cli_alert_info("Code has been added to the clipboard")
+ clipr::write_clip(paste(x$code, collapse = "\n"), "character")
+ }
+ if ("console" %in% print_mode) {
+ print(x$code)
+ }
+ if ("reprex" %in% print_mode) {
+ check_installed("reprex")
+ reprex_code <- c('getFromNamespace("prex", "reprex")({', x$code, "})")
+ eval.parent(parse(text = reprex_code))
+ }
+ if ("script" %in% print_mode) {
+ check_installed("rstudioapi")
+ rstudioapi::documentNew(x$code, "r")
+ }
+ invisible(x)
+}
+
+
+
+#' Print code with syntax highlighting
+#'
+#' @param x The object to print
+#' @param ... Unused
+#' @param colored Whether to apply syntax highlighting. Set to `FALSE`, or use
+#' `options(constructive_pretty = FALSE)` to turn off highlighting.
+#' @param code_theme Syntax highlighting theme passed to [cli::code_highlight()].
+#' Setting `code_theme = list()` will remove all syntax highlighting, but
+#' hyperlinks will remain if supported.
+#' @param style Deprecated in favour of `code_theme`
+#' @keywords internal
+#' @export
+print.constructive_code <- function(
+ x,
+ ...,
+ colored = getOption("constructive_pretty", TRUE),
+ code_theme = NULL,
+ style = NULL
+) {
+ if (!is.null(style)) {
+ deprecate_soft(c(
+ "The `style` argument of `print.constructive_code()` is deprecated as of constructive 1.0.2",
+ i = "Please use the `code_theme` argument instead"
+ ))
+ }
+
+ x <- highlight_code(x, code_theme, colored)
+ cat(x, sep = "\n")
+ invisible(x)
+}
+
+as_constructive_code <- function(x) {
+ structure(x, class = "constructive_code")
+}
diff --git a/sub/constructive.core/R/construct_clip.R b/sub/constructive.core/R/construct_clip.R
new file mode 100644
index 00000000..42d56b68
--- /dev/null
+++ b/sub/constructive.core/R/construct_clip.R
@@ -0,0 +1,43 @@
+#' Construct to clipboard
+#'
+#' This is a simple wrapper for convenience, `construct_clip(x, ...)` is equivalent to
+#' `print(construct(x, ...), print_mode = "clipboard")` (an idiom that you might
+#' use to use the clipboard with other functions). For more flexible printing
+#' options see `?constructive_print_mode`.
+#'
+#' @inheritParams construct
+#'
+#' @return An object of class 'constructive', invisibly. Called for side effects.
+#' @export
+#'
+#' @examples
+#' \dontrun{
+#' construct_clip(head(cars))
+#' }
+construct_clip <- function(
+ x,
+ ...,
+ data = NULL,
+ pipe = NULL,
+ check = NULL,
+ unicode_representation = c("ascii", "latin", "character", "unicode"),
+ escape = FALSE,
+ pedantic_encoding = FALSE,
+ compare = compare_options(), one_liner = FALSE,
+ template = getOption("constructive_opts_template"),
+ classes = NULL) {
+ out <- construct(
+ x,
+ ...,
+ data = data,
+ pipe = pipe,
+ check = check,
+ unicode_representation = unicode_representation,
+ escape = escape,
+ pedantic_encoding = pedantic_encoding,
+ compare = compare,
+ template = template,
+ classes = classes
+ )
+ print(out, print_mode = union("clipboard", getOption("constructive_print_mode", "console")))
+}
diff --git a/sub/constructive.core/R/construct_diff.R b/sub/constructive.core/R/construct_diff.R
new file mode 100644
index 00000000..bdc60572
--- /dev/null
+++ b/sub/constructive.core/R/construct_diff.R
@@ -0,0 +1,99 @@
+#' Display diff of object definitions
+#'
+#' This calls `construct()` on two objects and compares the output using
+#' `diffobj::diffChr()`.
+#'
+#' @inheritParams construct
+#' @inheritParams diffobj::diffChr
+#' @param mode,interactive passed to `diffobj::diffChr()`
+#' @return Returns `NULL` invisibly, called for side effects
+#' @export
+#'
+#' @examples
+#' \dontrun{
+#' # some object print the same though they're different
+#' # `construct_diff()` shows how they differ :
+#' df1 <- data.frame(a=1, b = "x")
+#' df2 <- data.frame(a=1L, b = "x", stringsAsFactors = TRUE)
+#' attr(df2, "some_attribute") <- "a value"
+#' df1
+#' df2
+#' construct_diff(df1, df2)
+#'
+#'
+#' # Those are made easy to compare
+#' construct_diff(substr, substring)
+#' construct_diff(month.abb, month.name)
+#'
+#' # more examples borrowed from {waldo} package
+#' construct_diff(c("a", "b", "c"), c("a", "B", "c"))
+#' construct_diff(c("X", letters), c(letters, "X"))
+#' construct_diff(list(factor("x")), list(1L))
+#' construct_diff(df1, df2)
+#' x <- list(a = list(b = list(c = list(structure(1, e = 1)))))
+#' y <- list(a = list(b = list(c = list(structure(1, e = "a")))))
+#' construct_diff(x, y)
+#' }
+construct_diff <- function(
+ target,
+ current, ...,
+ data = NULL,
+ pipe = NULL,
+ check = TRUE,
+ compare = compare_options(),
+ one_liner = FALSE,
+ template = getOption("constructive_opts_template"),
+ classes = NULL,
+ mode = c("sidebyside", "auto", "unified", "context"),
+ interactive = TRUE) {
+ mode <- match.arg(mode)
+ tar.banner <- format_call_for_diffobj_banner(substitute(target), interactive = interactive)
+ cur.banner <- format_call_for_diffobj_banner(substitute(current), interactive = interactive)
+
+ target_code <- construct(
+ target,
+ ...,
+ data = data,
+ pipe = pipe,
+ check = check,
+ compare = compare,
+ one_liner = one_liner,
+ template = template,
+ classes = classes
+ )$code
+ current_code <- construct(
+ current,
+ ...,
+ data = data,
+ pipe = pipe,
+ check = check,
+ compare = compare,
+ one_liner = one_liner,
+ template = template,
+ classes = classes
+ )$code
+
+ if (identical(target_code, current_code)) {
+ rlang::inform("No difference to show!")
+ return(invisible(NULL))
+ }
+
+ f <- tempfile(fileext = ".html")
+ diffobj::diffChr(
+ target_code,
+ current_code,
+ mode = mode,
+ tar.banner = tar.banner,
+ cur.banner = cur.banner,
+ pager = list(file.path = f),
+ interactive = interactive
+ )
+}
+
+format_call_for_diffobj_banner <- function(call, interactive) {
+ deparsed <- rlang::expr_deparse(call)
+ if (!interactive) return(paste(deparsed, collapse = " "))
+ multiline <- paste(deparsed, collapse = "
")
+ idented <- gsub(" ", " ", multiline)
+ idented
+}
diff --git a/sub/constructive.core/R/construct_dput.R b/sub/constructive.core/R/construct_dput.R
new file mode 100644
index 00000000..15031894
--- /dev/null
+++ b/sub/constructive.core/R/construct_dput.R
@@ -0,0 +1,79 @@
+#' Construct using only low level constructors
+#'
+#' * `construct_dput()` is a closer counterpart to `base::dput()` that doesn't
+#' use higher level constructors such as `data.frame()` and `factor()`.
+#' * `construct_base()` uses higher constructors, but only for the classes
+#' maintained in the default base R packages. This includes `data.frame()`
+#' and `factor()`, the S4 constructors from the 'method' package etc,
+#' but not `data.table()` and other constructors for classes from other
+#' packages.
+#'
+#' Both functions are valuable for object inspection, and might provide more
+#' stable snapshots, since supporting more classes in the package means
+#' the default output of `construct()` might change over time for some objects.
+#'
+#' To use higher level constructor from the base package itself, excluding
+#' for instance `stats::ts()`, `utils::person()` or
+#' `methods::classGeneratorFunction()`), we can call `construct(x, classes = "{base}"`
+#'
+#' @inheritParams construct
+#'
+#' @return An object of class 'constructive'.
+#' @export
+#'
+#' @examples
+#' construct_dput(head(iris, 2))
+#' construct_base(head(iris, 2))
+construct_dput <- function(
+ x,
+ ...,
+ data = NULL,
+ pipe = NULL,
+ check = NULL,
+ unicode_representation = c("ascii", "latin", "character", "unicode"),
+ escape = FALSE,
+ pedantic_encoding = FALSE,
+ compare = compare_options(), one_liner = FALSE,
+ template = getOption("constructive_opts_template")) {
+ construct(
+ x,
+ ...,
+ data = data,
+ pipe = pipe,
+ check = check,
+ unicode_representation = unicode_representation,
+ escape = escape,
+ pedantic_encoding = pedantic_encoding,
+ compare = compare,
+ template = template,
+ classes = "*none*"
+ )
+}
+
+#' @export
+#' @rdname construct_dput
+construct_base <- function(
+ x,
+ ...,
+ data = NULL,
+ pipe = NULL,
+ check = NULL,
+ unicode_representation = c("ascii", "latin", "character", "unicode"),
+ escape = FALSE,
+ pedantic_encoding = FALSE,
+ compare = compare_options(), one_liner = FALSE,
+ template = getOption("constructive_opts_template")) {
+ construct(
+ x,
+ ...,
+ data = data,
+ pipe = pipe,
+ check = check,
+ unicode_representation = unicode_representation,
+ escape = escape,
+ pedantic_encoding = pedantic_encoding,
+ compare = compare,
+ template = template,
+ classes = "*base*"
+ )
+}
diff --git a/sub/constructive.core/R/construct_dump.R b/sub/constructive.core/R/construct_dump.R
new file mode 100644
index 00000000..df89c618
--- /dev/null
+++ b/sub/constructive.core/R/construct_dump.R
@@ -0,0 +1,20 @@
+#' Dump Constructed Code to a File
+#'
+#' An alternative to `base::dump()` using code built with \pkg{constructive}.
+#'
+#' @param x A named list or an environment.
+#' @param path File or connection to write to.
+#' @param append If FALSE, will overwrite existing file. If TRUE, will append to existing file. In both cases, if the file does not exist a new file is created.
+#' @param ... Forwarded to `construct_multi()`
+#'
+#' @return Returns `NULL` invisibly, called for side effects.
+#' @export
+construct_dump <- function(x, path, append = FALSE, ...) {
+ .cstr_combine_errors(
+ x,
+ abort_not_string(path)
+ )
+ constructive <- construct_multi(x, ...)
+ cat(constructive$code, file = path, sep = "\n", append = append)
+ invisible(NULL)
+}
diff --git a/sub/constructive.core/R/construct_idiomatic.R b/sub/constructive.core/R/construct_idiomatic.R
new file mode 100644
index 00000000..ac01ecec
--- /dev/null
+++ b/sub/constructive.core/R/construct_idiomatic.R
@@ -0,0 +1,128 @@
+#' @export
+.cstr_construct.default <- function(x, ...) {
+ classes <- list(...)$classes
+ if (is.matrix(x) && (is.null(classes) || "matrix" %in% classes)) {
+ return(.cstr_construct.matrix(x, ...))
+ }
+ if (is.array(x) && (is.null(classes) ||"array" %in% classes)) {
+ return(.cstr_construct.array(x, ...))
+ }
+ switch(
+ typeof(x),
+ environment = .cstr_construct.environment(x, ...),
+ list = .cstr_construct.list(x, ...),
+ special = ,
+ builtin = ,
+ closure = .cstr_construct.function(x, ...),
+ symbol = ,
+ language = .cstr_construct.language(x, ...),
+ `...` = .cstr_construct.dots(x, ...),
+ externalptr = .cstr_construct.externalptr(x, ...),
+ S4 = .cstr_construct.S4(x, ...),
+ object = .cstr_construct.object(x, ...),
+ character = .cstr_construct.character(x, ...),
+ integer = .cstr_construct.integer(x, ...),
+ double = .cstr_construct.double(x, ...),
+ complex = .cstr_construct.complex(x, ...),
+ logical = .cstr_construct.logical(x, ...),
+ raw = .cstr_construct.raw(x, ...),
+ `NULL` = .cstr_construct.NULL(x, ...)
+ )
+}
+
+#' .cstr_apply
+#'
+#' Exported for custom constructor design. If `recurse` is `TRUE` (default), we
+#' recurse to construct `args` and insert their construction code in a `fun(...)` call returned
+#' as a character vector. If `args` already contains code rather than object to
+#' construct one should set `recurse` to `FALSE`.
+#'
+#' @param args A list of arguments to construct recursively, or code if `recurse = FALSE`.
+#' If elements are named, the arguments will be named in the generated code.
+#' @param fun The function name to use to build code of the form "fun(...)"
+#' @param ... Options passed recursively to the further methods
+#' @param trailing_comma Boolean. Whether to leave a trailing comma after the last argument if
+#' the code is multiline, some constructors allow it (e.g. `tibble::tibble()`) and it makes for nicer
+#' diffs in version control.
+#' @param recurse Boolean. Whether to recursively generate the code to construct `args`. If `FALSE` arguments
+#' are expected to contain code.
+#' @param implicit_names When data is provided, compress calls of the form `f(a = a)` to `f(a)`
+#' @param new_line Boolean. Forwarded to `wrap()` to add a line between "fun(" and ")", forced to
+#' `FALSE` if `one_liner` is `TRUE`
+#' @param one_liner Boolean. Whether to return a one line call.
+#' @inheritParams construct
+#'
+#' @export
+#' @return A character vector of code
+#'
+#' @examples
+#' a <- 1
+#' .cstr_apply(list(a=a), "foo")
+#' .cstr_apply(list(a=a), "foo", data = list(a=1))
+#' .cstr_apply(list(a=a), "foo", data = list(a=1), implicit_names = TRUE)
+#' .cstr_apply(list(b=a), "foo", data = list(a=1), implicit_names = TRUE)
+#' .cstr_apply(list(a="c(1,2)"), "foo")
+#' .cstr_apply(list(a="c(1,2)"), "foo", recurse = FALSE)
+.cstr_apply <- function(
+ args,
+ fun = "list",
+ ...,
+ trailing_comma = FALSE,
+ recurse = TRUE,
+ implicit_names = FALSE,
+ new_line = TRUE,
+ one_liner = FALSE,
+ unicode_representation = c("ascii", "latin", "character", "unicode"),
+ escape = FALSE) {
+ new_line <- new_line && !one_liner
+ trailing_comma <- trailing_comma && !one_liner
+ unicode_representation <- match.arg(unicode_representation)
+ # so we make sure we use the right methods for length, [, [[
+ # and lapply iterates properly at the low level
+ args <- unclass(args)
+ if (!length(args)) return(sprintf("%s()", fun))
+ if (recurse) args <- lapply(
+ args,
+ # for some reason, using simply .cstr_construct on the next line doesn't
+ # dispatch to the right method
+ function(x, ...) .cstr_construct(x, ...),
+ ...,
+ one_liner = one_liner,
+ unicode_representation = unicode_representation,
+ escape = escape
+ )
+ args_chr <- Map(
+ name_and_append_comma,
+ unname(args),
+ names2(args),
+ MoreArgs = list(
+ implicit_names = implicit_names,
+ unicode_representation = unicode_representation,
+ escape = escape
+ )
+ )
+ args_chr <- unlist(args_chr)
+ # if line is short enough stick all in one line
+ # FIXME : chunk unnamed lists of single line items by lines of 80 chars ?
+ nchrs <- nchar(args_chr)
+
+ one_liner <- one_liner || (sum(nchrs) < 80 && all(endsWith(args_chr, ",")))
+ if (one_liner) {
+ args_chr <- paste(args_chr, collapse = " ")
+ new_line <- FALSE
+ trailing_comma <- FALSE
+ } else if (all(rlang::names2(args) == "") && all(endsWith(args_chr, ","))) {
+ lines <- character()
+ while (length(args_chr)) {
+ ind <- union(1, which(cumsum(nchar(args_chr) + 1) < 80))
+ lines[[length(lines) + 1]] <- paste(args_chr[ind], collapse = " ")
+ args_chr <- args_chr[-ind]
+ }
+ args_chr <- lines
+ }
+ if (!trailing_comma) {
+ args_chr[[length(args_chr)]] <- sub(",$", "", args_chr[[length(args_chr)]])
+ }
+
+ .cstr_wrap(args_chr, fun, new_line)
+}
diff --git a/sub/constructive.core/R/construct_issues.R b/sub/constructive.core/R/construct_issues.R
new file mode 100644
index 00000000..8fb317ba
--- /dev/null
+++ b/sub/constructive.core/R/construct_issues.R
@@ -0,0 +1,14 @@
+#' Show constructive issues
+#'
+#' Usually called without arguments right after an imperfect code generation,
+#' but can also be called on the 'constructive' object itself.
+#'
+#' @param x An object built by `construct()`, if `NULL` the latest encountered
+#' issues will be displayed
+#'
+#' @return A character vector with class "waldo_compare"
+#' @export
+construct_issues <- function(x = NULL) {
+ if (is.null(x)) return(globals$issues) # nocov
+ x$compare
+}
diff --git a/sub/constructive.core/R/construct_reprex.R b/sub/constructive.core/R/construct_reprex.R
new file mode 100644
index 00000000..c24a035a
--- /dev/null
+++ b/sub/constructive.core/R/construct_reprex.R
@@ -0,0 +1,57 @@
+#' construct_reprex
+#'
+#' @description
+#'
+#' `construct_reprex()` constructs all objects of the local environment,
+#' or a caller environment `n` steps above. If `n > 0` the function call
+#' is also included in a comment.
+#'
+#' @details
+#'
+#' `construct_reprex()` doesn't call the \{reprex\} package. `construct_reprex()`
+#' builds reproducible data while the reprex package build reproducible output
+#' once you have the data.
+#'
+#' `construct_reprex()` wraps `construct_multi()` and is thus able to construct
+#' unevaluated arguments using `delayedAssign()`. This means we can construct
+#' reprexes for functions that use Non Standard Evaluation.
+#'
+#' A useful trick is to use `options(error = recover)` to be able to inspect
+#' frames on error, and use `construct_reprex()` from there to reproduce the
+#' data state.
+#'
+#' `construct_reprex()` might fail to reproduce the output of functions that refer
+#' to environments other than their caller environment. We believe these are
+#' very rare and that the simplicity is worth the rounded corners, but if you
+#' encounter these limitations please do open a ticket on our issue tracker
+#' at `https://github.com/cynkra/constructive/` and we might expand the feature.
+#'
+#' @param ... Forwarded to `construct_multi()`
+#' @param n The number of steps to go up on the call stack
+#' @inheritParams construct_multi
+#'
+#' @return An object of class 'constructive'.
+#' @seealso [construct_multi()]
+#' @export
+construct_reprex <- function(..., n = 0, include_dotted = TRUE) {
+ stopifnot(n >= 0)
+ caller_env <- parent.frame(1 + n)
+ if (n == 0) {
+ return(construct_multi(caller_env, ..., include_dotted = include_dotted))
+ }
+
+ call <- sys.call(-n)
+ fun <- sys.function(-n)
+
+ # output ---------------------------------------------------------------------
+ if (length(names(caller_env))) {
+ constructed <- construct_multi(caller_env, ..., include_dotted = include_dotted)
+ constructed$code <- as_constructive_code(
+ c(constructed$code, paste("#", deparse_call(call, style = FALSE)))
+ )
+ } else {
+ code <- paste("#", deparse_call(call))
+ constructed <- new_constructive(code, compare = NULL)
+ }
+ constructed
+}
diff --git a/sub/constructive.core/R/construct_signature.R b/sub/constructive.core/R/construct_signature.R
new file mode 100644
index 00000000..832a15bf
--- /dev/null
+++ b/sub/constructive.core/R/construct_signature.R
@@ -0,0 +1,28 @@
+#' Construct a function's signature
+#'
+#' Construct a function's signature such as the one you can see right below in
+#' the 'Usage' section.
+#'
+#' @param x A function
+#' @param name The name of the function, by default we use the symbol provided to `x`
+#' @inheritParams deparse_call
+#'
+#' @export
+#' @return a string or a character vector, with a class "constructive_code" for pretty
+#' printing if `style` is `TRUE`
+#' @examples
+#' construct_signature(lm)
+construct_signature <- function(x, name = NULL, one_liner = FALSE, style = TRUE) {
+ if (is.null(name)) {
+ name <- as.character(substitute(x))
+ if (length(name) > 1) abort("`name` should be of length 1")
+ }
+ fun_lst <- as.list(x)
+ empty_lgl <- sapply(fun_lst, identical, quote(expr=))
+ fun_lst[empty_lgl] <- lapply(names(fun_lst)[empty_lgl], as.symbol)
+ names(fun_lst)[empty_lgl] <- ""
+ names(fun_lst)[!empty_lgl] <- protect(names(fun_lst)[!empty_lgl])
+ name <- protect(name)
+ signature_lng <- as.call(c(as.symbol(name), fun_lst[-length(fun_lst)]))
+ deparse_call(signature_lng, one_liner = one_liner, style = style)
+}
diff --git a/sub/constructive.core/R/constructive-package.R b/sub/constructive.core/R/constructive-package.R
new file mode 100644
index 00000000..7f23f4f4
--- /dev/null
+++ b/sub/constructive.core/R/constructive-package.R
@@ -0,0 +1,20 @@
+globals <- new.env()
+
+# FIXME: find a way to support extensions better
+globals$ggpackages <- "ggplot2"
+
+#' @keywords internal
+"_PACKAGE"
+
+#' @import rlang
+#' @importFrom utils capture.output head tail getFromNamespace
+#' packageDescription methods
+#' @importFrom stats setNames
+#' @importFrom methods getSlots
+#' @importFrom grDevices pdf dev.off
+#' @useDynLib constructive.core, .registration = TRUE
+NULL
+
+## usethis namespace: start
+## usethis namespace: end
+NULL
diff --git a/sub/constructive.core/R/contains_self_reference.R b/sub/constructive.core/R/contains_self_reference.R
new file mode 100644
index 00000000..4698212f
--- /dev/null
+++ b/sub/constructive.core/R/contains_self_reference.R
@@ -0,0 +1,50 @@
+# FIXME: instead of returning TRUE we could keep tract of nesting like waldo
+# does and return the location of the problematic env
+contains_self_reference <- function(
+ x,
+ envs = character(),
+ check_parent = TRUE,
+ check_function_env = TRUE,
+ check_srcref = FALSE
+ ) {
+ rec <- function(x) {
+ contains_self_reference(x, envs, check_parent, check_function_env, check_srcref)
+ }
+ if (is.null(x)) return(FALSE)
+ if (is.environment(x)) {
+ if (!is.null(construct_special_env(x))) return(FALSE)
+ address <- rlang::obj_address(x)
+ if (address %in% envs) return(TRUE)
+ envs <- c(envs, address)
+ # since we override S3 dispatch here we can circumvent rlang bug
+ # https://github.com/r-lib/rlang/issues/1783
+ bindings <- names(x)
+ lazy_bindings <- bindings[rlang::env_binding_are_lazy(x, bindings)]
+ lazy_binding_envs <- lapply(lazy_bindings, promise_env, x)
+ for (lazy_binding_env in lazy_binding_envs) {
+ if (rec(lazy_binding_env)) return(TRUE)
+ }
+ bindings <- setdiff(bindings, lazy_bindings)
+ for (binding in bindings) {
+ obj <- get(binding, x)
+ if (rec(obj)) return(TRUE)
+ }
+ if (check_parent && rec(parent.env(x))) return(TRUE)
+ } else if (is.list(x)) {
+ for (elt in x) {
+ if (rec(elt)) return(TRUE)
+ }
+ } else if (is.function(x)) {
+ if (check_function_env && rec(environment(x))) return(TRUE)
+ if (!check_srcref) attr(x, "srcref") <- NULL
+ }
+ # this correctly uses the updated envs if x is an environment
+
+ if (rec(names(x))) return(TRUE)
+ attrs <- attributes(x)
+ attrs$names <- NULL
+ # to avoid infinite recursion we don't inspect names
+ # names can be only characters so there
+ if (length(attrs) && rec(attrs)) return(TRUE)
+ FALSE
+}
diff --git a/sub/constructive.core/R/custom_constructors.R b/sub/constructive.core/R/custom_constructors.R
new file mode 100644
index 00000000..b69ff0f8
--- /dev/null
+++ b/sub/constructive.core/R/custom_constructors.R
@@ -0,0 +1,18 @@
+#' Extend constructive
+#'
+#' @description
+#' We export a collection of functions that can be used to design custom methods for
+#' \link{.cstr_construct}() or custom constructors for a given method.
+#'
+#' * \link{.cstr_new_class}() : Open template to support a new class
+#' * \link{.cstr_new_constructor}() : Open template to implement a new constructor
+#' * \link{.cstr_construct}() : Low level generic for object construction code generation
+#' * \link{.cstr_repair_attributes}()` : Helper to repair attributes of objects
+#' * \link{.cstr_options}() : Define and check options to pass to custom constructors
+#' * \link{.cstr_apply}() : Build recursively the arguments passed to your constructor
+#' * \link{.cstr_wrap}() : Wrap argument code in function code (rarely needed)
+#' * \link{.cstr_pipe}() : Pipe a call to another (rarely needed)
+#' * \link{.cstr_combine_errors}() : helper function report several errors
+#' at once when relevant
+#' @name extend-constructive
+NULL
diff --git a/sub/constructive.core/R/deparse_call.R b/sub/constructive.core/R/deparse_call.R
new file mode 100644
index 00000000..b367af1c
--- /dev/null
+++ b/sub/constructive.core/R/deparse_call.R
@@ -0,0 +1,270 @@
+#' Deparse a language object
+#'
+#' An alternative to `base::deparse()` and `rlang::expr_deparse()` that
+#' handles additional corner cases and fails when encountering tokens other than
+#' symbols and syntactic literals where cited alternatives would produce non syntactic code.\cr\cr
+#'
+#' @param call A call.
+#' @param one_liner Boolean. Whether to collapse multi-line expressions on a single line using
+#' semicolons.
+#' @param pipe Boolean. Whether to use the base pipe to disentangle nested calls. This
+#' works best on simple calls.
+#' @param style Boolean. Whether to give a class "constructive_code" on the output
+#' for pretty printing.
+#' @param collapse Boolean. Whether to collapse the output to a single string,
+#' won't be directly visible if `style` is `TRUE`.
+#' @inheritParams construct
+#'
+#' @return a string or a character vector, with a class "constructive_code" for pretty
+#' printing if `style` is `TRUE`.
+#' @export
+#'
+#' @examples
+#' expr <- quote(foo(bar({this; that}, 1)))
+#' deparse_call(expr)
+#' deparse_call(expr, one_liner = TRUE)
+#' deparse_call(expr, pipe = TRUE)
+#' deparse_call(expr, style = FALSE)
+deparse_call <- function(
+ call,
+ one_liner = FALSE,
+ pipe = FALSE,
+ style = TRUE,
+ collapse = !style,
+ unicode_representation = c("ascii", "latin", "character", "unicode"),
+ escape = FALSE,
+ pedantic_encoding = FALSE) {
+
+ .cstr_combine_errors(
+ abort_not_boolean(one_liner),
+ abort_not_boolean(pipe),
+ abort_not_boolean(style),
+ abort_not_boolean(collapse),
+ { unicode_representation <- rlang::arg_match(unicode_representation) },
+ abort_not_boolean(escape)
+ )
+
+ globals$pedantic_encoding <- pedantic_encoding
+
+ code <- rlang::try_fetch(
+ deparse_call_impl(
+ call,
+ one_liner,
+ 0,
+ pipe,
+ check_syntactic = TRUE,
+ unicode_representation,
+ escape,
+ lisp_equal = FALSE
+ ),
+ error = function(cnd) {
+ abort("`call` must only be made of symbols and syntactic literals", parent = cnd)
+ })
+ if (!collapse) {
+ code <- split_by_line(code)
+ }
+ if (style) {
+ code <- as_constructive_code(code)
+ }
+ code
+}
+
+# a dot absorbing stripped down version of deparse_call() to be used internally
+deparse_call0 <- function(
+ call,
+ one_liner = FALSE,
+ unicode_representation = c("ascii", "latin", "character", "unicode"),
+ escape = FALSE,
+ ...) {
+ code <- deparse_call_impl(
+ call,
+ one_liner = one_liner,
+ unicode_representation = unicode_representation,
+ escape = escape,
+ lisp_equal = TRUE
+ )
+ split_by_line(code)
+}
+
+deparse_call_impl <- function(
+ call,
+ one_liner = FALSE,
+ indent = 0,
+ pipe = FALSE,
+ check_syntactic = TRUE,
+ unicode_representation = "ascii",
+ escape = FALSE,
+ lisp_equal = FALSE, # To handle `=` as top level caller, e.g. quote(`=`(x, 1))
+ force_lisp = FALSE # To prevent callers from using the infix form, e.g. `+`(x, y)(z)
+) {
+
+ # helper to avoid forwarding all args all the time
+ rec <- function(call, ...) {
+ # override defaults
+ if (...length()) list2env(list(...), environment())
+ deparse_call_impl(
+ call,
+ one_liner,
+ indent,
+ pipe,
+ check_syntactic,
+ unicode_representation,
+ escape,
+ force_lisp = force_lisp
+ )
+ }
+
+ if (is.symbol(call))
+ return(deparse_symbol(call, check_syntactic, unicode_representation))
+
+ check_syntactic <- TRUE
+
+ # artificial cases where caller is NULL, a numeric etc
+ if (is_syntactic_literal2(call))
+ return(deparse_syntactic_literal(call, unicode_representation, escape))
+
+ if (!is.call(call)) {
+ code <- paste(capture.output(construct(call, check = FALSE)), collapse = "\n")
+ msg <- sprintf("Found element of type '%s' and length '%s':\n%s", typeof(call), length(call), code)
+ abort(msg)
+ }
+
+ if (length(call) == 2 && identical(call[[2]], quote(expr = ))) {
+ code <- paste(capture.output(construct(call, check = FALSE)), collapse = "\n")
+ msg <- sprintf("Found empty symbol used as sole argument of a function:\n%s", code)
+ abort(msg)
+ }
+
+ if (identical(call[[1]], quote(expr=))) {
+ code <- paste(capture.output(construct(call, check = FALSE)), collapse = "\n")
+ msg <- sprintf("Found empty symbol used as caller:\n%s", code)
+ abort(msg)
+ }
+
+ caller_lng <- call[[1]]
+ # if the caller is not a symbol in order to parse we need to express it in lisp form
+ # for instance `+`(1, 2)(3), hence force_lisp() below.
+ # This does NOT apply if the caller is a call to `::` or `:::`!
+ caller_calls_colon_ops <-
+ is.call(caller_lng) && list(caller_lng[[1]]) %in% list(
+ quote(`::`), quote(`:::`), quote(`$`), quote(`@`)
+ )
+ caller <- rec(
+ caller_lng,
+ check_syntactic = FALSE,
+ force_lisp = !caller_calls_colon_ops
+ )
+ if ((is_op(caller) || is_cf(caller)) && force_lisp) {
+ return(deparse_lisp(
+ caller, call, rec, one_liner, indent, unicode_representation, escape,
+ protect = TRUE
+ ))
+ }
+ force_lisp <- FALSE
+
+ if (lisp_equal && caller == "=") {
+ return(deparse_lisp(
+ caller, call, rec, one_liner, indent, unicode_representation, escape,
+ protect = TRUE
+ ))
+ }
+
+ # function and control flow ---------------------------------------------------
+
+ if (caller == "function" && is_regular_function_definition(call))
+ return(deparse_function(call, rec))
+
+ if (caller == "if" && length(call) %in% 3:4)
+ return(deparse_if(call, rec))
+
+ if (caller == "while" && length(call) == 3)
+ return(deparse_while(call, rec))
+
+ if (caller == "for" && length(call) == 4)
+ return(deparse_for(call, rec))
+
+ if (caller == "repeat" && length(call) == 2)
+ return(deparse_repeat(call, rec))
+
+ # surrounding ops ------------------------------------------------------------
+
+ if (caller == "[" && is_regular_bracket_call(call)) {
+ return(deparse_subset(call, rec, one_liner, indent, unicode_representation, escape))
+ }
+
+ if (caller == "[[" && is_regular_bracket_call(call)) {
+ return(deparse_subset2(call, rec, one_liner, indent, unicode_representation, escape))
+ }
+
+ if (caller == "(" && length(call) == 2)
+ return(deparse_paren(call, rec))
+
+ if (caller == "{" && !any(vapply(call[-1], identical, logical(1), quote(expr = ))))
+ return(deparse_curly(call, rec, one_liner, indent))
+
+ # non standard use of infix ops ----------------------------------------------
+
+ if (is_op(caller) && !operands_have_higher_or_equal_precedence(caller, call)) {
+ args <- deparse_named_args_to_string(
+ call[-1],
+ one_liner = one_liner,
+ indent = indent,
+ unicode_representation,
+ escape
+ )
+ return(sprintf("%s(%s)", protect(caller), args))
+ }
+
+ # infix ops ------------------------------------------------------------------
+
+ if (is_unary(caller) && length(call) == 2)
+ return(deparse_unary(caller, call, rec))
+
+ if (is_infix_wide(caller) && length(call) == 3)
+ return(deparse_infix_wide(caller, call, rec, pipe))
+
+ if (
+ caller %in% c("::", ":::") &&
+ length(call) == 3 &&
+ (is.symbol(call[[2]]) || is.character(call[[2]])) &&
+ (is.symbol(call[[3]]) || is.character(call[[3]]))
+ ) {
+ return(deparse_double_triple_colon(caller, call, rec))
+ }
+
+ if (caller %in% c("@", "$") && length(call) == 3 &&
+ (is.symbol(call[[3]]) || is.character(call[[3]])))
+ return(deparse_accessor(caller, call, rec, unicode_representation, escape))
+
+ if (caller %in% c("^", ":") && length(call) == 3)
+ return(deparse_hat_colon(caller, call, rec))
+
+ # lisp calls ----------------------------------------------------------------
+
+ if (pipe && length(call) > 1 && rlang::names2(call)[[2]] == "") {
+ arg1 <- rec(call[[2]])
+ arg1_is_pipeable <-
+ !is.call(call[[2]]) ||
+ operands_have_higher_or_equal_precedence("|>", list(NULL, call[[2]], NULL))
+ if (arg1_is_pipeable) {
+ if (is.symbol(caller_lng)) {
+ caller <- protect(caller)
+ }
+ other_args <- vapply(call[-(1:2)], rec, character(1))
+ other_args <- paste(rlang::names2(other_args), "=", other_args)
+ other_args <- sub("^ = ", "", other_args)
+ return(sprintf(
+ "%s %s %s(%s)",
+ arg1,
+ get_pipe_symbol(NULL),
+ caller,
+ paste(other_args, collapse = ", ")
+ ))
+ }
+ }
+
+ deparse_lisp(
+ caller, call, rec, one_liner, indent, unicode_representation, escape,
+ protect = is.symbol(caller_lng)
+ )
+}
diff --git a/sub/constructive.core/R/deparse_helpers.R b/sub/constructive.core/R/deparse_helpers.R
new file mode 100644
index 00000000..17f6ae80
--- /dev/null
+++ b/sub/constructive.core/R/deparse_helpers.R
@@ -0,0 +1,366 @@
+is_syntactic <- function(x) {
+ x == make.names(x)
+}
+
+# exceptions -----------------------------------------------------------------
+
+deparse_symbol <- function(call, check_syntactic, unicode_representation) {
+ code <- construct_string(
+ as.character(call),
+ unicode_representation,
+ escape = TRUE,
+ mode = "symbol",
+ protect = check_syntactic
+ )
+ code
+}
+
+deparse_syntactic_literal <- function(call, unicode_representation, escape) {
+ .cstr_construct(
+ call, template = NULL, data = NULL,
+ unicode_representation = unicode_representation,
+ escape = escape,
+ unicode_representation.chr = unicode_representation,
+ escape.chr = escape
+ )
+}
+
+# function and control flow ---------------------------------------------------
+
+deparse_function <- function(call, rec) {
+ # no need to check more, already done by is_expression2
+ pair_list_args <- sapply(call[[2]], rec)
+ pair_list_code <- paste(protect(names(pair_list_args)), "=", pair_list_args)
+ pair_list_code <- sub(" = $", "", pair_list_code)
+ pair_list_code <- paste(pair_list_code, collapse = ", ")
+ body_code <- rec(call[[3]])
+ sprintf("function(%s) %s", pair_list_code, body_code)
+}
+
+deparse_if <- function(call, rec) {
+ cond <- rec(call[[2]])
+ yes <- rec(call[[3]])
+ if (length(call) == 3) {
+ return(sprintf("if (%s) %s", cond, yes))
+ }
+ no <- rec(call[[4]])
+ sprintf("if (%s) %s else %s", cond, yes, no)
+}
+
+deparse_while <- function(call, rec) {
+ cond <- rec(call[[2]])
+ expr <- rec(call[[3]])
+ sprintf("while (%s) %s", cond, expr)
+}
+
+deparse_for <- function(call, rec) {
+ i <- rec(call[[2]])
+ seq <- rec(call[[3]])
+ expr <- rec(call[[4]])
+ sprintf("for (%s in %s) %s", i, seq, expr)
+}
+
+deparse_repeat <- function(call, rec) {
+ expr <- rec(call[[2]])
+ sprintf("repeat %s", expr)
+}
+
+# surrounding ops ------------------------------------------------------------
+
+deparse_subset <- function(call, rec, one_liner, indent, unicode_representation, escape) {
+ arg1 <- rec(call[[2]])
+ other_args <- deparse_named_args_to_string(
+ call[-(1:2)],
+ one_liner = one_liner,
+ indent = indent,
+ unicode_representation,
+ escape
+ )
+ sprintf("%s[%s]", arg1, other_args)
+}
+
+deparse_subset2 <- function(call, rec, one_liner, indent, unicode_representation, escape) {
+ arg1 <- rec(call[[2]])
+ other_args <- deparse_named_args_to_string(
+ call[-(1:2)],
+ one_liner = one_liner,
+ indent = indent,
+ unicode_representation,
+ escape
+ )
+ sprintf("%s[[%s]]", arg1, other_args)
+}
+
+is_regular_bracket_call <- function(call) {
+ if (!identical(call[[1]], as.symbol("[")) && !identical(call[[1]], as.symbol("[["))) {
+ return(FALSE)
+ }
+ if (length(call) < 3) {
+ # even with empty bracket it is length 3 because x[] uses an empty arg
+ return(FALSE)
+ }
+
+ if (identical(call[[2]], quote(expr=))) return(FALSE)
+ if (!is.call(call[[2]])) return(TRUE)
+
+ lhs_is_call_with_a_symbol_caller <-
+ is.call(call[[2]]) &&
+ is.symbol(call[[2]][[1]])
+
+ if (!lhs_is_call_with_a_symbol_caller) return(TRUE)
+ lhs_caller_chr <- as.character((call[[2]][[1]]))
+ if (is_cf(lhs_caller_chr) || lhs_caller_chr == "function") return(FALSE)
+ precedence(lhs_caller_chr, length(call[[2]])) >= 16
+}
+
+deparse_paren <- function(call, rec) {
+ sprintf("(%s)", rec(call[[2]]))
+}
+
+deparse_curly <- function(call, rec, one_liner, indent) {
+ if (length(call) == 1) {
+ return("{ }")
+ }
+ # tunneling
+ if (rlang::is_call(call[[2]], "{") && is.symbol(call[[c(2, 2)]])) {
+ return(sprintf("{{ %s }}", as.character(call[[c(2, 2)]])))
+ }
+
+ if (one_liner) {
+ args <- paste(vapply(call[-1], rec, character(1)), collapse = "; ")
+ return(sprintf("{%s}", args))
+ }
+ args <- vapply(call[-1], rec, character(1), indent = indent + 1)
+ args <- paste(indent(args, depth = indent + 1), collapse = "\n")
+ sprintf("{\n%s\n%s}", args, indent("", depth = indent))
+}
+
+# infix ops ------------------------------------------------------------------
+
+is_unary <- function(x) {
+ x %in% c("-", "+", "!", "?", "^", "~", "?")
+}
+
+is_infix_wide <- function(x) {
+ x %in% c("+", "-", "*", "/", "<", ">", "<=", ">=", "==", "!=", "&", "&&", "|", "||", "~", "<-", "<<-", "=", "?", ":=") || grepl("^%.*%$", x)
+}
+
+is_infix_narrow <- function(x) {
+ x %in% c("::", ":::", "$", "@", "^", ":")
+}
+
+is_op <- function(x) {
+ is_unary(x) || is_infix_wide(x) || is_infix_narrow(x)
+}
+
+is_cf <- function(x) {
+ x %in% c("if", "while", "for", "repeat")
+}
+
+deparse_unary <- function(caller, call, rec) {
+ if (caller %in% c("+", "-")) {
+ # FIXME: pipe = FALSE is too restrictive
+ # should apply only to direct arg but not recursively
+ sprintf("%s%s", caller, rec(call[[2]], pipe = FALSE))
+ } else {
+ sprintf("%s%s", caller, rec(call[[2]]))
+ }
+
+}
+
+deparse_infix_wide <- function(caller, call, rec, pipe) {
+ # cancel the pipe where it doesn't belong
+ pipe <- pipe && caller %in% c("~", "<-", "<<-", "=", "?", ":=")
+ # FIXME: we probably want to get rid of this
+ use_right_assignment <-
+ caller == "<-" &&
+ is.call(call[[2]]) &&
+ list(call[[2]][[1]]) %in% alist(`<-`, `if`, `for`, `while`, `repeat`)
+
+ if (use_right_assignment) {
+ # because `<-` has differen precedence
+ if (identical(call[[2]][[1]], as.symbol("<-"))) {
+ code <- sprintf(
+ "%s -> %s <- %s",
+ rec(call[[2]][[3]]),
+ rec(call[[2]][[2]]),
+ rec(call[[3]])
+ )
+ return(code)
+ }
+
+ code <- sprintf(
+ "%s -> %s",
+ rec(call[[3]]),
+ rec(call[[2]])
+ )
+ return(code)
+ }
+
+ sprintf(
+ "%s %s %s",
+ rec(call[[2]]),
+ caller,
+ rec(call[[3]])
+ )
+}
+
+deparse_double_triple_colon <- function(caller, call, rec) {
+ sprintf("%s%s%s", rec(call[[2]]), caller, rec(call[[3]]))
+}
+
+deparse_accessor <- function(caller, call, rec, unicode_representation, escape) {
+ if (is.symbol(call[[3]])) {
+ nm <- as.character(call[[3]])
+ nm <- construct_string(nm, unicode_representation, escape, mode = "symbol")
+ return(sprintf("%s%s%s", rec(call[[2]]), caller, nm))
+ }
+ if (is.character(call[[3]])) {
+ nm <- construct_string(
+ call[[3]],
+ unicode_representation = unicode_representation,
+ escape = escape
+ )
+ return(sprintf('%s%s%s', rec(call[[2]]), caller, nm))
+ }
+}
+
+deparse_hat_colon <- function(caller, call, rec) {
+ # FIXME: pipe = FALSE is too restrictive
+ # should apply only to direct arg but not recursively
+ sprintf("%s%s%s", rec(call[[2]]), caller, rec(call[[3]], pipe = FALSE))
+}
+
+# lisp -------------------------------------------------------------------------
+
+deparse_pipe <- function(caller, call, rec, one_liner, indent, unicode_representation, escape, protect) {
+ if (protect) caller <- protect(caller)
+ args <- deparse_named_args_to_string(
+ call[-1],
+ one_liner = one_liner,
+ indent = indent,
+ unicode_representation,
+ escape
+ )
+ sprintf("%s(%s)", caller, args)
+}
+
+deparse_lisp <- function(caller, call, rec, one_liner, indent, unicode_representation, escape, protect) {
+ if (protect) caller <- protect(caller)
+ args <- deparse_named_args_to_string(
+ call[-1],
+ one_liner = one_liner,
+ indent = indent,
+ unicode_representation,
+ escape
+ )
+ sprintf("%s(%s)", caller, args)
+}
+
+# other helpers ----------------------------------------------------------------
+
+deparse_named_args_to_string <- function(args, one_liner, indent, unicode_representation, escape) {
+ if (length(args) == 0) {
+ return("")
+ }
+ args <- vapply(args, deparse_call_impl, character(1), one_liner = one_liner, indent = indent + 1, lisp_equal = TRUE)
+ nms0 <- rlang::names2(args)
+ nms <- construct_strings(nms0, unicode_representation, escape, mode = "name")
+ args <- ifelse(nms0 == "", args, paste(nms, "=", args))
+ # FIXME: the 80 is a bit arbitrary, since we don't account for indent and length of caller
+ if (one_liner || max(nchar(args)) < 80) return(paste(args, collapse = ", "))
+ args <- paste(indent(args, depth = indent + 1), collapse = ",\n")
+ paste0("\n", args, "\n", indent("", depth = indent))
+}
+
+precedence <- function(x, call_length = 2) {
+ # length(x) > 1 means x was produced from a call, like `pkg::foo`, so it
+ # has the highest precedence
+ if (length(x) > 1) return(Inf)
+ if (!call_length %in% c(2, 3)) return(Inf)
+ if (call_length == 2) {
+ precedences <- c(
+ "-" = 14,
+ "+" = 14,
+ "!" = 8,
+ "~" = 5,
+ "?" = 1
+ )
+ } else {
+ if (grepl("^%.*%$", x)) return(12)
+ precedences <- c(
+ "::" = 18,
+ ":::" = 18,
+ "$" = 17,
+ "@" = 17,
+ "[" = 16,
+ "[[" = 16,
+ "^" = 15,
+ # "-" = 14,
+ # "+" = 14,
+ ":" = 13,
+ #"%any%", # 12
+ "|>" = 12,
+ "*" = 11,
+ "/" = 11,
+ "+" = 10,
+ "-" = 10,
+ "<" = 9,
+ ">" = 9,
+ "<=" = 9,
+ ">=" = 9,
+ "==" = 9,
+ "!=" = 9,
+ #"!" = 8,
+ "&" = 7,
+ "&&" = 7,
+ "|" = 6,
+ "||" = 6,
+ "~" = 5,
+ "->" = 4,
+ "->>" = 4,
+ "<-" = 3,
+ "<<-" = 3,
+ "=" = 2,
+ "?" = 1
+ )
+ }
+ # if the caller is not found above, it is a regular function call foo(x)
+ # so it has the highest precedence
+ if (!x %in% names(precedences)) return(Inf)
+ precedences[[x]]
+}
+
+# checks if the operator has a higher precedence than both the lhs and rhs
+# of the call
+operands_have_higher_or_equal_precedence <- function(operator, call) {
+ if (any(sapply(call[-1], identical, quote(expr=)))) return(FALSE)
+ if (!length(call) %in% c(2, 3)) return(TRUE)
+
+ # we need to special case ops with righ to left precedence
+ lhs <- call[[2]] # actually rhs when call is length 2
+ op_prec <- precedence(operator, length(call))
+ if (is.call(lhs)) {
+ lhs_caller_chr <- as.character(lhs[[1]])
+ if (length(lhs_caller_chr) == 1 && lhs_caller_chr %in% c("[", "[[")) {
+ lhs_prec <- Inf
+ } else if (length(call) == 3 && length(lhs_caller_chr) == 1 && is_cf(lhs_caller_chr)) {
+ lhs_prec <- 1.5 # just above `?`
+ } else {
+ lhs_prec <- precedence(lhs_caller_chr, length(lhs))
+ }
+ } else {
+ lhs_prec <- Inf
+ }
+ if (length(call) == 3 && is.call(rhs <- call[[3]])) {
+ rhs_prec <- precedence(as.character(rhs[[1]]), length(rhs))
+ } else {
+ rhs_prec <- Inf
+ }
+
+ # `=`, `<-`, and `^` have right to left precedence
+ if (op_prec %in% c(2, 3, 15)) {
+ return(lhs_prec > op_prec && rhs_prec >= op_prec)
+ }
+ lhs_prec >= op_prec && rhs_prec > op_prec
+}
diff --git a/sub/constructive.core/R/document-other-opts.R b/sub/constructive.core/R/document-other-opts.R
new file mode 100644
index 00000000..bc58fdd0
--- /dev/null
+++ b/sub/constructive.core/R/document-other-opts.R
@@ -0,0 +1,11 @@
+#' Other Opts Functions
+#'
+#' These `opts_*()` functions are not extensively documented yet. Hopefully
+#' the signature is self explanatory, if not please
+#' \href{https://github.com/cynkra/constructive/issues}{raise an issue}
+#'
+#' @param constructor String. Method used to construct the object, often the name
+#' of a function.
+#' @inheritParams opts_atomic
+#' @name other-opts
+NULL
diff --git a/sub/constructive.core/R/environment_utils.R b/sub/constructive.core/R/environment_utils.R
new file mode 100644
index 00000000..a486d82b
--- /dev/null
+++ b/sub/constructive.core/R/environment_utils.R
@@ -0,0 +1,228 @@
+
+construct_special_env <- function(x) {
+ if (identical(x, baseenv())) return("baseenv()")
+ if (identical(x, emptyenv())) return("emptyenv()")
+ if (identical(x, .GlobalEnv)) return(".GlobalEnv")
+ if (identical(x, .BaseNamespaceEnv)) return(".BaseNamespaceEnv")
+ # testing on name is not enough but we use it to identify candidated
+ name <- environmentName(x)
+ # handle {testthat} corner case
+ if (identical(Sys.getenv("TESTTHAT"), "true") && name == "constructive") return('asNamespace("constructive")')
+ if (name != "" && rlang::is_installed(name) && identical(x, asNamespace(name))) return(sprintf('asNamespace("%s")', name))
+ if (name %in% search() && identical(x, as.environment(name))) return(sprintf('as.environment("%s")', name))
+ if (startsWith(name, "imports:")) {
+ pkg <- sub("^imports:(.*)$", "\\1", name)
+ env_is_imports <-
+ pkg != "" &&
+ rlang::is_installed(pkg) &&
+ identical(x, parent.env(asNamespace(pkg)))
+ if (env_is_imports)
+ return(sprintf('parent.env(asNamespace("%s"))', pkg))
+ }
+ if (startsWith(name, "lazydata:")) {
+ pkg <- sub("^lazydata:(.*)$", "\\1", name)
+ env_is_lazydata <-
+ pkg != "" &&
+ rlang::is_installed(pkg) &&
+ identical(x, getNamespaceInfo(pkg, "lazydata"))
+ if (env_is_lazydata)
+ return(sprintf('getNamespaceInfo("%s", "lazydata")', pkg))
+ }
+}
+
+construct_top_env <- function(x) {
+ repeat {
+ code <- construct_special_env(x)
+ if (!is.null(code)) break
+ x <- parent.env(x)
+ }
+ code
+}
+
+env_memory_address <- function(x, by_name = FALSE) {
+ if (identical(Sys.getenv("TESTTHAT"), "true")) return("0x123456789")
+ if (by_name) rlang::env_label(x) else rlang::obj_address(x)
+}
+
+# adapted from rlang::env_name
+env_name <- function (env) {
+ if (identical(env, global_env())) {
+ return("global")
+ }
+ if (identical(env, base_env())) {
+ return("package:base")
+ }
+ if (identical(env, empty_env())) {
+ return("empty")
+ }
+ nm <- environmentName(env)
+ if (isNamespace(env)) {
+ return(paste0("namespace:", nm))
+ }
+ nm
+}
+
+fetch_parent_names <- function(x) {
+ parents <- character()
+ repeat {
+ x <- parent.env(x)
+ # An environment should always have a parent but for some reason some have
+ # a NULL parent, though the error of `new.env(parent = NULL)` says the feature
+ # is defunct
+ if (is.null(x)) return(parents)
+ nm <- env_name(x)
+ if (nm != "") {
+ return(c(parents, nm))
+ }
+ nm <- env_memory_address(x, by_name = TRUE)
+ parents <- c(parents, nm)
+ }
+}
+
+#' Fetch environment from memory address
+#'
+#' This is designed to be used in constructed output. The `parents` and `...` arguments
+#' are not processed and only used to display additional information. If used on
+#' an improper memory address it will either fail (most likely) or the output
+#' will be erratic.
+#'
+#' @param address Memory address of the environment
+#' @param parents,... ignored
+#' @return The environment that the memory address points to.
+#' @export
+.env <- function(address, parents = NULL, ...) {
+ force(parents) # to avoid notes
+ env <- env_impl(address)
+ if (is.null(env)) {
+ msg <- sprintf("No environment was found at the memory address '%s'", address)
+ info1 <- "It's likely that {constructive} was called in a different session to generate this code."
+ info2 <- "The environment might also have been garbage collected."
+ info3 <- "See `?opts_environment` for various alternatives to construct environment with persistent definitions."
+ abort(c(msg, i = info1, i = info2, i = info3))
+ }
+ env
+}
+
+update_predefinition <- function(envir, ...) {
+ # construct parent before constructing env
+ parent_code <- .cstr_construct(parent.env(envir), ...)
+ # if envir was already constructed (recorded in globals$env), just return its name
+ hash <- format(envir)
+ if (hash %in% globals$envs$hash) {
+ return(globals$envs$name[hash == globals$envs$hash][[1]])
+ }
+ # create a new name, incrementing count
+ env_name <- sprintf("..env.%s..", nrow(globals$envs) + 1)
+ # update globals$envs with new row (hash + variable name)
+ globals$envs <- rbind(globals$envs, data.frame(hash = hash, name = env_name))
+ # initialize with new.env(), repairing attributes
+ code <- sprintf("new.env(parent = %s)", parent_code)
+ code <- repair_attributes_environment(envir, code, ...)
+ code[[1]] <- sprintf("%s <- %s", env_name, code[[1]])
+ # update predefinitions with envir definition
+ globals$predefinition <- c(
+ globals$predefinition,
+ code
+ )
+ # build non environment objects of envir above
+ for (nm in names(envir)) {
+ obj <- envir[[nm]]
+ if (missing(obj)) {
+ obj_code <- sprintf("%s$%s <- quote(expr = )", env_name, nm)
+ globals$predefinition <- c(
+ globals$predefinition,
+ obj_code
+ )
+ } else if (!is.environment(obj)) {
+ nm <- protect(nm)
+ # this defines the objects as a side effect
+ obj_code <- .cstr_construct(obj, ...)
+ obj_code[[1]] <- sprintf("%s$%s <- %s", env_name, nm, obj_code[[1]])
+ globals$predefinition <- c(
+ globals$predefinition,
+ obj_code
+ )
+ }
+ }
+
+ # build environment objects of envir above
+ for (nm in names(envir)) {
+ obj <- envir[[nm]]
+ if (missing(obj)) {
+ obj_code <- sprintf("%s$%s <- quote(expr = )", env_name, nm)
+ globals$predefinition <- c(
+ globals$predefinition,
+ obj_code
+ )
+ } else if (is.environment(obj)) {
+ nm <- protect(nm)
+ obj_code <- .cstr_construct(obj, ...) # this will also print code
+ obj_code[[1]] <- sprintf("%s$%s <- %s", env_name, nm, obj_code[[1]])
+ globals$predefinition <- c(
+ globals$predefinition,
+ obj_code
+ )
+ }
+ }
+ env_name
+}
+
+apply_env_locks <- function(x, code, ...) {
+ # since we override S3 dispatch here we can circumvent rlang bug
+ # https://github.com/r-lib/rlang/issues/1783
+ bindings <- names(x)
+ locked_bindings <- rlang::env_binding_are_locked(x, bindings)
+ if (environmentIsLocked(x)) {
+ if (length(locked_bindings) && all(locked_bindings)) {
+ rhs <- c(
+ "(\\(e) {",
+ " lockEnvironment(e, bindings = TRUE)",
+ " e",
+ "})()"
+ )
+ code <- .cstr_pipe(code, rhs)
+ return(code)
+ }
+ if (!any(locked_bindings)) {
+ rhs <- c(
+ "(\\(e) {",
+ " lockEnvironment(e)",
+ " e",
+ "})()"
+ )
+ code <- .cstr_pipe(code, rhs)
+ return(code)
+ }
+ rhs <- c(
+ '(\\(e) {',
+ " lockEnvironment(e)",
+ locked_code(locked_bindings, ...),
+ ' e',
+ '})()'
+ )
+ code <- .cstr_pipe(code, rhs)
+ return(code)
+ }
+ if (any(locked_bindings)) {
+ rhs <- c(
+ '(\\(e) {',
+ locked_code(locked_bindings, ...),
+ ' e',
+ '})()'
+ )
+ code <- .cstr_pipe(code, rhs)
+ }
+ code
+}
+
+locked_code <- function(locked_bindings, ...) {
+ locked <- names(locked_bindings)[locked_bindings]
+ if (length(locked) > 2) {
+ locked_code <- .cstr_construct(locked, ...)
+ locked_code[[1]] <- paste("locked <- ", locked_code[[1]])
+ locked_code <- c(locked_code, 'for (sym in locked) lockBinding(sym, e)')
+ locked_code <- paste0(" ", locked_code)
+ return(locked_code)
+ }
+ sprintf(" lockBinding(%s, e)", sapply(locked, .cstr_construct, ...))
+}
diff --git a/sub/constructive.core/R/expect_construct.R b/sub/constructive.core/R/expect_construct.R
new file mode 100644
index 00000000..5ce9535e
--- /dev/null
+++ b/sub/constructive.core/R/expect_construct.R
@@ -0,0 +1,13 @@
+expect_construct <- function(x, expected, ...) {
+ withr::local_envvar(c(TESTTHAT = "true"))
+ if (!missing(expected) && rlang::is_na(substitute(expected))) {
+ out <- construct(x, check = FALSE, ...)$code
+ getFromNamespace("write_clip", "clipr")(out)
+ return(out)
+ }
+
+ expected <- if (missing(expected)) substitute(x) else substitute(expected)
+ new_code <- eval(substitute(construct(x, check = FALSE, ...)$code), parent.frame())
+ recreated <- parse(text=new_code)[[1]]
+ expect_equal(recreated, expected)
+}
diff --git a/sub/constructive.core/R/format_atomic.R b/sub/constructive.core/R/format_atomic.R
new file mode 100644
index 00000000..a82fc236
--- /dev/null
+++ b/sub/constructive.core/R/format_atomic.R
@@ -0,0 +1,96 @@
+
+format_rep <- function(x, ..., double = FALSE) {
+ attributes(x) <- NULL
+ rle_x <- rle2(x, double = double)
+ values <- rle_x[[1]]
+ lengths <- rle_x[[2]]
+ l <- length(x)
+
+ # use rep(x, each=)
+ rep_each_is_applicable <-
+ # value is not unique
+ length(lengths) != 1 &&
+ # values are repeated the same amount
+ length(unique(lengths)) == 1 &&
+ # length is at least 2 more than unique values
+ # FIXME: not clear if this is necessary
+ length(values) + 1 < length(x)
+ if (rep_each_is_applicable) {
+ code <- .cstr_apply(list(values, each = lengths[[1]]), "rep", ...)
+ return(code)
+ }
+
+ # use rep(x, times=) with `times` and `x` of same length
+ rep_times_reduces_verbosity <- length(values) * 2 < l
+ if (rep_times_reduces_verbosity) {
+ code <- .cstr_apply(list(values, lengths), "rep", ...)
+ return(code)
+ }
+
+ # use rep(x, times =) with scalar `times`
+ # we test all subdivisions
+ for (d in divisors(l)) {
+ sequence <- x[1:d]
+ times <- l / d
+ the_repeated_sequence_matches <- identical(x, rep(sequence, times))
+ if (the_repeated_sequence_matches) {
+ code <- .cstr_apply(list(sequence, times), "rep", ...)
+ return(code)
+ }
+ }
+
+}
+
+format_seq <- function(x, ...) {
+ # for diff()
+ attributes(x) <- NULL
+ l <- length(x)
+ # seq ----------------------------------------------------------------------
+ if (is.integer(x) && l >= 2 && !anyNA(x)) {
+ # diff returns NA when span of difference exceeds .Machine$integer.max
+ d <- suppressWarnings(diff(x))
+ if (!anyNA(d) && length(unique(d)) == 1) {
+ if (abs(d[[1]]) == 1) return(sprintf("%s:%s", x[[1]], x[[l]]))
+ if (l > 3) return(.cstr_apply(list(x[[1]], x[[l]], by = d[[1]]), "seq", ...))
+ return(NULL)
+ }
+ }
+
+ if (is.numeric(x) && l > 3 && !anyNA(x)) {
+ # diff returns NA when span of difference exceeds .Machine$integer.max
+ d <- suppressWarnings(diff(x))
+ if (!anyNA(d) && length(unique(d)) == 1) {
+ return(.cstr_apply(list(x[[1]], x[[l]], by = d[[1]]), "seq", ...))
+ }
+ }
+}
+
+trim_atomic <- function(x, trim, fill, ...) {
+ l <- length(x)
+ if (trim >= l) return(NULL)
+ if (trim == 0) return(.cstr_construct(x[0], ...))
+ x_short <- x[seq_len(trim)]
+ strings <- vapply(
+ x_short,
+ function(x, ...) .cstr_construct(x, ...),
+ character(1),
+ ...
+ )
+ nms <- names(x_short)
+ if (fill == "none" && trim == 1 && is.null(nms)) return(strings)
+ names(strings) <- names(x_short)
+ replacement <- switch(
+ fill,
+ none = NULL,
+ default = sprintf(
+ "%s(%s)",
+ if (is.double(x)) "numeric" else typeof(x),
+ l - trim
+ ),
+ rlang = sprintf("rlang::new_%s(%s)", typeof(x), l - trim),
+ "+" = paste0("+", l - trim),
+ "..." = "..."
+ )
+ code <- .cstr_apply(c(strings, replacement), "c", ..., recurse = FALSE)
+ return(code)
+}
diff --git a/sub/constructive.core/R/global-options.R b/sub/constructive.core/R/global-options.R
new file mode 100644
index 00000000..80f9533f
--- /dev/null
+++ b/sub/constructive.core/R/global-options.R
@@ -0,0 +1,27 @@
+#' Global Options
+#'
+#' Set these options to tweak \{constructive\}'s global behavior, to set them
+#' permanently you can edit your `.RProfile1`, e.g. using `usethis::edit_r_profile()`.
+#'
+#' * Set `options(constructive_print_mode = )` to change the default
+#' value of the `print_mode` argument, of `print.constructive`, where `` is a vector
+#' of strings among the following :
+#' * `"console"` : The default behavior, the code is printed in the console
+#' * `"script"` : The code is copied to a new R script
+#' * `"reprex"` : The code is shown in the viewer as a reprex,
+#' the reprex (not only the code!) is also copied to the clipboard.
+#' * `"clipboard"` : The constructed code is copied to the clipboard, if combined
+#' with `"reprex"` this takes precedence (the reprex is showed in the viewer,
+#' the code without output is copied to the clipboard)
+#' * Set `options(constructive_opts_template = )` to set default constructive options,
+#' see documentation of the `template` arg in `?construct`
+#' * Set `options(constructive_pretty = FALSE)` to disable syntax highlighting.
+#'
+#' ## Relevant options from other packages:
+#'
+#' * `cli.code_theme` can be used to configure the syntax highlighting theme
+#' used by \{constructive\}; see [cli::code_theme_list()] for more information.
+#'
+#' @name constructive-global_options
+#' @aliases constructive_opts_template constructive_pretty constructive_print_mode
+NULL
diff --git a/sub/constructive.core/R/import-standalone-lifecycle.R b/sub/constructive.core/R/import-standalone-lifecycle.R
new file mode 100644
index 00000000..a3bcb068
--- /dev/null
+++ b/sub/constructive.core/R/import-standalone-lifecycle.R
@@ -0,0 +1,252 @@
+# Standalone file: do not edit by hand
+# Source:
+# ----------------------------------------------------------------------
+#
+# ---
+# repo: r-lib/rlang
+# file: standalone-lifecycle.R
+# last-updated: 2023-02-23
+# license: https://unlicense.org
+# imports: rlang (>= 1.0.0)
+# ---
+#
+# This file serves as a reference for currently unexported rlang
+# lifecycle functions. These functions require rlang in your `Imports`
+# DESCRIPTION field but you don't need to import rlang in your
+# namespace.
+#
+# ## Changelog
+#
+# 2023-02-23
+#
+# - Updated the API and internals to match modern lifecycle tools.
+#
+#
+# 2021-04-19
+#
+# - Removed `lifecycle()` function. You can now use the following in
+# your roxygen documentation to inline a badge:
+#
+# ```
+# `r lifecycle::badge()`
+# ```
+#
+# This is a build-time dependency on lifecycle so there is no need
+# to add lifecycle to Imports just to use badges. See also
+# `?usethis::use_lifecycle()` for importing or updating the badge
+# images in your package.
+#
+# - Soft-namespaced private objects.
+#
+# nocov start
+
+
+#' Signal deprecation
+#'
+#' @description
+#' These functions provide two levels of verbosity for deprecation
+#' warnings.
+#'
+#' * `deprecate_soft()` warns only if called directly: from the global
+#' environment (so the user can change their script) or from the
+#' package currently being tested (so the package developer can fix
+#' the package).
+#'
+#' * `deprecate_warn()` warns unconditionally.
+#'
+#' * `deprecate_stop()` fails unconditionally.
+#'
+#' Both functions warn only once per session by default to avoid
+#' overwhelming the user with repeated warnings.
+#'
+#' @param msg The deprecation message.
+#' @param id The id of the deprecation. A warning is issued only once
+#' for each `id`. Defaults to `msg`, but you should give a unique ID
+#' when the message is built programmatically and depends on inputs.
+#' @param user_env The environment in which the deprecated function
+#' was called. The verbosity depends on whether the deprecated
+#' feature was called directly, see [rlang::env_is_user_facing()] and the
+#' documentation in the lifecycle package.
+#'
+#' @section Controlling verbosity:
+#'
+#' The verbosity of retirement warnings can be controlled with global
+#' options. You'll generally want to set these options locally with
+#' one of these helpers:
+#'
+#' * `with_lifecycle_silence()` disables all soft-deprecation and
+#' deprecation warnings.
+#'
+#' * `with_lifecycle_warnings()` enforces warnings for both
+#' soft-deprecated and deprecated functions. The warnings are
+#' repeated rather than signalled once per session.
+#'
+#' * `with_lifecycle_errors()` enforces errors for both
+#' soft-deprecated and deprecated functions.
+#'
+#' All the `with_` helpers have `scoped_` variants that are
+#' particularly useful in testthat blocks.
+#'
+#' @noRd
+NULL
+
+deprecate_soft <- function(msg,
+ id = msg,
+ user_env = rlang::caller_env(2)) {
+ .rlang_lifecycle_signal_stage(msg, "deprecated")
+
+ id <- paste(id, collapse = "\n")
+ verbosity <- .rlang_lifecycle_verbosity()
+
+ invisible(switch(
+ verbosity,
+ quiet = NULL,
+ warning = ,
+ default =
+ if (rlang::env_is_user_facing(user_env)) {
+ always <- verbosity == "warning"
+ trace <- rlang::trace_back(bottom = caller_env())
+ .rlang_lifecycle_deprecate_warn0(
+ msg,
+ id = id,
+ trace = trace,
+ always = always
+ )
+ },
+ error = deprecate_stop(msg)
+ ))
+}
+
+deprecate_warn <- function(msg,
+ id = msg,
+ always = FALSE,
+ user_env = rlang::caller_env(2)) {
+ .rlang_lifecycle_signal_stage(msg, "deprecated")
+
+ id <- paste(id, collapse = "\n")
+ verbosity <- .rlang_lifecycle_verbosity()
+
+ invisible(switch(
+ verbosity,
+ quiet = NULL,
+ warning = ,
+ default = {
+ direct <- rlang::env_is_user_facing(user_env)
+ always <- direct && (always || verbosity == "warning")
+
+ trace <- tryCatch(
+ rlang::trace_back(bottom = rlang::caller_env()),
+ error = function(...) NULL
+ )
+
+ .rlang_lifecycle_deprecate_warn0(
+ msg,
+ id = id,
+ trace = trace,
+ always = always
+ )
+ },
+ error = deprecate_stop(msg),
+ ))
+}
+
+.rlang_lifecycle_deprecate_warn0 <- function(msg,
+ id = msg,
+ trace = NULL,
+ always = FALSE,
+ call = rlang::caller_env()) {
+ if (always) {
+ freq <- "always"
+ } else {
+ freq <- "regularly"
+ }
+
+ rlang::warn(
+ msg,
+ class = "lifecycle_warning_deprecated",
+ .frequency = freq,
+ .frequency_id = id
+ )
+}
+
+deprecate_stop <- function(msg) {
+ msg <- cli::format_error(msg)
+ .rlang_lifecycle_signal_stage(msg, "deprecated")
+
+ stop(rlang::cnd(
+ c("defunctError", "error", "condition"),
+ old = NULL,
+ new = NULL,
+ package = NULL,
+ message = msg
+ ))
+}
+
+.rlang_lifecycle_signal_stage <- function(msg, stage) {
+ rlang::signal(msg, "lifecycle_stage", stage = stage)
+}
+
+expect_deprecated <- function(expr, regexp = NULL, ...) {
+ rlang::local_options(lifecycle_verbosity = "warning")
+
+ if (!is.null(regexp) && rlang::is_na(regexp)) {
+ rlang::abort("`regexp` can't be `NA`.")
+ }
+
+ testthat::expect_warning(
+ {{ expr }},
+ regexp = regexp,
+ class = "lifecycle_warning_deprecated",
+ ...
+ )
+}
+
+local_lifecycle_silence <- function(frame = rlang::caller_env()) {
+ rlang::local_options(
+ .frame = frame,
+ lifecycle_verbosity = "quiet"
+ )
+}
+with_lifecycle_silence <- function(expr) {
+ local_lifecycle_silence()
+ expr
+}
+
+local_lifecycle_warnings <- function(frame = rlang::caller_env()) {
+ rlang::local_options(
+ .frame = frame,
+ lifecycle_verbosity = "warning"
+ )
+}
+with_lifecycle_warnings <- function(expr) {
+ local_lifecycle_warnings()
+ expr
+}
+
+local_lifecycle_errors <- function(frame = rlang::caller_env()) {
+ rlang::local_options(
+ .frame = frame,
+ lifecycle_verbosity = "error"
+ )
+}
+with_lifecycle_errors <- function(expr) {
+ local_lifecycle_errors()
+ expr
+}
+
+.rlang_lifecycle_verbosity <- function() {
+ opt <- getOption("lifecycle_verbosity", "default")
+
+ if (!rlang::is_string(opt, c("quiet", "default", "warning", "error"))) {
+ options(lifecycle_verbosity = "default")
+ rlang::warn(paste(
+ "The `lifecycle_verbosity` option must be set to one of:",
+ "\"quiet\", \"default\", \"warning\", or \"error\".",
+ "Resetting to \"default\"."
+ ))
+ }
+
+ opt
+}
+
+# nocov end
diff --git a/sub/constructive.core/R/opts.R b/sub/constructive.core/R/opts.R
new file mode 100644
index 00000000..4dff2085
--- /dev/null
+++ b/sub/constructive.core/R/opts.R
@@ -0,0 +1,140 @@
+collect_opts <- function(..., template) {
+ opts_from_dots <- rlang::with_bindings(list(...), !!!all_opts_funs, .env = .GlobalEnv)
+ opts <- c(opts_from_dots, template)
+ names(opts) <- sapply(opts, function(x) sub("^constructive_options_(.*)$", "\\1", class(x)[[1]]))
+ opts <- opts[unique(names(opts))]
+ # inherit from atomic
+ # logical
+ opts$logical$constructor <-
+ opts$logical$constructor %||%
+ opts$atomic$constructor %||%
+ "default"
+ opts$logical$trim <-
+ opts$logical$trim %||%
+ opts$atomic$trim
+ opts$logical$fill <-
+ opts$logical$fill %||%
+ opts$atomic$fill %||%
+ "default"
+ opts$logical$compress <-
+ opts$logical$compress %||%
+ opts$atomic$compress %||%
+ TRUE
+ # integer
+ opts$integer$constructor <-
+ opts$integer$constructor %||%
+ opts$atomic$constructor %||%
+ "default"
+ opts$integer$trim <-
+ opts$integer$trim %||%
+ opts$atomic$trim
+ opts$integer$fill <-
+ opts$integer$fill %||%
+ opts$atomic$fill %||%
+ "default"
+ opts$integer$compress <-
+ opts$integer$compress %||%
+ opts$atomic$compress %||%
+ TRUE
+ # double
+ opts$double$constructor <-
+ opts$double$constructor %||%
+ opts$atomic$constructor %||%
+ "default"
+ opts$double$trim <-
+ opts$double$trim %||%
+ opts$atomic$trim
+ opts$double$fill <-
+ opts$double$fill %||%
+ opts$atomic$fill %||%
+ "default"
+ opts$double$compress <-
+ opts$double$compress %||%
+ opts$atomic$compress %||%
+ TRUE
+ # complex
+ opts$complex$constructor <-
+ opts$complex$constructor %||%
+ opts$atomic$constructor %||%
+ "default"
+ opts$complex$trim <-
+ opts$complex$trim %||%
+ opts$atomic$trim
+ opts$complex$fill <-
+ opts$complex$fill %||%
+ opts$atomic$fill %||%
+ "default"
+ opts$complex$compress <-
+ opts$complex$compress %||%
+ opts$atomic$compress %||%
+ TRUE
+ # raw
+ opts$raw$constructor <-
+ opts$raw$constructor %||%
+ opts$atomic$constructor %||%
+ "as.raw"
+ opts$raw$trim <-
+ opts$raw$trim %||%
+ opts$atomic$trim
+ opts$raw$fill <-
+ opts$raw$fill %||%
+ opts$atomic$fill %||%
+ "default"
+ opts$raw$compress <-
+ opts$raw$compress %||%
+ opts$atomic$compress %||%
+ TRUE
+ opts$raw$representation <-
+ opts$raw$representation %||%
+ "hexadecimal"
+ # character
+ opts$character$constructor <-
+ opts$character$constructor %||%
+ opts$atomic$constructor %||%
+ "default"
+ opts$character$trim <-
+ opts$character$trim %||%
+ opts$atomic$trim
+ opts$character$fill <-
+ opts$character$fill %||%
+ opts$atomic$fill %||%
+ "default"
+ opts$character$compress <-
+ opts$character$compress %||%
+ opts$atomic$compress %||%
+ TRUE
+ opts$character$unicode_representation <-
+ opts$character$unicode_representation %||%
+ opts$atomic$unicode_representation
+ opts$character$escape <-
+ opts$character$escape %||%
+ opts$atomic$escape
+
+ opts
+}
+
+#' Create constructive options
+#'
+#' Exported for custom constructor design.
+#'
+#' @param class A string. An S3 class.
+#' @param ... Options to set
+#'
+#' @return An object of class `c(paste0("constructive_options_", class), "constructive_options")`
+#' @export
+.cstr_options <- function(class, ...) {
+ structure(
+ class = c(paste0("constructive_options_", class), "constructive_options"),
+ list(...)
+ )
+}
+
+#' @export
+print.constructive_options <- function(x, ...) {
+ cl <- cli::col_blue(sprintf("<%s>", paste(class(x), collapse = "/")))
+ opts <- vapply(x, function(x, ...) .cstr_construct(x, ...), character(1), one_liner = TRUE, template = NULL, data = NULL, opts = NULL)
+ # This assumes options are all scalar or NULL
+ nms <- format(paste0(cli::col_blue(names(x)), ":"))
+ writeLines(c(cl, paste(nms, opts)))
+ invisible(x)
+}
diff --git a/sub/constructive.core/R/repair_attributes.R b/sub/constructive.core/R/repair_attributes.R
new file mode 100644
index 00000000..74eff218
--- /dev/null
+++ b/sub/constructive.core/R/repair_attributes.R
@@ -0,0 +1,87 @@
+repair_attributes <- function(x, code, ..., pipe = NULL) {
+ UseMethod("repair_attributes")
+}
+
+#' Repair attributes after idiomatic construction
+#'
+#' Exported for custom constructor design. In the general case an object might have more attributes than given by the idiomatic
+#' construction. `.cstr_repair_attributes()` sets some of those attributes and ignores
+#' others.
+#'
+#' @param x The object to construct
+#' @param code The code constructing the object before attribute repair
+#' @param ... Forwarded to `.construct_apply()` when relevant
+#' @param ignore The attributes that shouldn't be repaired, i.e. we expect them
+#' to be set by the constructor already in `code`
+#' @param idiomatic_class The class of the objects that the constructor produces,
+#' if `x` is of class `idiomatic_class` there is no need to repair the class.
+#' @param remove Attributes that should be removed, should rarely be useful.
+#' @param flag_s4 Boolean. Whether to use `asS4()` on the code of S4 objects,
+#' set to `FALSE` when a constructor that produces S4 objects was used.
+#' @param repair_names Boolean. Whether to repair the `names` attribute. Generally it is
+#' generated by the constructor but it is needed for some corner cases
+#'
+#' @return A character vector
+#' @export
+.cstr_repair_attributes <- function(
+ x, code, ...,
+ ignore = NULL,
+ idiomatic_class = NULL,
+ remove = NULL,
+ flag_s4 = TRUE,
+ repair_names = FALSE) {
+ # fetch non idiomatic args and class
+ attrs <- attributes(x)
+ attrs[ignore] <- NULL
+ # names are normally already provided through constructors, but need to be
+ # repaired for some corner cases
+ if (!repair_names) attrs$names <- NULL
+ # The `noquote` class is added at the end of the class vector so method `.noquote`
+ # wouldn't be triggered
+ if (
+ !identical(attrs$class, idiomatic_class) &&
+ tail(class(x), 1) == "noquote" &&
+ list(...)$opts$no_quote$constructor %||% "no_quote" == "noquote"
+ ) {
+ right <- identical(tail(names(class(x)), 1), "right")
+ args <- list(code)
+ args$right <- if (right) "TRUE"
+ code <- .cstr_apply(args, "noquote", recurse = FALSE)
+ attrs$class <- setdiff(attrs$class, "noquote")
+ if (!length(attrs$class)) attrs$class <- NULL
+ }
+ if (identical(attrs$class, idiomatic_class)) {
+ attrs$class <- NULL
+ } else if (is.null(attrs$class)) {
+ # to be able to remove the idiomatic class explicitly, mainly (only ?) useful for classless formulas
+ attrs["class"] <- list(NULL)
+ }
+ if (length(remove)) attrs <- c(attrs, setNames(replicate(length(remove), NULL), remove))
+ if (length(attrs)) {
+ # See ?structure, when those arguments are provided to structure() differently named attributes are created
+ special_structure_args <- c(".Data", ".Dim", ".Dimnames", ".Names", ".Tsp", ".Label")
+ special_attr_nms <- intersect(names(attrs), special_structure_args)
+ special_attrs <- attrs[special_attr_nms]
+ attrs[special_attr_nms] <- NULL
+ # append structure() code to repair object
+ if (length(attrs)) {
+ if ("row.names" %in% names(attrs) && identical(attrs$row.names, seq_along(attrs$row.names))) {
+ attrs$row.names <- c(NA, -length(attrs$row.names))
+ }
+ attrs_code <- .cstr_apply(attrs, fun = "structure", ...)
+ code <- .cstr_pipe(code, attrs_code, ...)
+ }
+ for (attr_nm in special_attr_nms) {
+ attr_code <- .cstr_apply(
+ list(attr_nm, special_attrs[[attr_nm]]),
+ "(`attr<-`)",
+ ...
+ )
+ code <- .cstr_pipe(code, attr_code, ...)
+ }
+ }
+ if (isS4(x) && flag_s4) {
+ code <- .cstr_pipe(code, "asS4()", pipe, ...)
+ }
+ code
+}
diff --git a/sub/constructive.core/R/roxygen2-tags.R b/sub/constructive.core/R/roxygen2-tags.R
new file mode 100644
index 00000000..f28c28c3
--- /dev/null
+++ b/sub/constructive.core/R/roxygen2-tags.R
@@ -0,0 +1,38 @@
+# nocov start
+
+roxy_tag_parse.roxy_tag_enumerateOptFunctions <- function(x) {
+ x$raw <- "."
+ roxygen2::tag_markdown(x)
+}
+
+roxy_tag_rd.roxy_tag_enumerateOptFunctions <- function(x, base_path, env) {
+ roxygen2::rd_section("enumerateOptFunctions", x$val)
+}
+
+#' @export
+format.rd_section_enumerateOptFunctions <- function(...) {
+ fun_nms <- ls(asNamespace("constructive"), pattern = "^opts_")
+ fun_nms <- fun_nms[order(tolower(fun_nms))]
+ funs <- mget(fun_nms, asNamespace("constructive"))
+ signatures <- mapply(construct_signature, funs, fun_nms, USE.NAMES = FALSE, MoreArgs = list(one_liner = TRUE, style = FALSE))
+ signatures <- gsub("^[^(]+(.*)", "\\1", signatures)
+ signatures_formatted <- sprintf(
+ "\\code{\\link[=%s]{%s}%s}",
+ fun_nms,
+ fun_nms,
+ signatures
+ )
+
+ paste0(
+ "\\section{Constructive options}{\n",
+ "Constructive options provide a way to customize the output of `construct()`.\n",
+ "We can provide calls to `opts_*()` functions to the `...` argument. Each of ",
+ "these functions targets a specific type or class and is documented on its own page.\n\n",
+ "\\itemize{\n",
+ paste0(" \\item ", signatures_formatted, "\n", collapse = ""),
+ "}\n",
+ "}\n"
+ )
+}
+
+# nocov end
diff --git a/sub/constructive.core/R/s3-NULL.R b/sub/constructive.core/R/s3-NULL.R
new file mode 100644
index 00000000..ad0b8b66
--- /dev/null
+++ b/sub/constructive.core/R/s3-NULL.R
@@ -0,0 +1,30 @@
+#' @export
+#' @rdname other-opts
+opts_NULL <- function(
+ constructor = "NULL",
+ ...) {
+ .cstr_options(
+ "NULL",
+ constructor = constructor,
+ ...
+ )
+}
+
+#' @export
+#' @method .cstr_construct NULL
+.cstr_construct.NULL <- function(x, ...) {
+ opts <- list(...)$opts$`NULL` %||% opts_NULL()
+ if (is_corrupted_NULL(x) || opts$constructor == "next") return(NextMethod())
+ UseMethod(".cstr_construct.NULL", structure(NA, class = opts$constructor))
+}
+
+is_corrupted_NULL <- function(x) {
+ typeof(x) != "NULL"
+}
+
+#' @export
+#' @method .cstr_construct.NULL NULL
+.cstr_construct.NULL.NULL <- function(x, ...) {
+ "NULL"
+}
+
diff --git a/sub/constructive.core/R/s3-array.R b/sub/constructive.core/R/s3-array.R
new file mode 100644
index 00000000..b3bc03eb
--- /dev/null
+++ b/sub/constructive.core/R/s3-array.R
@@ -0,0 +1,61 @@
+#' Constructive options for arrays
+#'
+#' These options will be used on arrays. Note that arrays can be built on top of
+#' vectors, lists or expressions. Canonical arrays have an implicit class "array"
+#' shown by `class()` but "array" is not part of the class attribute.
+#'
+#' Depending on `constructor`, we construct the object as follows:
+#' * `"array"` (default): Use the `array()` function
+#' * `"next"` : Use the constructor for the next supported class. Call `.class2()`
+#' on the object to see in which order the methods will be tried.
+#'
+#' @param constructor String. Name of the function used to construct the object, see Details section.
+#' @inheritParams opts_atomic
+#' @return An object of class
+#' @export
+opts_array <- function(constructor = c("array", "next"), ...) {
+ .cstr_options("array", constructor = constructor[[1]], ...)
+}
+
+#' @export
+#' @method .cstr_construct array
+.cstr_construct.array <- function(x, ...) {
+ opts <- list(...)$opts$array %||% opts_array()
+ if (is_corrupted_array(x) || opts$constructor == "next") return(NextMethod())
+ UseMethod(".cstr_construct.array", structure(NA, class = opts$constructor))
+}
+
+is_corrupted_array <- function(x) {
+ dim <- attr(x, "dim")
+ if (is.null(dim) || !is.integer(dim)) return(TRUE)
+ if (!(is.atomic(x) || is.list(x) || is.expression(x))) return(TRUE)
+ FALSE
+}
+
+#' @export
+#' @method .cstr_construct.array array
+.cstr_construct.array.array <- function(x, ...) {
+ # build args for array() call
+ x_stripped <- x
+ attributes(x_stripped) <- NULL
+ args <- list(
+ x_stripped,
+ dim = attr(x, "dim")
+ )
+ dimnames <- attr(x, "dimnames")
+ args$dim_names <- if (!is.null(dimnames)) list(dimnames = dimnames)
+
+ # build code
+ code <- .cstr_apply(args, fun = "array", ...)
+
+ # repair
+ repair_attributes_array(x, code, ...)
+}
+
+repair_attributes_array <- function(x, code, ..., pipe = NULL) {
+ .cstr_repair_attributes(
+ x, code, ...,
+ pipe = pipe,
+ ignore = "dim"
+ )
+}
diff --git a/sub/constructive.core/R/s3-atomic.R b/sub/constructive.core/R/s3-atomic.R
new file mode 100644
index 00000000..2a1c1023
--- /dev/null
+++ b/sub/constructive.core/R/s3-atomic.R
@@ -0,0 +1,124 @@
+#' Constructive options for atomic types
+#'
+#' These options will be used on atomic types ("logical", "integer", "numeric", "complex", "character" and "raw").
+#' They can also be directly provided to atomic types through their own `opts_*()`
+#' function, and in this case the latter will have precedence.
+#'
+#' @param ... Additional options used by user defined constructors through the `opts` object
+#' @param trim `NULL` or integerish. Maximum of elements showed before it's trimmed.
+#' Note that it will necessarily produce code that doesn't reproduce the input.
+#' This code will parse without failure but its evaluation might fail.
+#' @param fill String. Method to use to represent the trimmed elements.
+#' @param compress Boolean. If `TRUE` instead of `c()` Use `seq()`, `rep()`
+#' when relevant to simplify the output.
+#'
+#' @details
+#'
+#' If `trim` is provided, depending on `fill` we will present trimmed elements as followed:
+#' * `"default"` : Use default atomic constructors, so for instance `c("a", "b", "c")` might become `c("a", character(2))`.
+#' * `"rlang"` : Use rlang atomic constructors, so for instance `c("a", "b", "c")` might become `c("a", rlang::new_character(2))`,
+#' these `rlang` constructors create vectors of `NAs`, so it's different from the default option.
+#' * `"+"`: Use unary `+`, so for instance `c("a", "b", "c")` might become `c("a", +2)`.
+#' * `"..."`: Use `...`, so for instance `c("a", "b", "c")` might become `c("a", ...)`
+#' * `"none"`: Don't represent trimmed elements.
+#'
+#' Depending on the case some or all of the choices above might generate code that
+#' cannot be executed. The 2 former options above are the most likely to succeed
+#' and produce an output of the same type and dimensions recursively. This would
+#' at least be the case for data frame.
+#'
+#' @return An object of class
+#' @export
+#' @examples
+#' construct(iris, opts_atomic(trim = 2), check = FALSE) # fill = "default"
+#' construct(iris, opts_atomic(trim = 2, fill = "rlang"), check = FALSE)
+#' construct(iris, opts_atomic(trim = 2, fill = "+"), check = FALSE)
+#' construct(iris, opts_atomic(trim = 2, fill = "..."), check = FALSE)
+#' construct(iris, opts_atomic(trim = 2, fill = "none"), check = FALSE)
+#' construct(iris, opts_atomic(trim = 2, fill = "none"), check = FALSE)
+#' x <- c("a a", "a\U000000A0a", "a\U00002002a", "\U430 \U430")
+opts_atomic <- function(
+ ...,
+ trim = NULL,
+ fill = c("default", "rlang", "+", "...", "none"),
+ compress = TRUE
+) {
+ .cstr_combine_errors(
+ abort_not_null_or_integerish(trim),
+ fill <- rlang::arg_match(fill),
+ abort_not_boolean(compress)
+ )
+ if (any(c("unicode_representation", "escape") %in% names(list(...)))) {
+ msg <- "`unicode_representation` and `escape` are deprecated in `opts_atomic()`"
+ info1 <- "Set those in `opts_character()` instead for the same effect"
+ info2 <- "Set those directly in the main function (e.g. `construct()`) to apply them on both character vectors, symbols and argument names"
+ rlang::warn(c(msg, i = info1, i = info2))
+ }
+
+ .cstr_options("atomic", ..., trim = trim, fill = fill, compress = compress) #, unicode_representation = unicode_representation, escape = escape)
+}
+
+# divisors except self and 1
+divisors <- function(x) {
+ y <- setdiff(seq_len(x / 2), 1)
+ y[x %% y == 0]
+}
+
+# A rle without checks that treats NAs like a regular values and return an unnamed list
+# with value first
+rle2 <- function (x, double = FALSE) {
+ n <- length(x)
+ t <- x[-1L]
+ h <- x[-n]
+ y <- t != h
+ if (double) {
+ y <- ifelse(
+ is.na(y),
+ !(is.nan(t) & is.nan(h)) & !(is_na_real(t) & is_na_real(h)),
+ y
+ )
+ } else {
+ y <- ifelse(is.na(y), !(is.na(t) & is.na(h)), y)
+ }
+ i <- c(which(y), n)
+ list(x[i], diff(c(0L, i)))
+}
+
+
+# Special treatmnent of doubles is necessary because `dput()`, used for default
+# the method, sometimes cuts values too short,
+# however this gives ugly values in the general case
+# in the 2 following cases we want the shortest "equal" output
+# format(5.1, digits = 22) # "5.099999999999999644729"
+# format(1e24, digits = 22) # 999999999999999983222784
+# => so we use `digits = 16` for the default since it seems to simplify those values,
+# and we fall back on `digits = 22` for other cases
+# if it still doesn't fit it we use `sprintf("%a", x)` which provides a representation
+# that is not very readable but always works
+
+
+format_flex <- function(x, all_na) {
+ # negative zeroes
+ if (identical(x, 0) && sign(1/x) == -1) return("-0")
+ # negative NAs, commented for now as might be overkill, and inconsistent
+ # if(is.na(x) && serialize(x, NULL)[[32]] == as.raw(0xff)) {
+ # if (is.nan(x)) return("-NaN")
+ # return("-NA_real_")
+ # }
+ formatted <- format(x, digits = 15)
+ if (formatted == "NA") {
+ if (all_na) return("NA_real_") else return("NA")
+ }
+ if (formatted == "NaN") {
+ return("NaN")
+ }
+ if (as.numeric(formatted) == x) return(formatted)
+ # FIXME: Increase digits only for those array elements that don't match
+ for (digits in 16:22) {
+ formatted <- format(x, digits = digits)
+ if (as.numeric(formatted) == x) return(formatted)
+ }
+ # remove from coverage since system dependent
+ # (similarly to .deparseOpts("hexNumeric"))
+ sprintf("%a", x) # nocov
+}
diff --git a/sub/constructive.core/R/s3-character.R b/sub/constructive.core/R/s3-character.R
new file mode 100644
index 00000000..6b4fd01a
--- /dev/null
+++ b/sub/constructive.core/R/s3-character.R
@@ -0,0 +1,108 @@
+#' Constructive options for type 'character'
+#'
+#' @description
+#' These options will be used on objects of type 'character'. This type has
+#' a single native constructor, but some additional options can be set.
+#'
+#' `unicode_representation` and `escape` are usually better set in the main
+#' function (`construct()` or other) so they apply not only on strings but on
+#' symbols and argument names as well.
+#'
+#' To set options on all atomic types at once see \link{opts_atomic}().
+#'
+#' @inheritParams construct
+#' @inheritParams opts_atomic
+#' @inheritParams other-opts
+#' @param fill String. Method to use to represent the trimmed elements. See `?opts_atomic`
+#' @return An object of class
+#' @export
+opts_character <- function(
+ constructor = c("default"),
+ ...,
+ trim = NULL,
+ fill = c("default", "rlang", "+", "...", "none"),
+ compress = TRUE,
+ unicode_representation = c("ascii", "latin", "character", "unicode"),
+ escape = FALSE) {
+ .cstr_combine_errors(
+ abort_not_null_or_integerish(trim),
+ { fill <- rlang::arg_match(fill) },
+ abort_not_boolean(compress),
+ { unicode_representation <- rlang::arg_match(unicode_representation) },
+ abort_not_boolean(escape)
+ )
+ .cstr_options(
+ "character",
+ constructor = constructor,
+ ...,
+ trim = trim,
+ fill = fill,
+ compress = compress,
+ unicode_representation = unicode_representation,
+ escape = escape
+ )
+}
+
+#' @export
+#' @method .cstr_construct character
+.cstr_construct.character <- function(x, ...) {
+ opts <- list(...)$opts$character %||% opts_character()
+ if (is_corrupted_character(x) || opts$constructor == "next") return(NextMethod())
+ UseMethod(".cstr_construct.character", structure(NA, class = opts$constructor))
+}
+
+is_corrupted_character <- function(x) {
+ typeof(x) != "character"
+}
+
+#' @export
+#' @method .cstr_construct.character default
+.cstr_construct.character.default <- function(x, ...) {
+ # return length 0 object early
+ if (!length(x)) return(.cstr_repair_attributes(x, "character(0)", ...))
+
+ # we apply in priority the character opts, fall back on atomic opts otherwise
+ opts <- list(...)$opts$character %||% opts_character()
+ x_bkp <- x
+
+ # non standard names
+ nms <- names(x)
+ repair_names <- names_need_repair(nms)
+ if (repair_names) names(x) <- NULL
+
+ # trim
+ # FIXME: the name repair is affected by trim
+ if (!is.null(opts$trim)) {
+ code <- trim_atomic(x, opts$trim, opts$fill, ...)
+ if (!is.null(code)) {
+ code <- .cstr_repair_attributes(x_bkp, code, ..., repair_names = repair_names)
+ return(code)
+ }
+ }
+
+ # compression
+ if (opts$compress && is.null(names(x))) {
+ code <- compress_character(x, ...)
+ if (!is.null(code)) {
+ code <- .cstr_repair_attributes(x_bkp, code, ..., repair_names = repair_names)
+ return(code)
+ }
+ }
+
+ # build code for strings with relevant format (a better sapply(x, deparse))
+ strings <- construct_strings(x, ...)
+
+ # return length 1 object early, no need for c() or NA compaction
+ if (length(strings) == 1 && is.null(names(x))) {
+ code <- .cstr_repair_attributes(x_bkp, strings, ..., repair_names = repair_names)
+ return(code)
+ }
+
+ # use NA rather than NA_character when relevant
+ nas <- strings == "NA_character_"
+ if (any(nas) && !all(nas)) strings[nas] <- "NA"
+
+ # wrap with c()
+ code <- .cstr_apply(strings, "c", ..., recurse = FALSE)
+ .cstr_repair_attributes(x_bkp, code, ..., repair_names = repair_names)
+}
diff --git a/sub/constructive.core/R/s3-complex.R b/sub/constructive.core/R/s3-complex.R
new file mode 100644
index 00000000..55baca49
--- /dev/null
+++ b/sub/constructive.core/R/s3-complex.R
@@ -0,0 +1,130 @@
+#' Constructive options for type 'complex'
+#'
+#' @description
+#' These options will be used on objects of type 'complex'. This type has
+#' a single native constructor, but some additional options can be set.
+#'
+#' To set options on all atomic types at once see \link{opts_atomic}().
+#'
+#' @inheritParams opts_atomic
+#' @inheritParams other-opts
+#' @param fill String. Method to use to represent the trimmed elements. See `?opts_atomic`
+#' @return An object of class
+#' @export
+opts_complex <- function(
+ constructor = c("default"),
+ ...,
+ trim = NULL,
+ fill = c("default", "rlang", "+", "...", "none"),
+ compress = TRUE) {
+ .cstr_combine_errors(
+ abort_not_null_or_integerish(trim),
+ { fill <- rlang::arg_match(fill) },
+ abort_not_boolean(compress)
+ )
+ .cstr_options(
+ "complex",
+ constructor = constructor,
+ ...,
+ trim = trim,
+ fill = fill,
+ compress = compress
+ )
+}
+
+#' @export
+#' @method .cstr_construct complex
+.cstr_construct.complex <- function(x, ...) {
+ opts <- list(...)$opts$complex %||% opts_complex()
+ if (is_corrupted_complex(x) || opts$constructor == "next") return(NextMethod())
+ UseMethod(".cstr_construct.complex", structure(NA, class = opts$constructor))
+}
+
+is_corrupted_complex <- function(x) {
+ typeof(x) != "complex"
+}
+
+#' @export
+#' @method .cstr_construct.complex default
+.cstr_construct.complex.default <- function(x, ...) {
+ # return length 0 object early
+ if (!length(x)) return(.cstr_repair_attributes(x, "complex(0)", ...))
+
+ # we apply in priority the complex opts, fall back on atomic opts otherwise
+ all_opts <- list(...)$opts
+ opts <- all_opts$complex %||% opts_complex()
+ x_bkp <- x
+
+ # non standard names
+ nms <- names(x)
+ repair_names <- names_need_repair(nms)
+ if (repair_names) names(x) <- NULL
+
+ # trim
+ # FIXME: the name repair is affected by trim
+ if (!is.null(opts$trim)) {
+ code <- trim_atomic(x, opts$trim, opts$fill, ...)
+ if (!is.null(code)) {
+ code <- .cstr_repair_attributes(x_bkp, code, ..., repair_names = repair_names)
+ return(code)
+ }
+ }
+
+ # compression
+ if (opts$compress && is.null(nms)) {
+ code <- compress_complex(x, ...)
+ if (!is.null(code)) {
+ code <- .cstr_repair_attributes(x_bkp, code, ..., repair_names = repair_names)
+ return(code)
+ }
+ }
+
+ re <- Re(x)
+ im <- Im(x)
+ op <- if (isTRUE(sign(1/im) == -1)) "-" else "+"
+ im <- abs(im)
+ # override double options so they don't affect complex numbers
+ all_opts$double <- opts
+ re_code <- sapply(re, function(x, ..., opts) .cstr_construct.double(x, ..., opts = all_opts), ...)
+ im_code <- sapply(im, function(x, ..., opts) .cstr_construct.double(x, ..., opts = all_opts), ...)
+
+ # general case
+
+ code <- sprintf("%s%s%si", re_code, op, im_code)
+ # zero real parts can be omitted
+ zero_real <- re_code == "0"
+ code[zero_real] <- paste0(im_code[zero_real], "i")
+ # zero im parts can sometimes be omitted
+ zero_im <- !zero_real & im_code == "0" & !all(im_code == "0")
+ code[zero_im] <- re_code[zero_im]
+ # if both parts are true NA we have a NA_complex
+ complex_na <- is_na_real(re) & is_na_real(im)
+ code[complex_na] <- "NA_complex_"
+ other_na <- is.na(x) & !complex_na
+ if (any(other_na)) {
+ code[other_na] <- mapply(
+ function(re, im) {
+ .cstr_apply(list(real = re, imaginary = im), "complex", recurse = FALSE)
+ },
+ re = re[other_na],
+ im = im[other_na]
+ )
+ }
+
+ if (length(x) == 1 && is.null(names(x))) {
+ code <- .cstr_repair_attributes(x_bkp, code, ..., repair_names = repair_names)
+ return(code)
+ }
+
+ # wrap with c()
+ names(code) <- names(x)
+ code <- .cstr_apply(code, "c", ..., recurse = FALSE)
+ if (list(...)$one_liner) code <- paste(code, collapse = " ")
+ .cstr_repair_attributes(x_bkp, code, ..., repair_names = repair_names)
+}
+
+compress_complex <- function(x, ...) {
+ l <- length(x)
+ if (l > 2 && isTRUE(all(x == 0+0i))) return(sprintf("complex(%s)", l))
+ format_rep(x, ...)
+}
diff --git a/sub/constructive.core/R/s3-dots.R b/sub/constructive.core/R/s3-dots.R
new file mode 100644
index 00000000..bb10954f
--- /dev/null
+++ b/sub/constructive.core/R/s3-dots.R
@@ -0,0 +1,59 @@
+#' Constructive options for type '...'
+#'
+#' These options will be used on objects of type '...'. These are rarely encountered
+#' in practice. By default this function is useless as nothing can be set, this
+#' is provided in case users want to extend the method with other constructors.
+#'
+#'
+#' Depending on `constructor`, we construct the object as follows:
+#' * `"default"` : We use the construct `(function(...) get(\"...\"))(a = x, y)`
+#' which we evaluate in the correct environment.
+#'
+#' @param constructor String. Name of the function used to construct the object.
+#' @inheritParams opts_atomic
+#'
+#' @return An object of class
+#' @export
+opts_dots <- function(constructor = c("default"), ...) {
+ .cstr_options("dots", constructor = constructor[[1]], ...)
+}
+
+#' @export
+#' @method .cstr_construct dots
+.cstr_construct.dots <- function(x, ...) {
+ opts <- list(...)$opts$dots %||% opts_dots()
+ if (is_corrupted_dots(x)) return(NextMethod())
+ UseMethod(".cstr_construct.dots", structure(NA, class = opts$constructor))
+}
+
+is_corrupted_dots <- function(x) {
+ typeof(x) != "..."
+}
+
+#' @export
+#' @method .cstr_construct.dots default
+.cstr_construct.dots.default <- function(x, ...) {
+ quo_dots <- with(list(... = x), rlang::enquos(...))
+ envs <- lapply(quo_dots, rlang::quo_get_env)
+ unique_env <- unique(envs)
+ if (length(unique_env) == 1) {
+ unique_env <- unique_env[[1]]
+ exprs <- lapply(quo_dots, rlang::quo_get_expr)
+ code_lng <- rlang::expr((function(...) get("..."))(!!!exprs))
+ code <- deparse_call0(code_lng, ...)
+ env_code <- .cstr_construct(unique_env, ...)
+ code <- .cstr_apply(list(code, envir = env_code), "evalq", recurse = FALSE)
+ return(repair_attributes_dots(x, code, ...))
+ }
+ # strip class since it's not necessary for splicing
+ quo_code <- .cstr_construct(unclass(quo_dots), ...)
+ quo_code[[1]] <- paste0("!!!", quo_code[[1]])
+ code <- .cstr_wrap(quo_code, "(function(...) get(\"...\"))")
+ code <- .cstr_wrap(code, "rlang::inject")
+
+ repair_attributes_dots(x, code, ...)
+}
+
+repair_attributes_dots <- function(x, code, ...) {
+ .cstr_repair_attributes(x, code, ...)
+}
diff --git a/sub/constructive.core/R/s3-double.R b/sub/constructive.core/R/s3-double.R
new file mode 100644
index 00000000..fbd82b1d
--- /dev/null
+++ b/sub/constructive.core/R/s3-double.R
@@ -0,0 +1,135 @@
+#' Constructive options for type 'double'
+#'
+#' @description
+#' These options will be used on objects of type 'double'. This type has
+#' a single native constructor, but some additional options can be set.
+#'
+#' To set options on all atomic types at once see \link{opts_atomic}().
+#'
+#' @inheritParams opts_atomic
+#' @inheritParams other-opts
+#' @param fill String. Method to use to represent the trimmed elements. See `?opts_atomic`
+#' @return An object of class
+#' @export
+opts_double <- function(
+ constructor = c("default"),
+ ...,
+ trim = NULL,
+ fill = c("default", "rlang", "+", "...", "none"),
+ compress = TRUE) {
+ .cstr_combine_errors(
+ abort_not_null_or_integerish(trim),
+ { fill <- rlang::arg_match(fill) },
+ abort_not_boolean(compress)
+ )
+ .cstr_options(
+ "double",
+ constructor = constructor,
+ ...,
+ trim = trim,
+ fill = fill,
+ compress = compress
+ )
+}
+
+#' @export
+#' @method .cstr_construct double
+.cstr_construct.double <- function(x, ...) {
+ opts <- list(...)$opts$double %||% opts_double()
+ if (is_corrupted_double(x) || opts$constructor == "next") return(NextMethod())
+ UseMethod(".cstr_construct.double", structure(NA, class = opts$constructor))
+}
+
+is_corrupted_double <- function(x) {
+ typeof(x) != "double"
+}
+
+#' @export
+#' @method .cstr_construct.double default
+.cstr_construct.double.default <- function(x, ...) {
+ # return length 0 object early
+ if (!length(x)) return(.cstr_repair_attributes(x, "numeric(0)", ...))
+
+ # we apply in priority the double opts, fall back on atomic opts otherwise
+ opts <- list(...)$opts$double %||% opts_double()
+ x_bkp <- x
+
+ # non standard names
+ nms <- names(x)
+ repair_names <- names_need_repair(nms)
+ if (repair_names) names(x) <- NULL
+
+ # trim
+ # FIXME: the name repair is affected by trim
+ if (!is.null(opts$trim)) {
+ code <- trim_atomic(x, opts$trim, opts$fill, ...)
+ if (!is.null(code)) {
+ code <- .cstr_repair_attributes(x_bkp, code, ..., repair_names = repair_names)
+ return(code)
+ }
+ }
+
+ # compression
+ if (opts$compress && is.null(names(x))) {
+ code <- compress_double(x, ...)
+ if (!is.null(code)) {
+ code <- .cstr_repair_attributes(x_bkp, code, ..., repair_names = repair_names)
+ return(code)
+ }
+ }
+
+ if (length(x) == 1 && is.null(names(x))) {
+ code <- format_flex(x, all_na = TRUE)
+ code <- .cstr_repair_attributes(x_bkp, code, ..., repair_names = repair_names)
+ return(code)
+ }
+
+ code <- vapply(x, format_flex, character(1), all_na = all(is_na_real(x)))
+
+ # wrap with c()
+ code <- .cstr_apply(code, "c", ..., recurse = FALSE)
+ if (list(...)$one_liner) code <- paste(code, collapse = " ")
+ .cstr_repair_attributes(x_bkp, code, ..., repair_names = repair_names)
+}
+
+compress_double <- function(x, ...) {
+ l <- length(x)
+ if (l > 2 && isTRUE(all(x == 0L))) {
+ signs <- sign(1/x)
+ if (all(signs == 1)) return(sprintf("numeric(%s)", l))
+ if (all(signs == -1)) return(sprintf("-numeric(%s)", l))
+ }
+ # don't compress if x contains both positive and negative zeroes
+ zeros_ind <- which(x == 0)
+ if (length(zeros_ind)) {
+ contains_pos_and_neg_zeroes <- length(unique(1/x[zeros_ind])) != 1
+ if (contains_pos_and_neg_zeroes) return(NULL)
+ }
+ format_rep(x, ..., double = TRUE) %||% format_seq(x, ...)
+}
+
+format_flex <- function(x, all_na) {
+ # negative zeroes
+ if (identical(x, 0) && sign(1/x) == -1) return("-0")
+ # negative NAs, commented for now as might be overkill, and inconsistent
+ # if(is.na(x) && serialize(x, NULL)[[32]] == as.raw(0xff)) {
+ # if (is.nan(x)) return("-NaN")
+ # return("-NA_real_")
+ # }
+ formatted <- format.default(x, digits = 15)
+ if (formatted == "NA") {
+ if (all_na) return("NA_real_") else return("NA")
+ }
+ if (formatted == "NaN") {
+ return("NaN")
+ }
+ if (as.numeric(formatted) == x) return(formatted)
+ # FIXME: Increase digits only for those array elements that don't match
+ for (digits in 16:22) {
+ formatted <- format.default(x, digits = digits)
+ if (as.numeric(formatted) == x) return(formatted)
+ }
+ # remove from coverage since system dependent
+ # (similarly to .deparseOpts("hexNumeric"))
+ sprintf("%a", x) # nocov
+}
diff --git a/sub/constructive.core/R/s3-environment.R b/sub/constructive.core/R/s3-environment.R
new file mode 100644
index 00000000..c97b727c
--- /dev/null
+++ b/sub/constructive.core/R/s3-environment.R
@@ -0,0 +1,299 @@
+#' Constructive options for type 'environment'
+#'
+#' Environments use reference semantics, they cannot be copied.
+#' An attempt to copy an environment would indeed yield a different environment and `identical(env, copy)` would be `FALSE`.\cr
+#' Moreover most environments have a parent (exceptions are `emptyenv()` and some
+#' rare cases where the parent is `NULL`) and thus to copy the environment we'd
+#' have to have a way to point to the parent, or copy it too. \cr
+#' For this reason environments are \pkg{constructive}'s cryptonite. They make some objects
+#' impossible to reproduce exactly. And since every function or formula has one they're hard to
+#' avoid. \cr
+#'
+#' @details
+#' In some case we can build code that points to a specific environment, namely:
+#' * `.GlobalEnv`, `.BaseNamespaceEnv`, `baseenv()` and `emptyenv()` are used to construct
+#' the global environment, the base namespace, the base package environment and the empty
+#' environment
+#' * Namespaces are constructed using `asNamespace("pkg")`
+#' * Package environments are constructed using `as.environment("package:pkg")`
+#' * "imports" environments are constructed with `parent.env(asNamespace("pkg"))`
+#' * "lazydata" environments are constructed with `getNamespaceInfo("pkg", "lazydata")`
+#'
+#' By default For other environments we use \pkg{constructive}'s function `constructive::.env()`, it fetches
+#' the environment from its memory address and provides as additional information
+#' the sequence of parents until we reach a special environment (those enumerated above).
+#' The advantage of this approach is that it's readable and that the object is accurately reproduced.
+#' The inconvenient is that it's not stable between sessions. If an environment has a `NULL` parent it's always constructed
+#' with `constructive::.env()`, whatever the choice of the constructor.
+#'
+#' Often however we wish to be able to reproduce from scratch a similar environment,
+#' so that we might run the constructed code later in a new session. We offer different
+#' different options to do this, with different trade-offs regarding accuracy and verbosity.
+#'
+#' \{constructive\} will not signal any difference if it can reproduce an equivalent environment,
+#' defined as containing the same values and having a same or equivalent parent.\cr
+#'
+#' See also the `ignore_function_env` argument in `?compare_options`, which disables the check
+#' of environments of function.
+#'
+#' @section Constructors:
+#'
+#' We might set the `constructor` argument to:
+#'
+#' - `".env"` (default): use `constructive::.env()` to construct the environment from
+#' its memory address.
+#' * `"list2env"`: We construct the environment as a list then
+#' use `base::list2env()` to convert it to an environment and assign it a parent. By
+#' default we use as a parent the first special environment we find when going
+#' through ancestors, so we can print code that doesn't use `.env()`.
+#' If `recurse` is `TRUE`
+#' the parent will be built recursively so all ancestors will be created until
+#' we meet a known environment, this might be verbose and will fail if environments
+#' are nested too deep or have a circular relationship. If the environment is empty we use `new.env(parent=)`
+#' for a more economic syntax.
+#' * `"new_environment"` : Similar to the above, but using `rlang::new_environment()`.
+#' * `"new.env"` : All environments will be recreated with the code `"base::new.env()"`,
+#' without argument, effectively creating an empty environment child of
+#' the local (often global) environment. This is enough in cases where the environment
+#' doesn't matter (or matters as long as it inherits from the local environment),
+#' as is often the case with formulas. `recurse` is ignored.
+#' * `"as.environment"` : we attempt to construct the environment as a list and use
+#' `base::as.environment()` on top of it, as in `as.environment(list(a=1, b=2))`, it will
+#' contain the same variables as the original environment but the parent will be the
+#' `emptyenv()`. `recurse` is ignored.
+#' * `"topenv"` : we construct `base::topenv(x)`, see `?topenv`. `recurse` is ignored.
+#' This is the most accurate we can be when constructing only special environments.
+#' * `"predefine"` : Building environments from scratch using the above methods
+#' can be verbose, sometimes redundant and sometimes even impossible due to
+#' circularity (e.g. an environment referencing itself). With `"predefine"`
+#' we define the environments and their content above the object returning
+#' call, using placeholder names `..env.1..`, `..env.2..` etc.
+#' The caveat is that the created code won't be a single call
+#' and will create objects in the workspace. `recurse` is ignored.
+#' @param constructor String. Name of the function used to construct the
+#' environment, see **Constructors** section.
+#' @inheritParams opts_atomic
+#' @param recurse Boolean. Only considered if `constructor` is `"list2env"` or
+#' `"new_environment"`. Whether to attempt to recreate all parent environments
+#' until a known environment is found, if `FALSE` (the default) we will use
+#' `topenv()` to find a known ancestor to set as the parent.
+#'
+#' @return An object of class
+#' @export
+opts_environment <- function(constructor = c(".env", "list2env", "as.environment", "new.env", "topenv", "new_environment", "predefine"), ..., recurse = FALSE) {
+ if (isTRUE(list(...)$predefine)) {
+ msg <- "`predefine = TRUE` in `opts_environment()` is deprecated"
+ info <- "Use `constructor = \"predefine\"` instead."
+ rlang::warn(c(msg, i = info))
+ constructor <- "predefine"
+ }
+ .cstr_options("environment", constructor = constructor[[1]], ..., recurse = recurse)
+}
+
+#' @export
+#' @method .cstr_construct environment
+.cstr_construct.environment <- function(x, ...) {
+ # The name of `asNamespace("pkg")` is always "pkg" and print as ``
+ # The name of `as.environment("package:pkg")` is ALMOST always "package:pkg" and prints as
+ # `` + attributes
+ # The exception is `as.environment("package:base")` which prints as
+ # `` and whose name is "base"
+ # This means `asNamespace("base")` (a.k.a. `.BaseNamespaceEnv`) and
+ # `as.environment("package:base")` (a.k.a. `baseenv()`) have the same name
+ # but are different. So we implement a workaround.
+ opts <- list(...)$opts$environment %||% opts_environment()
+ if (is_corrupted_environment(x)) return(NextMethod())
+
+ # if we can match a special env, return it directly
+ code <- construct_special_env(x)
+ if (!is.null(code)) return(code)
+
+ if (is.null(parent.env(x))) {
+ # according to error of `new.env(parent = NULL)` we should not find NULL
+ # parents anymore, yet we do. In this case we force the use of `env` as a constructor
+ # because it's the only one that can reproduce these objects.
+ .cstr_construct.environment..env(x, ...)
+ } else {
+ UseMethod(".cstr_construct.environment", structure(NA, class = opts$constructor))
+ }
+}
+
+is_corrupted_environment <- function(x) {
+ !is.environment(x)
+}
+
+#' @export
+#' @method .cstr_construct.environment predefine
+.cstr_construct.environment.predefine <- function(x, ...) {
+ update_predefinition(envir = x, ...)
+}
+
+#' @export
+#' @method .cstr_construct.environment .env
+.cstr_construct.environment..env <- function(x, ...) {
+ opts <- list(...)$opts$environment %||% opts_environment()
+ args <- c(
+ list(env_memory_address(x), parents = fetch_parent_names(x)),
+ attributes(x)
+ )
+ if (environmentIsLocked(x)) args <- c(args, locked = TRUE)
+ if (!length(args$parents)) args$parents <- NULL
+ code <- .cstr_apply(args, "constructive::.env", ...)
+ repair_attributes_environment(x, code, ...)
+}
+
+#' @export
+#' @method .cstr_construct.environment list2env
+.cstr_construct.environment.list2env <- function(x, ...) {
+ opts <- list(...)$opts$environment %||% opts_environment()
+ if (contains_self_reference(
+ x,
+ check_parent = opts$recurse,
+ check_function_env = list(...)$opts$`function`$environment %||% TRUE,
+ # FIXME: this would be a very contrived corner case to have a corrupted
+ # srcref containing environment self refs
+ check_srcref = FALSE # list(...)$opts$`function`$srcref %||% FALSE
+ )) {
+ abort_self_reference()
+ }
+
+ if (!opts$recurse) {
+ parent_code <- construct_top_env(parent.env(x))
+ if (length(names(x))) {
+ list_code <- .cstr_construct(env2list(x), ...)
+ code <- .cstr_apply(
+ list(list_code, parent = parent_code),
+ "list2env",
+ ...,
+ recurse = FALSE
+ )
+ code <- apply_env_locks(x, code, ...)
+ return(repair_attributes_environment(x, code, ...))
+ }
+ code <- .cstr_apply(list(parent = parent_code), "new.env", ..., recurse = FALSE)
+ code <- apply_env_locks(x, code, ...)
+ return(repair_attributes_environment(x, code, ...))
+ }
+
+ placeholder <- get_pipe_placeholder(list(...)$pipe)
+ lhs_code <- .cstr_construct(parent.env(x), ...)
+ if (length(names(x))) {
+ data_code <- .cstr_construct(env2list(x), ...)
+ rhs_code <- .cstr_apply(list(data_code, parent = placeholder), "list2env", ..., recurse = FALSE)
+ code <- .cstr_pipe(lhs_code, rhs_code, ...)
+ } else {
+ rhs_code <- .cstr_apply(list(parent = placeholder), "new.env", ..., recurse = FALSE)
+ code <- .cstr_pipe(lhs_code, rhs_code, ...)
+ }
+ code <- apply_env_locks(x, code)
+ repair_attributes_environment(x, code, ...)
+}
+
+#' @export
+#' @method .cstr_construct.environment new_environment
+.cstr_construct.environment.new_environment <- function(x, ...) {
+ opts <- list(...)$opts$environment %||% opts_environment()
+ if (contains_self_reference(
+ x,
+ check_parent = opts$recurse,
+ check_function_env = list(...)$opts$`function`$environment %||% TRUE,
+ # FIXME: this would be a very contrived corner case to have a corrupted
+ # srcref containing environment self refs
+ check_srcref = FALSE # list(...)$opts$`function`$srcref %||% FALSE
+ )) {
+ abort_self_reference()
+ }
+ if (!opts$recurse) {
+ parent_code <- construct_top_env(parent.env(x))
+ if (length(names(x))) {
+ list_code <- .cstr_construct(env2list(x), ...)
+ code <- .cstr_apply(
+ list(list_code, parent = parent_code),
+ "rlang::new_environment",
+ ...,
+ recurse = FALSE
+ )
+ code <- apply_env_locks(x, code)
+ return(repair_attributes_environment(x, code, ...))
+ }
+ code <- .cstr_apply(list(parent = parent_code), "rlang::new_environment", ...)
+ code <- apply_env_locks(x, code)
+ return(repair_attributes_environment(x, code, ...))
+ }
+
+ placeholder <- get_pipe_placeholder(list(...)$pipe)
+ lhs_code <- .cstr_construct(parent.env(x), ...)
+ if (length(names(x))) {
+ data_code <- .cstr_construct(env2list(x), ...)
+ rhs_code <- .cstr_apply(list(data_code, parent = placeholder), "rlang::new_environment", ..., recurse = FALSE)
+ code <- .cstr_pipe(lhs_code, rhs_code, ...)
+ } else {
+ rhs_code <- .cstr_apply(list(parent = placeholder), "rlang::new_environment", ..., recurse = FALSE)
+ code <- .cstr_pipe(lhs_code, rhs_code, ...)
+ }
+ code <- apply_env_locks(x, code)
+ repair_attributes_environment(x, code, ...)
+}
+
+#' @export
+#' @method .cstr_construct.environment new.env
+.cstr_construct.environment.new.env <- function(x, ...) {
+ code <- "new.env()"
+ repair_attributes_environment(x, code, ...)
+}
+
+#' @export
+#' @method .cstr_construct.environment as.environment
+.cstr_construct.environment.as.environment <- function(x, ...) {
+ if (contains_self_reference(
+ x,
+ check_parent = FALSE,
+ check_function_env = list(...)$opts$`function`$environment %||% TRUE,
+ # FIXME: this would be a very contrived corner case to have a corrupted
+ # srcref containing environment self refs
+ check_srcref = FALSE # list(...)$opts$`function`$srcref %||% FALSE
+ )) {
+ abort_self_reference()
+ }
+ # We need to use as.list.environment() (via env2list()) because as.list() will only map
+ # to as.list.environment() if class was not overriden
+ code <- .cstr_wrap(
+ .cstr_construct(env2list(x), ...),
+ "as.environment",
+ new_line = FALSE
+ )
+ code <- apply_env_locks(x, code)
+ repair_attributes_environment(x, code, ...)
+}
+
+#' @export
+#' @method .cstr_construct.environment topenv
+.cstr_construct.environment.topenv <- function(x, ...) {
+ code <- .cstr_construct(topenv(x), ...)
+ code
+}
+
+repair_attributes_environment <- function(x, code, ...) {
+ opts <- list(...)$opts$environment %||% opts_environment()
+ if (opts$constructor == ".env" ||
+ grepl("^asNamespace\\(\"[^\"]+\"\\)", code[[1]]) ||
+ code[[1]] %in% c("baseenv()", "emptyenv()", ".GlobalEnv", ".BaseNamespaceEnv")
+ ) {
+ # nothing to repair
+ return(code)
+ }
+
+ pkg_env_lgl <- grepl("as.environment\\(\"[^\"]+\"\\)", code[[1]])
+ .cstr_repair_attributes(
+ x, code, ...,
+ ignore = c(
+ # pkg:fun envs have name and path attributes already set by `as.environment()`
+ if (pkg_env_lgl) c("name", "path"),
+ if (opts$constructor == "predefine") "class"
+ )
+ )
+}
+
+env2list <- function(x) {
+ as.list.environment(x, all.names = TRUE, sorted = TRUE)
+}
diff --git a/sub/constructive.core/R/s3-externalptr.R b/sub/constructive.core/R/s3-externalptr.R
new file mode 100644
index 00000000..9e828afc
--- /dev/null
+++ b/sub/constructive.core/R/s3-externalptr.R
@@ -0,0 +1,46 @@
+#' Constructive options for type 'externalptr'
+#'
+#' These options will be used on objects of type 'externalptr'. By default this
+#' function is useless as nothing can be set, this is provided in case users wan
+#' to extend the method with other constructors.
+#'
+#' Depending on `constructor`, we construct the object as follows:
+#' * `"default"` : We use a special function from the constructive
+#'
+#' @param constructor String. Name of the function used to construct the object.
+#' @inheritParams opts_atomic
+#'
+#' @return An object of class
+#' @export
+opts_externalptr <- function(constructor = c("default"), ...) {
+ .cstr_options("externalptr", constructor = constructor[[1]], ...)
+}
+
+#' @export
+#' @method .cstr_construct externalptr
+.cstr_construct.externalptr <- function(x, ...) {
+ opts <- list(...)$opts$externalptr %||% opts_externalptr()
+ if (is_corrupted_externalptr (x)) return(NextMethod())
+ UseMethod(".cstr_construct.externalptr", structure(NA, class = opts$constructor))
+}
+
+is_corrupted_externalptr <- function(x) {
+ typeof(x) != "externalptr"
+}
+
+#' @export
+#' @method .cstr_construct.externalptr default
+.cstr_construct.externalptr.default <- function(x, ...) {
+ addr <- external_pointer_address(x)
+ # In tests, use a stable fictional address but do NOT register it,
+ # so lookup fails and faithfulness checks can detect mismatch.
+ if (!identical(Sys.getenv("TESTTHAT"), "true")) {
+ globals[["external_pointers"]][[addr]] <- x
+ }
+ code <- sprintf('constructive::.xptr("%s")', addr)
+ repair_attributes_externalptr(x, code, ...)
+}
+
+repair_attributes_externalptr <- function(x, code, ...) {
+ .cstr_repair_attributes(x, code, ...)
+}
diff --git a/sub/constructive.core/R/s3-function.R b/sub/constructive.core/R/s3-function.R
new file mode 100644
index 00000000..d5037857
--- /dev/null
+++ b/sub/constructive.core/R/s3-function.R
@@ -0,0 +1,209 @@
+#' Constructive options for functions
+#'
+#' These options will be used on functions, i.e. objects of type "closure", "special" and "builtin".
+#'
+#' Depending on `constructor`, we construct the object as follows:
+#' * `"function"` (default): Build the object using a standard `function() {}`
+#' definition. This won't set the environment by default, unless `environment`
+#' is set to `TRUE`. If a srcref is available, if this srcref matches the function's
+#' definition, and if `trim` is left `NULL`, the code is returned from using the srcref,
+#' so comments will be shown in the output of `construct()`. In the rare case
+#' where the ast body of the function contains non syntactic nodes this constructor
+#' cannot be used and falls back to the `"as.function"` constructor.
+#' * `"as.function"` : Build the object using a `as.function()` call.
+#' back to `data.frame()`.
+#' * `"new_function"` : Build the object using a `rlang::new_function()` call.
+#'
+#' @param constructor String. Name of the function used to construct the object, see Details section.
+#' @inheritParams opts_atomic
+#' @param environment Boolean. Whether to reconstruct the function's environment.
+#' @param srcref Boolean. Whether to attempt to reconstruct the function's srcref.
+#' @param trim `NULL` or integerish. Maximum of lines showed in the body before it's trimmed,
+#' replacing code with `...`. Note that it will necessarily produce code that doesn't
+#' reproduce the input, but it will parse and evaluate without failure.
+#'
+#' @return An object of class
+#' @export
+opts_function <- function(
+ constructor = c("function", "as.function", "new_function"),
+ ...,
+ environment = TRUE,
+ srcref = FALSE,
+ trim = NULL) {
+ .cstr_combine_errors(
+ check_dots_empty(),
+ abort_not_boolean(environment),
+ abort_not_boolean(srcref),
+ abort_not_null_or_integerish(trim)
+ )
+ .cstr_options("function", constructor = constructor[[1]], environment = environment, srcref = srcref, trim = trim)
+}
+
+#' @export
+#' @method .cstr_construct function
+.cstr_construct.function <- function(x, ...) {
+ if (rlang::is_primitive(x)) return(deparse(x))
+ opts <- list(...)$opts$`function` %||% opts_function()
+ if (is_corrupted_function(x)) return(NextMethod())
+ UseMethod(".cstr_construct.function", structure(NA, class = opts$constructor))
+}
+
+is_corrupted_function <- function(x) {
+ !is.function(x)
+}
+
+#' @export
+#' @method .cstr_construct.function function
+.cstr_construct.function.function <- function(x, ...) {
+ opts <- list(...)$opts$`function` %||% opts_function()
+ trim <- opts$trim
+ environment <- opts$environment && !identical(environment(x), list(...)$env)
+ srcref <- opts$srcref
+
+ x_bkp <- x
+ if (!is.null(trim)) x <- trim_function(x, trim)
+
+ # if the srcref matches the function's body (always in non artifical cases)
+ # we might use the srcref rather than the body, so we keep the comments
+
+ x_lst <- as.list(unclass(x))
+ x_length <- length(x_lst)
+
+ all_components_are_proper_expressions <-
+ all(vapply(x_lst, is_expression2, logical(1)))
+
+ if (!all_components_are_proper_expressions) {
+ # fall back on `as.function()` constructor
+ res <- .cstr_construct.function.as.function(x, ...)
+ return(res)
+ }
+
+ code_from_srcref <- FALSE
+ if (!list(...)$one_liner && is.null(trim)) {
+ code <- code_from_srcref(x)
+ if (!is.null(code)) {
+ code_from_srcref <- TRUE
+ }
+ }
+
+ if (!code_from_srcref) {
+ fun_call <- call("function")
+ if (x_length > 1) {
+ fun_call[[2]] <- as.pairlist(x_lst[-x_length])
+ }
+ fun_call[3] <- x_lst[x_length]
+ code <- deparse_call0(fun_call, ...)
+ if (length(code) == 2) code <- paste(code[1], code[2])
+ }
+
+ attrs <- attributes(x)
+ if (!srcref) attrs$srcref <- NULL
+
+ remove_srcref <- srcref && is.null(attr(x, "srcref"))
+
+ if (environment || length(attrs) || remove_srcref) {
+ code <- .cstr_wrap(code, fun = "")
+ }
+ if (environment) {
+ envir_code <- .cstr_apply(list(environment(x)), "(`environment<-`)", ...)
+ code <- .cstr_pipe(code, envir_code, ...)
+ }
+ repair_attributes_function(x_bkp, code, remove_srcref = remove_srcref, ...)
+}
+
+#' @export
+#' @method .cstr_construct.function as.function
+.cstr_construct.function.as.function <- function(x, ...) {
+ opts <- list(...)$opts$`function` %||% opts_function()
+ trim <- opts$trim
+ environment <- opts$environment
+ srcref <- opts$srcref
+
+ x_bkp <- x
+ if (!is.null(trim)) x <- trim_function(x, trim)
+
+ x_lst <- as.list(unclass(x))
+
+ all_components_are_proper_expressions <-
+ all(vapply(x_lst, is_expression2, logical(1)))
+
+ if (all_components_are_proper_expressions) {
+ fun_lst <- lapply(x_lst, deparse_call0, ...)
+ args <- list(.cstr_apply(fun_lst, "alist", ..., recurse = FALSE))
+ } else {
+ fun_lst <- lapply(x_lst, function(x, ...) .cstr_construct(x, ...), ...)
+ args <- list(.cstr_apply(fun_lst, "list", ..., recurse = FALSE))
+ }
+
+ if (environment) {
+ envir_arg <- .cstr_construct(environment(x), ...)
+ args <- c(args, list(envir = envir_arg))
+ }
+ code <- .cstr_apply(args, "as.function", ..., recurse = FALSE)
+ repair_attributes_function(x_bkp, code, ...)
+}
+
+#' @export
+#' @method .cstr_construct.function new_function
+.cstr_construct.function.new_function <- function(x, ...) {
+ opts <- list(...)$opts$`function` %||% opts_function()
+ trim <- opts$trim
+ environment <- opts$environment
+ srcref <- opts$srcref
+
+ x_bkp <- x
+ if (!is.null(trim)) x <- trim_function(x)
+
+ x_lst <- as.list(unclass(x))
+
+ args <- lapply(x_lst[-length(x_lst)], deparse_call0, ...)
+ args <- .cstr_apply(args, "alist", ..., recurse = FALSE)
+ body <- .cstr_construct.language(x_lst[[length(x_lst)]], ...)
+
+ args <- list(args = args, body = body)
+ if (environment) {
+ envir_arg <- .cstr_construct(environment(x), ...)
+ args <- c(args, list(env = envir_arg))
+ }
+ code <- .cstr_apply(args, "rlang::new_function", ..., recurse = FALSE)
+ repair_attributes_function(x_bkp, code, ...)
+}
+
+repair_attributes_function <- function(x, code, remove_srcref = FALSE, ...) {
+ opts <- list(...)$opts$`function` %||% opts_function()
+ srcref <- opts[["srcref"]]
+ ignore <- if (!srcref) "srcref"
+ remove <- if (remove_srcref) "srcref"
+ .cstr_repair_attributes(x, code, ..., remove = remove, ignore = ignore)
+}
+
+# returns the srcref as a character vector IF it matches the actual function, NULL otherwise
+code_from_srcref <- function(x) {
+ srcref <- attr(x, "srcref")
+ # srcref might have been zapped or function built withoiut srcref
+ if (is.null(srcref)) return(NULL)
+ srcref_chr <- as.character(srcref)
+ # srcref might have been manipulated and not parseable -> try
+ parsed <- try(parse(text = srcref_chr)[[1]], silent = TRUE)
+ if (
+ inherits(parsed, "try-error") ||
+ # don't bother trying to eval if it's not a function call
+ !identical(parsed[[1]], quote(`function`)) ||
+ # Note : ignore.srcef = TRUE is not enough, it might just look at the srcref attribute at the top level
+ !identical(rlang::zap_srcref(eval(parsed)), rlang::zap_srcref(x), ignore.environment = TRUE)
+ ) {
+ return(NULL)
+ }
+ srcref_chr
+}
+
+trim_function <- function(x, trim) {
+ x_lst <- as.list(unclass(x))
+ x_length <- length(x_lst)
+ body_lng <- x_lst[[x_length]]
+ if (length(body_lng) > trim + 1) {
+ x_lst[[x_length]] <- as.call(c(head(as.list(body_lng), trim + 1), quote(...)))
+ x <- as.function(x_lst, envir = environment(x))
+ }
+ x
+}
diff --git a/sub/constructive.core/R/s3-integer.R b/sub/constructive.core/R/s3-integer.R
new file mode 100644
index 00000000..d52912ea
--- /dev/null
+++ b/sub/constructive.core/R/s3-integer.R
@@ -0,0 +1,100 @@
+#' Constructive options for type 'integer'
+#'
+#' @description
+#' These options will be used on objects of type 'integer'. This type has
+#' a single native constructor, but some additional options can be set.
+#'
+#' To set options on all atomic types at once see \link{opts_atomic}().
+#'
+#' @inheritParams opts_atomic
+#' @inheritParams other-opts
+#' @param fill String. Method to use to represent the trimmed elements. See `?opts_atomic`
+#' @return An object of class
+#' @export
+opts_integer <- function(
+ constructor = c("default"),
+ ...,
+ trim = NULL,
+ fill = c("default", "rlang", "+", "...", "none"),
+ compress = TRUE) {
+ .cstr_combine_errors(
+ abort_not_null_or_integerish(trim),
+ { fill <- rlang::arg_match(fill) },
+ abort_not_boolean(compress)
+ )
+ .cstr_options(
+ "integer",
+ constructor = constructor,
+ ...,
+ trim = trim,
+ fill = fill,
+ compress = compress
+ )
+}
+
+#' @export
+#' @method .cstr_construct integer
+.cstr_construct.integer <- function(x, ...) {
+ opts <- list(...)$opts$integer %||% opts_integer()
+ if (is_corrupted_integer(x) || opts$constructor == "next") return(NextMethod())
+ UseMethod(".cstr_construct.integer", structure(NA, class = opts$constructor))
+}
+
+is_corrupted_integer <- function(x) {
+ typeof(x) != "integer"
+}
+
+#' @export
+#' @method .cstr_construct.integer default
+.cstr_construct.integer.default <- function(x, ...) {
+ # return length 0 object early
+ if (!length(x)) return(.cstr_repair_attributes(x, "integer(0)", ...))
+
+ # we apply in priority the integer opts, fall back on atomic opts otherwise
+ opts <- list(...)$opts$integer %||% opts_integer()
+ x_bkp <- x
+
+ # non standard names
+ nms <- names(x)
+ repair_names <- names_need_repair(nms)
+ if (repair_names) names(x) <- NULL
+
+ # trim
+ # FIXME: the name repair is affected by trim
+ if (!is.null(opts$trim)) {
+ code <- trim_atomic(x, opts$trim, opts$fill, ...)
+ if (!is.null(code)) {
+ code <- .cstr_repair_attributes(x_bkp, code, ..., repair_names = repair_names)
+ return(code)
+ }
+ }
+
+ # compression
+ if (opts$compress && is.null(names(x))) {
+ code <- compress_integer(x, ...)
+ if (!is.null(code)) {
+ code <- .cstr_repair_attributes(x_bkp, code, ..., repair_names = repair_names)
+ return(code)
+ }
+ }
+
+ code <- sapply(x, deparse)
+ if (!all(is.na(x))) {
+ code[is.na(x)] <- "NA"
+ }
+ if (length(x) == 1 && is.null(names(x))) {
+ code <- .cstr_repair_attributes(x_bkp, code, ..., repair_names = repair_names)
+ return(code)
+ }
+
+ # wrap with c()
+ code <- .cstr_apply(code, "c", ..., recurse = FALSE)
+ if (list(...)$one_liner) code <- paste(code, collapse = " ")
+ .cstr_repair_attributes(x_bkp, code, ..., repair_names = repair_names)
+}
+
+compress_integer <- function(x, ...) {
+ l <- length(x)
+ if (l > 2 && isTRUE(all(x == 0L))) return(sprintf("integer(%s)", l))
+ format_rep(x, ...) %||% format_seq(x, ...)
+}
diff --git a/sub/constructive.core/R/s3-language.R b/sub/constructive.core/R/s3-language.R
new file mode 100644
index 00000000..4b5d1c7b
--- /dev/null
+++ b/sub/constructive.core/R/s3-language.R
@@ -0,0 +1,101 @@
+#' Constructive options for type 'language'
+#'
+#' These options will be used on objects of type 'language'. By default this
+#' function is useless as nothing can be set, this is provided in case users want
+#' to extend the method with other constructors.
+#'
+#' Depending on `constructor`, we construct the object as follows:
+#' * `"default"` : We use constructive's deparsing algorithm on attributeless calls,
+#' and use `as.call()` on other language elements when attributes need to be constructed.
+#'
+#' @param constructor String. Name of the function used to construct the object.
+#' @inheritParams opts_atomic
+#'
+#' @return An object of class
+#' @export
+opts_language <- function(constructor = c("default"), ...) {
+ .cstr_options("language", constructor = constructor[[1]], ...)
+}
+
+#' @export
+#' @method .cstr_construct language
+.cstr_construct.language <- function(x, ...) {
+ opts <- list(...)$opts$language %||% opts_language()
+ if (is_corrupted_language(x)) return(NextMethod())
+ UseMethod(".cstr_construct.language", structure(NA, class = opts$constructor))
+}
+
+is_corrupted_language <- function(x) {
+ !typeof(x) %in% c("language", "symbol", "expression")
+}
+
+#' @export
+#' @method .cstr_construct.language default
+.cstr_construct.language.default <- function(x, ...) {
+ if (identical(x, quote(expr=))) return("quote(expr = )")
+ x_stripped <- x
+ attributes(x_stripped) <- NULL
+
+ if (is_expression2(x_stripped)) {
+ code <- deparse_call0(x_stripped, ...)
+ code <- .cstr_wrap(code, "quote", new_line = FALSE)
+ } else {
+ list_call <- .cstr_apply(as.list(x_stripped), "list", ...)
+ code <- .cstr_wrap(list_call, "as.call", new_line = FALSE)
+ }
+ repair_attributes_language(x, code, ...)
+}
+
+repair_attributes_language <- function(x, code, ...) {
+ .cstr_repair_attributes(
+ x, code, ...,
+ ignore = c("srcref", "srcfile", "wholeSrcref")
+ )
+}
+
+# adapted from rlang::is_syntactic_literal
+is_syntactic_literal2 <- function(x) {
+ if (!is.null(attributes(x))) return(FALSE)
+ switch(
+ typeof(x),
+ "NULL" = TRUE,
+ integer = ,
+ # handles, 0, positive and NA
+ double = length(x) == 1 && !isTRUE(sign(x) == -1),
+ logical = ,
+ character = length(x) == 1,
+ complex = length(x) == 1 && isTRUE(Re(x) == 0) && !isTRUE(Im(x) < 0),
+ FALSE
+ )
+}
+
+is_expression2 <- function(x) {
+ non_srcref_attr_nms <- setdiff(
+ names(attributes(x)),
+ c("srcref", "srcfile", "wholeSrcref")
+ )
+ if (length(non_srcref_attr_nms)) return(FALSE)
+ if (is_syntactic_literal2(x) || rlang::is_symbol(x)) return(TRUE)
+ if (!rlang::is_call(x)) return(FALSE)
+ # if the caller itself is empty the call can't be syntactic
+ if (identical(x[[1]], quote(expr=))) return(FALSE)
+ if (is_regular_function_definition(x)) return(TRUE)
+ if (!is_regular_bracket_call(x)) {
+ # if the only arg is missing then we can't use lisp notation to represent
+ # missing args.
+ if (length(x) == 2 && identical(x[[2]], quote(expr=))) return(FALSE)
+ }
+ if (is_regular_function_definition(x[[1]])) return(FALSE)
+ all(vapply(x, is_expression2, logical(1)))
+}
+
+is_regular_function_definition <- function(x) {
+ is.call(x) &&
+ identical(x[[1]], as.symbol("function")) &&
+ length(x) %in% c(3,4) &&
+ (
+ is.null(x[[2]]) ||
+ (is.pairlist(x[[2]]) && all(vapply(x[[2]], is_expression2, logical(1))))
+ ) &&
+ is_expression2(x[[3]])
+}
diff --git a/sub/constructive.core/R/s3-list.R b/sub/constructive.core/R/s3-list.R
new file mode 100644
index 00000000..ad19f903
--- /dev/null
+++ b/sub/constructive.core/R/s3-list.R
@@ -0,0 +1,107 @@
+#' Constructive options for type 'list'
+#'
+#' These options will be used on objects of type 'list'.
+#'
+#' Depending on `constructor`, we construct the object as follows:
+#' * `"list"` (default): Build the object by calling `list()`.
+#' * `"list2"`: Build the object by calling `rlang::list2()`, the only difference with
+#' the above is that we keep a trailing comma when the list is not trimmed and the call
+#' spans several lines.
+#'
+#' If `trim` is provided, depending on `fill` we will present trimmed elements as followed:
+#' * `"vector"` (default): Use `vector()`, so for instance `list("a", "b", "c")` might become `c(list("a"), vector("list", 2))`.
+#' * `"new_list"`: Use `rlang::new_list()`, so for instance `list("a", "b", "c")` might become `c(list("a"), rlang::new_list(2))`.
+#' * `"+"`: Use unary `+`, so for instance `list("a", "b", "c")` might become `list("a", +2)`.
+#' * `"..."`: Use `...`, so for instance `list("a", "b", "c")` might become `list("a", ...)`
+#' * `"none"`: Don't represent trimmed elements.
+#'
+#' When `trim` is used the output is parsable but might not be possible to evaluate,
+#' especially with `fill = "..."`. In that case you might want to set `check = FALSE`
+#'
+#' @param constructor String. Name of the function used to construct the object, see Details section.
+#' @inheritParams opts_atomic
+#' @param trim `NULL` or integerish. Maximum of elements showed before it's trimmed.
+#' Note that it will necessarily produce code that doesn't reproduce the input.
+#' This code will parse without failure but its evaluation might fail.
+#' @param fill String. Method to use to represent the trimmed elements.
+#'
+#' @return An object of class
+#' @export
+opts_list <- function(
+ constructor = c("list", "list2"),
+ ...,
+ trim = NULL,
+ fill = c("vector", "new_list", "+", "...", "none")) {
+ .cstr_combine_errors(
+ abort_not_null_or_integerish(trim),
+ fill <- rlang::arg_match(fill)
+ )
+ .cstr_options("list", constructor = constructor[[1]], ..., trim = trim, fill = fill)
+}
+
+#' @export
+#' @method .cstr_construct list
+.cstr_construct.list <- function(x, ...) {
+ opts <- list(...)$opts$list %||% opts_list()
+ if (is_corrupted_list(x)) return(NextMethod())
+ UseMethod(".cstr_construct.list", structure(NA, class = opts$constructor))
+}
+
+is_corrupted_list <- function(x) {
+ typeof(x) != "list"
+}
+
+construct_list <- function(x, constructor, trim, fill, trailing_comma, ...) {
+ if (!is.null(trim)) {
+ l <- length(x)
+ if (l > trim) {
+ args <- lapply(x[seq_len(trim)], .cstr_construct, ...)
+ if (fill %in% c("+", "...", "none")) {
+ if (fill == "+") {
+ args <- c(args, list(paste0("+", l - trim)))
+ } else if (fill == "...") {
+ args <- c(args, "...")
+ }
+ code <- .cstr_apply(args, constructor, ..., new_line = FALSE, recurse = FALSE, trailing_comma = trailing_comma)
+ return(code)
+ }
+
+ list_code <- .cstr_apply(args, constructor, ..., new_line = FALSE, recurse = FALSE, trailing_comma = trailing_comma)
+ if (fill == "vector") {
+ null_list_code <- sprintf('vector("list", %s)', l - trim)
+ } else {
+ # fill == "new_list
+ null_list_code <- sprintf("rlang::new_list(%s)", l - trim)
+ }
+ # args are not named here so no precaution needed for names args to c
+ code <- .cstr_apply(list(list_code, null_list_code), "c", ..., new_line = FALSE, recurse = FALSE)
+ return(code)
+ }
+ }
+ nms <- names(x)
+ repair_names <- names_need_repair(nms, c_names = FALSE)
+ if (repair_names) names(x) <- NULL
+ .cstr_apply(x, fun = constructor, ..., trailing_comma = trailing_comma)
+}
+
+#' @export
+#' @method .cstr_construct.list list
+.cstr_construct.list.list <- function(x, ...) {
+ opts <- list(...)$opts$list %||% opts_list()
+ code <- construct_list(x, "list", opts$trim, opts$fill, trailing_comma = FALSE, ...)
+ repair_attributes_list(x, code, ...)
+}
+
+#' @export
+#' @method .cstr_construct.list list2
+.cstr_construct.list.list2 <- function(x, ...) {
+ opts <- list(...)$opts$list %||% opts_list()
+ code <- construct_list(x, "rlang::list2", opts$trim, opts$fill, trailing_comma = TRUE, ...)
+ repair_attributes_list(x, code, ...)
+}
+
+repair_attributes_list <- function(x, code, ...) {
+ nms <- names(x)
+ repair_names <- !is.null(nms) && (anyNA(nms) || all(nms == ""))
+ .cstr_repair_attributes(x, code, ..., repair_names = repair_names)
+}
diff --git a/sub/constructive.core/R/s3-logical.R b/sub/constructive.core/R/s3-logical.R
new file mode 100644
index 00000000..b549aa84
--- /dev/null
+++ b/sub/constructive.core/R/s3-logical.R
@@ -0,0 +1,99 @@
+#' Constructive options for type 'logical'
+#'
+#' @description
+#' These options will be used on objects of type 'logical'. This type has
+#' a single native constructor, but some additional options can be set.
+#'
+#' To set options on all atomic types at once see \link{opts_atomic}().
+#' @inheritParams opts_atomic
+#' @inheritParams other-opts
+#' @param fill String. Method to use to represent the trimmed elements. See `?opts_atomic`
+#' @return An object of class
+#' @export
+opts_logical <- function(
+ constructor = c("default"),
+ ...,
+ trim = NULL,
+ fill = c("default", "rlang", "+", "...", "none"),
+ compress = TRUE) {
+ .cstr_combine_errors(
+ abort_not_null_or_integerish(trim),
+ { fill <- rlang::arg_match(fill) },
+ abort_not_boolean(compress)
+ )
+ .cstr_options(
+ "logical",
+ constructor = constructor,
+ ...,
+ trim = trim,
+ fill = fill,
+ compress = compress
+ )
+}
+
+#' @export
+#' @method .cstr_construct logical
+.cstr_construct.logical <- function(x, ...) {
+ opts <- list(...)$opts$logical %||% opts_logical()
+ if (is_corrupted_logical(x) || opts$constructor == "next") return(NextMethod())
+ UseMethod(".cstr_construct.logical", structure(NA, class = opts$constructor))
+}
+
+is_corrupted_logical <- function(x) {
+ typeof(x) != "logical"
+}
+
+#' @export
+#' @method .cstr_construct.logical default
+.cstr_construct.logical.default <- function(x, ...) {
+ # return length 0 object early
+ if (!length(x)) return(.cstr_repair_attributes(x, "logical(0)", ...))
+
+ # we apply in priority the logical opts, fall back on atomic opts otherwise
+ opts <- list(...)$opts$logical %||% opts_logical()
+ x_bkp <- x
+
+ # non standard names
+ nms <- names(x)
+ repair_names <- names_need_repair(nms)
+ if (repair_names) names(x) <- NULL
+
+ # trim
+ # FIXME: the name repair is affected by trim
+ if (!is.null(opts$trim)) {
+ code <- trim_atomic(x, opts$trim, opts$fill, ...)
+ if (!is.null(code)) {
+ code <- .cstr_repair_attributes(x_bkp, code, ..., repair_names = repair_names)
+ return(code)
+ }
+ }
+
+ # compression
+ if (opts$compress && is.null(names(x))) {
+ code <- compress_logical(x, ...)
+ if (!is.null(code)) {
+ code <- .cstr_repair_attributes(x_bkp, code, ..., repair_names = repair_names)
+ return(code)
+ }
+ }
+
+ code <- sapply(x, deparse)
+ if (!all(is.na(x))) {
+ code[is.na(x)] <- "NA"
+ }
+ if (length(x) == 1 && is.null(names(x))) {
+ code <- .cstr_repair_attributes(x_bkp, code, ..., repair_names = repair_names)
+ return(code)
+ }
+
+ # wrap with c()
+ code <- .cstr_apply(code, "c", ..., recurse = FALSE)
+ if (list(...)$one_liner) code <- paste(code, collapse = " ")
+ .cstr_repair_attributes(x_bkp, code, ..., repair_names = repair_names)
+}
+
+compress_logical <- function(x, ...) {
+ l <- length(x)
+ if (l > 2 && isTRUE(all(!x))) return(sprintf("logical(%s)", l))
+ format_rep(x, ...)
+}
diff --git a/sub/constructive.core/R/s3-matrix.R b/sub/constructive.core/R/s3-matrix.R
new file mode 100644
index 00000000..161fb9f2
--- /dev/null
+++ b/sub/constructive.core/R/s3-matrix.R
@@ -0,0 +1,98 @@
+#' Constructive options for matrices
+#'
+#' Matrices are atomic vectors, lists, or objects of type `"expression"` with a `"dim"`
+#' attributes of length 2.
+#'
+#' Depending on `constructor`, we construct the object as follows:
+#' * `"matrix"` : We use `matrix()`
+#' * `"array"` : We use `array()`
+#' * `"cbind"`,`"rbind"` : We use `cbind()` or `"rbind()"`, this makes named
+#' columns and rows easier to read.
+#' * `"next"` : Use the constructor for the next supported class. Call `.class2()`
+#' on the object to see in which order the methods will be tried. This will usually
+#' be equivalent to `"array"`
+#' * `"atomic"` : We define as an atomic vector and repair attributes
+#'
+#' @param constructor String. Name of the function used to construct the object.
+#' @inheritParams opts_atomic
+#'
+#' @return An object of class
+#' @export
+opts_matrix <- function(constructor = c("matrix", "array", "cbind", "rbind", "next"), ...) {
+ .cstr_options("matrix", constructor = constructor[[1]], ...)
+}
+
+#' @export
+#' @method .cstr_construct matrix
+.cstr_construct.matrix <- function(x, ...) {
+ opts <- list(...)$opts$matrix %||% opts_matrix()
+ if (is_corrupted_matrix(x) || opts$constructor == "next") return(NextMethod())
+ UseMethod(".cstr_construct.matrix", structure(NA, class = opts$constructor))
+}
+
+is_corrupted_matrix <- function(x) {
+ dim <- attr(x, "dim")
+ if (is.null(dim) || !is.integer(dim) || length(dim) != 2) return(TRUE)
+ if (!(is.atomic(x) || is.list(x) || is.expression(x))) return(TRUE)
+ FALSE
+}
+
+#' @export
+#' @method .cstr_construct.matrix matrix
+.cstr_construct.matrix.matrix <- function(x, ...) {
+ dim <- attr(x, "dim")
+ dimnames <- attr(x, "dimnames")
+ dim_names_lst <- if (!is.null(dimnames)) list(dimnames = dimnames)
+ x_stripped <- x
+ attributes(x_stripped) <- NULL
+ code <- .cstr_apply(
+ c(list(x_stripped, nrow = dim[[1]], ncol = dim[[2]]), dim_names_lst),
+ "matrix",
+ ...
+ )
+ repair_attributes_matrix(x, code, ...)
+}
+
+#' @export
+#' @method .cstr_construct.matrix array
+.cstr_construct.matrix.array <- function(x, ...) {
+ .cstr_construct.array.array(x, ...)
+}
+
+#' @export
+#' @method .cstr_construct.matrix cbind
+.cstr_construct.matrix.cbind <- function(x, ...) {
+ dimnames <- attr(x, "dimnames")
+ # apply(simplify = TRUE) needs R >= 4.1
+ args <- lapply(
+ as.data.frame(unclass(x)),
+ set_names,
+ dimnames[[1]]
+ )
+ names(args) <- dimnames[[2]]
+ code <- .cstr_apply(args, "cbind", ...)
+ repair_attributes_matrix(x, code, ...)
+}
+
+#' @export
+#' @method .cstr_construct.matrix rbind
+.cstr_construct.matrix.rbind <- function(x, ...) {
+ dimnames <- attr(x, "dimnames")
+ # apply(simplify = TRUE) needs R >= 4.1
+ args <- lapply(
+ as.data.frame(t(unclass(x))),
+ set_names,
+ dimnames[[2]]
+ )
+ names(args) <- dimnames[[1]]
+ code <- .cstr_apply(args, "rbind", ...)
+ repair_attributes_matrix(x, code, ...)
+}
+
+repair_attributes_matrix <- function(x, code, ..., pipe = NULL) {
+ .cstr_repair_attributes(
+ x, code, ...,
+ pipe = pipe,
+ ignore = c("dim", "dimnames")
+ )
+}
diff --git a/sub/constructive.core/R/s3-object.R b/sub/constructive.core/R/s3-object.R
new file mode 100644
index 00000000..4a509447
--- /dev/null
+++ b/sub/constructive.core/R/s3-object.R
@@ -0,0 +1,51 @@
+#' Constructive options for class 'object'
+#'
+#' These options will be used on objects of class 'object'. The 'object' type
+#' is particular in that it is an internal type in base R, but can only be
+#' produced at time of writing through the 'S7' package. Well this is not
+#' completely true since those can be built from S4 objects that we remove
+#' the S4 flag from by using `asS3(x, complete = FALSE)` but we don't propose
+#' this for now.
+#'
+#' Depending on `constructor`, we construct the object as follows:
+#' * `"S7_object"` (default): We build the object using `S7::S7_object()`.
+#' At the time of writing, this is currently the only way to create these objects.
+#' * `"next"` : Use the constructor for the next supported class.
+#'
+#' @param constructor String. Name of the function used to construct the object.
+#' @param ... Additional options used by user defined constructors through the `opts` object
+#' @return An object of class
+#' @export
+opts_object <- function(constructor = c("prototype", "S7_object"), ...) {
+ constructive::.cstr_options("object", constructor = constructor[[1]], ...)
+}
+
+#' @exportS3Method constructive::.cstr_construct
+.cstr_construct.object <- function(x, ...) {
+ opts <- list(...)$opts$object %||% opts_object()
+ if (is_corrupted_object(x)) return(NextMethod())
+ UseMethod(".cstr_construct.object", structure(NA, class = opts$constructor))
+}
+
+is_corrupted_object <- function(x) {
+ typeof(x) != "object"
+}
+
+#' @export
+.cstr_construct.object.S7_object <- function(x, ...) {
+ code <- "S7::S7_object()"
+ constructive::.cstr_repair_attributes(
+ x, code, ...,
+ idiomatic_class = "S7_object"
+ )
+}
+
+#' @export
+.cstr_construct.object.prototype <- function(x, ...) {
+ "getClass(\"S4\")@prototype"
+ code <- .cstr_pipe("getClass(\"S4\")@prototype", "asS3(complete = FALSE)")
+ .cstr_repair_attributes(
+ x, code, ...,
+ flag_s4 = FALSE
+ )
+}
diff --git a/sub/constructive.core/R/s3-pairlist.R b/sub/constructive.core/R/s3-pairlist.R
new file mode 100644
index 00000000..d11d3c95
--- /dev/null
+++ b/sub/constructive.core/R/s3-pairlist.R
@@ -0,0 +1,45 @@
+#' Constructive options for pairlists
+#'
+#' Depending on `constructor`, we construct the object as follows:
+#' * `"pairlist"` (default): Build the object using a `pairlist()` call.
+#' * `"pairlist2"` : Build the object using a `rlang::pairlist2()` call.
+#'
+#' @param constructor String. Name of the function used to construct the object, see Details section.
+#' @inheritParams opts_atomic
+#'
+#' @return An object of class
+#' @export
+opts_pairlist <- function(constructor = c("pairlist", "pairlist2"), ...) {
+ .cstr_options("pairlist", constructor = constructor[[1]], ...)
+}
+
+#' @export
+#' @method .cstr_construct pairlist
+.cstr_construct.pairlist <- function(x, ...) {
+ opts <- list(...)$opts$pairlist %||% opts_pairlist()
+ if (is_corrupted_pairlist(x)) return(NextMethod())
+ UseMethod(".cstr_construct.pairlist", structure(NA, class = opts$constructor))
+}
+
+is_corrupted_pairlist <- function(x) {
+ typeof(x) != "pairlist"
+}
+
+#' @export
+#' @method .cstr_construct.pairlist pairlist
+.cstr_construct.pairlist.pairlist <- function(x, ...) {
+ code <- .cstr_apply(x, "pairlist", ...)
+ repair_attributes_pairlist(x, code, ...)
+}
+
+#' @export
+#' @method .cstr_construct.pairlist pairlist2
+.cstr_construct.pairlist.pairlist2 <- function(x, ...) {
+ code <- .cstr_apply(x, "rlang::pairlist2", ...)
+ repair_attributes_pairlist(x, code, ...)
+}
+
+repair_attributes_pairlist <- function(x, code, ...) {
+ # FIXME: is there something to repair ?
+ code
+}
diff --git a/sub/constructive.core/R/s3-raw.R b/sub/constructive.core/R/s3-raw.R
new file mode 100644
index 00000000..b493dd28
--- /dev/null
+++ b/sub/constructive.core/R/s3-raw.R
@@ -0,0 +1,158 @@
+#' Constructive options for type 'raw'
+#'
+#' @description
+#'
+#' These options will be used on objects of type 'raw'.
+#'
+#' Depending on `constructor`, we construct the object as follows:
+#' * `"as.raw"` (default): Use `as.raw()`, or `raw()` when relevant
+#' * `"charToRaw"` : Use `charToRaw()` on a string, if the a raw vector contains
+#' a zero we fall back to the "as.raw" constructor.
+#'
+#' To set options on all atomic types at once see \link{opts_atomic}().
+#'
+#' @param constructor String. Name of the function used to construct the object.
+#' @param representation For "as.raw" constructor. Respectively generate output
+#' in the formats `as.raw(0x10)` or `as.raw(16)`
+#' @inheritParams opts_atomic
+#' @inheritParams other-opts
+#' @param fill String. Method to use to represent the trimmed elements. See `?opts_atomic`
+#' @return An object of class
+#' @export
+opts_raw <- function(
+ constructor = c("as.raw", "charToRaw"),
+ ...,
+ trim = NULL,
+ fill = c("default", "rlang", "+", "...", "none"),
+ compress = TRUE,
+ representation = c("hexadecimal", "decimal")
+ ) {
+ .cstr_combine_errors(
+ abort_not_null_or_integerish(trim),
+ { fill <- rlang::arg_match(fill) },
+ abort_not_boolean(compress),
+ { representation <- rlang::arg_match(representation) }
+ )
+ .cstr_options(
+ "raw",
+ constructor = constructor[[1]],
+ ...,
+ trim = trim,
+ fill = fill,
+ compress = compress,
+ representation = representation
+ )
+}
+
+#' @export
+#' @method .cstr_construct raw
+.cstr_construct.raw <- function(x, ...) {
+ opts <- list(...)$opts$raw %||% opts_raw()
+ if (is_corrupted_raw(x) || opts$constructor == "next") return(NextMethod())
+ UseMethod(".cstr_construct.raw", structure(NA, class = opts$constructor))
+}
+
+is_corrupted_raw <- function(x) {
+ typeof(x) != "raw"
+}
+
+#' @export
+#' @method .cstr_construct.raw as.raw
+.cstr_construct.raw.as.raw <- function(x, ...) {
+ # return length 0 object early
+ if (!length(x)) return(.cstr_repair_attributes(x, "raw(0)", ...))
+
+ # we apply in priority the raw opts, fall back on atomic opts otherwise
+ opts <- list(...)$opts$raw %||% opts_raw()
+ x_bkp <- x
+
+ # non standard names
+ nms <- names(x)
+ repair_names <- names_need_repair(nms)
+ if (repair_names) names(x) <- NULL
+
+ # trim
+ # FIXME: the name repair is affected by trim
+ if (!is.null(opts$trim)) {
+ code <- trim_atomic(x, opts$trim, opts$fill, ...)
+ if (!is.null(code)) {
+ code <- .cstr_repair_attributes(x_bkp, code, ..., repair_names = repair_names)
+ return(code)
+ }
+ }
+
+ # compression
+ if (opts$compress && is.null(names(x))) {
+ code <- compress_raw(x, ...)
+ if (!is.null(code)) {
+ code <- .cstr_repair_attributes(x_bkp, code, ..., repair_names = repair_names)
+ return(code)
+ }
+ }
+
+ if (length(x) == 1 && is.null(names(x))) {
+ code <- switch(
+ opts$representation,
+ hexadecimal = sprintf("as.raw(0x%02x)", as.integer(x)),
+ decimal = sprintf("as.raw(%s)", as.integer(x))
+ )
+ code <- .cstr_repair_attributes(x_bkp, code, ..., repair_names = repair_names)
+ return(code)
+ }
+
+ # wrap with c()
+ code <- switch(
+ opts$representation,
+ hexadecimal = sprintf("0x%02x", as.integer(x)),
+ decimal = sprintf("%s", as.integer(x)),
+ )
+ code <- .cstr_apply(code, "c", ..., recurse = FALSE)
+ code <- .cstr_wrap(code, "as.raw")
+ if (list(...)$one_liner) code <- paste(code, collapse = " ")
+ .cstr_repair_attributes(x_bkp, code, ..., repair_names = repair_names)
+}
+
+#' @export
+#' @method .cstr_construct.raw charToRaw
+.cstr_construct.raw.charToRaw <- function(x, ...) {
+ # Fall back when it cannot be represented by a string
+ if (!length(x) || raw(1) %in% x) return(.cstr_construct.raw.as.raw(x, ...))
+
+ # we apply in priority the raw opts, fall back on atomic opts otherwise
+ opts <- list(...)$opts$raw %||% opts_raw()
+ x_bkp <- x
+
+ # non standard names
+ nms <- names(x)
+ repair_names <- names_need_repair(nms)
+ if (repair_names) names(x) <- NULL
+
+ # trim
+ # FIXME: the name repair is affected by trim
+ if (!is.null(opts$trim)) {
+ code <- trim_atomic(x, opts$trim, opts$fill, ...)
+ if (!is.null(code)) {
+ code <- .cstr_repair_attributes(x_bkp, code, ...)
+ return(code)
+ }
+ }
+
+ # compression
+ if (opts$compress && is.null(names(x))) {
+ code <- compress_raw(x, ...)
+ if (!is.null(code)) {
+ code <- .cstr_repair_attributes(x_bkp, code, ...)
+ return(code)
+ }
+ }
+
+ code <- .cstr_wrap(.cstr_construct(rawToChar(x), ...), "charToRaw")
+ if (list(...)$one_liner) code <- paste(code, collapse = " ")
+ .cstr_repair_attributes(x_bkp, code, ..., repair_names = repair_names)
+}
+
+compress_raw <- function(x, ...) {
+ l <- length(x)
+ if (l > 2 && isTRUE(all(x == 0))) return(sprintf("raw(%s)", l))
+ format_rep(x, ...)
+}
diff --git a/sub/constructive.core/R/s3_register.R b/sub/constructive.core/R/s3_register.R
new file mode 100644
index 00000000..8ac6b9e8
--- /dev/null
+++ b/sub/constructive.core/R/s3_register.R
@@ -0,0 +1,54 @@
+# copied from vctrs, appropriately as described in ?vctrs::s3_register
+s3_register <- function (generic, class, method = NULL) {
+ stopifnot(is.character(generic), length(generic) == 1)
+ stopifnot(is.character(class), length(class) == 1)
+ pieces <- strsplit(generic, "::")[[1]]
+ stopifnot(length(pieces) == 2)
+ package <- pieces[[1]]
+ generic <- pieces[[2]]
+ caller <- parent.frame()
+ get_method_env <- function() {
+ top <- topenv(caller)
+ if (isNamespace(top)) {
+ asNamespace(environmentName(top))
+ }
+ else {
+ caller
+ }
+ }
+ get_method <- function(method) {
+ if (is.null(method)) {
+ get(paste0(generic, ".", class), envir = get_method_env())
+ }
+ else {
+ method
+ }
+ }
+ register <- function(...) {
+ envir <- asNamespace(package)
+ method_fn <- get_method(method)
+ stopifnot(is.function(method_fn))
+ if (exists(generic, envir)) {
+ registerS3method(generic, class, method_fn, envir = envir)
+ }
+ # # commented because .rlang_s3_register_compat is not available, and
+ # # this is just used to warn
+ # else if (identical(Sys.getenv("NOT_CRAN"), "true")) {
+ # warn <- .rlang_s3_register_compat("warn")
+ # warn(c(sprintf("Can't find generic `%s` in package %s to register S3 method.",
+ # generic, package), i = "This message is only shown to developers using devtools.",
+ # i = sprintf("Do you need to update %s to the latest version?",
+ # package)))
+ # }
+ }
+ setHook(packageEvent(package, "onLoad"), function(...) {
+ register()
+ })
+ is_sealed <- function(pkg) {
+ identical(pkg, "base") || environmentIsLocked(asNamespace(pkg))
+ }
+ if (isNamespaceLoaded(package) && is_sealed(package)) {
+ register()
+ }
+ invisible()
+}
diff --git a/sub/constructive.core/R/s4.R b/sub/constructive.core/R/s4.R
new file mode 100644
index 00000000..3666ad34
--- /dev/null
+++ b/sub/constructive.core/R/s4.R
@@ -0,0 +1,84 @@
+#' Constructive options for class 'S4'
+#'
+#' These options will be used on objects of class 'S4'.
+#'
+#' Depending on `constructor`, we construct the object as follows:
+#' * `"new"` (default): We build the function using `new()` if possible.
+#' If the class has a "initialize" method we have no practical way to
+#' reverse-engineer the inputs so we fall back to the "prototype" constructor
+#' * `"prototype"` : We start from `getClass("S4")@prototype` and add attributes.
+#'
+#' @param constructor String. Name of the function used to construct the object, see Details section.
+#' @inheritParams opts_atomic
+#' @return An object of class
+#' @export
+opts_S4 <- function(constructor = c("new", "prototype"), ...) {
+ .cstr_options("S4", constructor = constructor[[1]], ...)
+}
+
+#' @export
+#' @method .cstr_construct S4
+.cstr_construct.S4 <- function(x, ...) {
+ opts <- list(...)$opts$S4 %||% opts_S4()
+ if (is_corrupted_S4(x) || opts$constructor == "next") return(NextMethod())
+ if (with_versions(R < "4.4") && !isS4(x)) {
+ # in R < 4.4 we can have objects of type "S4" without the S4 bit on
+ # The S4 bit is recognized by `isS4()` or `isS3()` and set or unset by
+ # `asS4()` or `asS3()`, for later R there is a new type "object" for those
+ # and we can reuse their construction
+ return(.cstr_construct.object.prototype(x, ...))
+ }
+ UseMethod(".cstr_construct.S4", structure(NA, class = opts$constructor))
+}
+
+is_corrupted_S4 <- function(x) {
+ typeof(x) != "S4"
+}
+
+#' @export
+#' @method .cstr_construct.S4 new
+.cstr_construct.S4.new <- function(x, env, ...) {
+ cl <- class(x)
+
+ class_has_initialize <- !is.null(methods::getMethod("initialize", cl, optional = TRUE))
+
+ if (class_has_initialize) {
+ return(.cstr_construct.S4.prototype(x, env = env, ...))
+ }
+
+ if (
+ attr(cl, "package") == environmentName(env) ||
+ (identical(env, .GlobalEnv) && attr(cl, "package") == ".GlobalEnv")) {
+ attr(cl, "package") <- NULL
+ }
+ slots <- getSlots(cl)
+ nms <- names(slots)
+ if (".Data" %in% nms) {
+ attrs <- attributes(x)[setdiff(nms, ".Data")]
+ args <- c(list(cl), .Data = x@.Data, attrs)
+ } else {
+ attrs <- attributes(x)[nms]
+ args <- c(list(cl), attrs)
+ }
+ code <- .cstr_apply(args, fun = "new", env = env, ...)
+ .cstr_repair_attributes(
+ x, code, env = env, ...,
+ ignore = names(getSlots(class(x))),
+ idiomatic_class = class(x),
+ flag_s4 = FALSE
+ )
+}
+
+#' @export
+.cstr_construct.S4.prototype <- function(x, ...) {
+ code <- "getClass(\"S4\")@prototype"
+
+ # flag_s4 = FALSE is to make sure we don't use asS4 when unneeded
+ # as is the case here since `getClass(\"S4\")@prototype` already
+ # produces such object
+ .cstr_repair_attributes(
+ x, code, ...,
+ flag_s4 = FALSE
+ )
+}
+
diff --git a/sub/constructive.core/R/templates.R b/sub/constructive.core/R/templates.R
new file mode 100644
index 00000000..01fdb902
--- /dev/null
+++ b/sub/constructive.core/R/templates.R
@@ -0,0 +1,83 @@
+#' Extend constructive
+#'
+#' @description
+#' `.cstr_new_class()` and `.cstr_new_constructor()` open new unsaved scripts,
+#' optionally commented, that can be used as templates to define new constructors.
+#' If the class is already supported and you want to implement a new constructor,
+#' use `.cstr_new_constructor()`, otherwise use `.cstr_new_class()`.
+#'
+#' @details
+#'
+#' We suggest the following workflow (summarized in a message when you call the functions):
+#' * Call `usethis::use_package(\"constructive\"`, \"Suggests\")` one time at any
+#' point, this will add a soft dependency on 'constructive' so it's only needed to
+#' install it when you use it.
+#' * Call `.cstr_new_class()` or `.cstr_new_constructor()`, with `commented = TRUE` for more guidance.
+#' * Save the scripts unchanged in the "R" folder of your package.
+#' * `devtools::document()`: this will register the S3 methods.
+#' * Try `construct()` on your new object, it should print a call to your chosen
+#' constructor.
+#' * Tweak the code, in particular the definition of `args`.
+#'
+#' The README of the example extension package
+#' ['constructive.example'](https://github.com/cynkra/constructive.example)
+#' guides you through the process. See also \{constructive\}'s own code
+#' and `vignette("extend-constructive")` for more details.
+#'
+#' @param class Class to support, provide the full `class()` vector.
+#' @param constructor Name of the constructor, usually the name of the function
+#' you can to use to build the object. If not you might need to adjust the
+#' script.
+#' @param commented Boolean. Whether to include comments in the template.
+#'
+#' @return Both function return `NULL` invisibly and are called for side effects
+#' @name templates
+#' @export
+.cstr_new_class <- function(
+ class = c("CLASS", "PARENT_CLASS"),
+ constructor = "PKG::CONSTRUCTOR",
+ commented = FALSE) {
+ template <- if (commented) {
+ system.file("new_class_template_commented_no_import.R", package = "constructive")
+ } else {
+ system.file("new_class_template_no_import.R", package = "constructive")
+ }
+ code <- readLines(template)
+ code <- gsub(".CLASS.", .cstr_construct(class, one_liner = TRUE), code, fixed = TRUE)
+ code <- gsub(".CLASS1.", class[[1]], code, fixed = TRUE)
+ code <- gsub(".PKG::CONSTRUCTOR.", constructor, code, fixed = TRUE)
+ code <- gsub(".CONSTRUCTOR.", sub("^.*::(.*)$", "\\1", constructor), code, fixed = TRUE)
+ code <- paste(code, collapse = "\n")
+ rstudioapi::documentNew(code)
+ inform(c(
+ `*` = "Call `usethis::use_package(\"constructive\"`, \"Suggests\")`",
+ `*` = "Save the script in your package's R folder",
+ `*` = "Call `devtools::document()`",
+ `*` = "Tweak and iterate"
+ ))
+ invisible(NULL)
+}
+
+#' @rdname templates
+#' @export
+.cstr_new_constructor <- function(class = c("CLASS", "PARENT_CLASS"), constructor = "PKG::CONSTRUCTOR", commented = FALSE) {
+ template <- if (commented) {
+ system.file("new_constructor_template_commented_no_import.R", package = "constructive")
+ } else {
+ system.file("new_constructor_template_no_import.R", package = "constructive")
+ }
+ code <- readLines(template)
+ code <- gsub(".CLASS.", .cstr_construct(class, one_liner = TRUE), code, fixed = TRUE)
+ code <- gsub(".CLASS1.", class[[1]], code, fixed = TRUE)
+ code <- gsub(".PKG::CONSTRUCTOR.", constructor, code, fixed = TRUE)
+ code <- gsub(".CONSTRUCTOR.", sub("^.*::(.*)$", "\\1", constructor), code, fixed = TRUE)
+ code <- paste(code, collapse = "\n")
+ rstudioapi::documentNew(code)
+ inform(c(
+ `*` = "Call `usethis::use_package(\"constructive\"`, \"Suggests\")`",
+ `*` = "Save the script in your package's R folder",
+ `*` = "Call `devtools::document()`",
+ `*` = "Tweak and iterate"
+ ))
+ invisible(NULL)
+}
diff --git a/sub/constructive.core/R/utils.R b/sub/constructive.core/R/utils.R
new file mode 100644
index 00000000..ee228549
--- /dev/null
+++ b/sub/constructive.core/R/utils.R
@@ -0,0 +1,420 @@
+# Functions that are used in several places, or that have a general scope
+
+#' Wrap argument code in function call
+#'
+#' Exported for custom constructor design. Generally called through `.cstr_apply()`.
+#'
+#' @param args A character vector containing the code of arguments.
+#' @param fun A string. The name of the function to use in the function call.
+#' Use `fun = ""` to wrap in parentheses.
+#' @param new_line Boolean. Whether to insert a new line between `"fun("` and the closing `")"`.
+#'
+#' @return A character vector.
+#' @export
+.cstr_wrap <- function(args, fun, new_line = FALSE) {
+ if (new_line) {
+ return(c(
+ paste0(fun, "("),
+ indent(args),
+ ")"
+ ))
+ }
+ args[1] <- paste0(fun, "(", args[1])
+ l <- length(args)
+ args[l] <- paste0(args[l], ")")
+ args
+}
+
+# "c(1,2)" to "foo = c(1,2),"
+name_and_append_comma <- function(
+ x,
+ nm,
+ implicit_names = FALSE,
+ unicode_representation = c("ascii", "latin", "character", "unicode"),
+ escape = FALSE) {
+ unicode_representation <- match.arg(unicode_representation)
+ if (nm != "" && (!implicit_names || !identical(nm, x))) {
+ nm <- construct_string(nm, unicode_representation, escape, mode = "name")
+ x[1] <- paste(nm, "=", x[1])
+ }
+ x[length(x)] <- paste0(x[length(x)], ",")
+ x
+}
+
+#' Insert a pipe between two calls
+#'
+#' Exported for custom constructor design.
+#'
+#' @param x A character vector. The code for the left hand side call.
+#' @param y A character vector. The code for the right hand side call.
+#' @param pipe A string. The pipe to use, `"plus"` is useful for ggplot code.
+#' @param one_liner A boolean. Whether to paste `x`, the pipe and `y` together
+#' @param indent A boolean. Whether to indent `y`
+#' on a same line (provided that `x` and `y` are strings and one liners themselves)
+#' @param ... Implemented to collect unused arguments forwarded by the dots of the
+#' caller environment.
+#'
+#' @return A character vector
+#' @export
+#' @examples
+#' .cstr_pipe("iris", "head(2)", pipe = "magrittr", one_liner = FALSE)
+#' .cstr_pipe("iris", "head(2)", pipe = "magrittr", one_liner = TRUE)
+.cstr_pipe <- function(x, y, ..., pipe = NULL, one_liner = FALSE, indent = TRUE) {
+ if (is.null(pipe)) {
+ if (with_versions(R >= "4.2.0")) {
+ pipe <- "base"
+ } else {
+ pipe <- "magrittr"
+ }
+ } else if (pipe != "plus") {
+ pipe <- rlang::arg_match(pipe, c("base", "magrittr"))
+ }
+ pipe_symbol <- get_pipe_symbol(pipe)
+ if (one_liner) return(paste(x, pipe_symbol, y))
+ x[length(x)] <- paste(x[length(x)], pipe_symbol)
+ if (indent) {
+ c(x, indent(y))
+ } else {
+ c(x, y)
+ }
+}
+
+arg_match_pipe <- function(pipe, allow_plus = FALSE) {
+ if (is.null(pipe)) {
+ if (with_versions(R >= "4.2.0")) {
+ pipe <- "base"
+ } else {
+ pipe <- "magrittr"
+ }
+ } else if (!allow_plus || pipe != "plus") {
+ pipe <- rlang::arg_match(pipe, c("base", "magrittr"))
+ }
+
+ pipe
+}
+
+get_pipe_symbol <- function(pipe) {
+ pipe <- arg_match_pipe(pipe, allow_plus = TRUE)
+ c(base = "|>", magrittr = "%>%", plus = "+")[[pipe]]
+}
+
+get_pipe_placeholder <- function(pipe) {
+ pipe <- arg_match_pipe(pipe)
+ c(base = "_", magrittr = ".")[[pipe]]
+}
+
+
+is_syntactic <- function(x) {
+ x == make.names(x)
+}
+
+protect <- function(name) {
+ ifelse(is_syntactic(name) | name == "", name, paste0("`", gsub("`", "\\\\`", name), "`"))
+}
+
+namespace_as_list <- function(pkg, main) {
+ ns <- asNamespace(pkg)
+ if (pkg == "base") return(as.list(ns))
+ objs <- c(
+ mget(getNamespaceExports(ns), ns, inherits = TRUE, ifnotfound = list(NULL)),
+ as.list(.getNamespaceInfo(ns, "lazydata"))
+ )
+ if (!main) {
+ names(objs) <- paste0(pkg, "::", names(objs))
+ }
+ objs
+}
+
+# much faster than match()
+perfect_match <- function(needle, haystack) {
+ ind <- vapply(haystack, identical, needle, FUN.VALUE = logical(1))
+ if (any(ind)) names(haystack[ind])[1]
+}
+
+flex_match <- function(needle, haystack) {
+ # ignore attributes of needle and its environment-ness
+ if (is.environment(needle)) needle <- env2list(needle)
+ attributes(needle) <- attributes(needle)["names"]
+ # like identical but ignoring attributes of haystack elements and their environment-ness
+ identical2 <- function(x, needle) {
+ # as.list() doesn't work on environments with a S3 class excluding "environment"
+ if (is.environment(x)) x <- env2list(x)
+ attributes(x) <- attributes(x)["names"]
+ identical(x, needle)
+ }
+ ind <- vapply(haystack, identical2, needle, FUN.VALUE = logical(1))
+ if (any(ind)) names(haystack[ind])[1]
+}
+
+
+# adapted from glue::glue_collapse
+collapse <- function (x, sep = ",", width = 80, last = " and ", quote = "") {
+ if (length(x) == 0) {
+ return(character())
+ }
+ if (any(is.na(x))) {
+ return(NA_character_)
+ }
+ x <- paste0(quote, x, quote)
+ if (nzchar(last) && length(x) > 1) {
+ res <- collapse(x[seq(1, length(x) - 1)], sep = sep, width = Inf, last = "")
+ return(collapse(paste0(res, last, x[length(x)]), width = width))
+ }
+ x <- paste0(x, collapse = sep)
+ if (width < Inf) {
+ x_width <- nchar(x, "width")
+ too_wide <- x_width > width
+ if (too_wide) {
+ x <- paste0(substr(x, 1, width - 3), "...")
+ }
+ }
+ x
+}
+
+scrub_ggplot <- function(x) {
+ x <- flatten.scales(x)
+ x
+}
+
+
+
+# Thanks to Zi Lin : https://stackoverflow.com/questions/75960769
+flatten.scales <- function(gg) {
+ `$` <- base::`$`
+ # take stock how many different scales are contained within the top-level
+ # scale list, & sort their names alphabetically for consistency
+ # FIXME: scrub new ggplot
+ if (with_versions(ggplot2 > "3.5.2")) {
+ orig.scales <- gg@scales
+ } else {
+ orig.scales <- gg[["scales"]]
+ }
+
+ scale.count <- orig.scales$n()
+ scale.aesthetics <- lapply(seq_len(scale.count),
+ function(i) orig.scales$scales[[i]]$aesthetics)
+ names(scale.aesthetics) <- lapply(scale.aesthetics,
+ function(x) x[[1]])
+ scale.names.sorted <- sort(names(scale.aesthetics))
+
+ # define a new empty scale list ggproto object
+ new.scales <- getFromNamespace("scales_list", asNamespace("ggplot2"))()
+
+ # for each scale, traverse up its inheritance tree until we can't go any
+ # higher without losing the function call -- i.e. any super's beyond this
+ # point are inheritances defined in ggproto (e.g. ScaleContinuousPosition
+ # inherits from ScaleContinuous, which in turn inherits from Scale), not
+ # inheritances created during cloning of scales within this ggplot object.
+ # add that scale to the new scale list.
+ for (i in seq_along(scale.names.sorted)) {
+ scale.to.add <- orig.scales$get_scales(scale.names.sorted[[i]])
+ while ("super" %in% names(scale.to.add)) {
+ scale.to.add1 <- scale.to.add$super()
+ if (!is.null(scale.to.add1$call)) {
+ scale.to.add <- scale.to.add1
+ } else {
+ break
+ }
+ }
+ new.scales$add(scale.to.add)
+ }
+
+ if (with_versions(ggplot2 > "3.5.2")) {
+ gg@scales <- new.scales
+ } else {
+ gg[["scales"]] <- new.scales
+ }
+
+ return(gg)
+}
+
+# Not used yet, should be used in construction code rather than using flatten.scales
+# in waldo_proxy methods
+trans_order <- function(x) {
+ n_layers <- length(x$layers)
+ layers <- seq(n_layers)
+ names(layers) <- rep("layers", n_layers)
+
+ n_scales <- x$scales$n()
+ if (!n_scales) return(layers)
+ n_trans <- n_layers + n_scales
+
+ scale_i_reversed <- function(scale) {
+ i <- 0
+ while ("super" %in% names(scale)) {
+ i <- i + 1
+ scale <- scale$super()
+ if (is.null(scale$call)) break
+ }
+ i
+ }
+ scale_order_reversed <- sapply(x$scales$scales, scale_i_reversed)
+ scale_order <- n_trans - scale_order_reversed + 1
+ layer_order <- setdiff(seq(n_trans), scale_order)
+ scales <- seq(n_scales)
+ names(scales) <- rep("scales", n_scales)
+
+ c(layers, scales)[order(c(layer_order, scale_order))]
+}
+
+compare_proxy_LayerInstance <- function(x, path) {
+
+ if (with_versions(ggplot2 > "3.5.2")) {
+ # remove computed elements before comparison
+ # we clone the env not to change it by reference
+ x <- rlang::env_clone(x)
+ if (exists("computed_geom_params", x)) rm("computed_geom_params", envir = x)
+ if (exists("computed_mapping", x)) rm("computed_mapping", envir = x)
+ if (exists("computed_stat_params", x)) rm("computed_stat_params", envir = x)
+ }
+ list(object = x, path = path)
+}
+
+compare_proxy_ggplot <- function(x, path) {
+ list(object = scrub_ggplot(x), path = path)
+}
+
+equivalent_ggplot <- function(x, y) {
+ # ggplot_table triggers a blank plot that can't be silenced so we divert it
+ # not sure if pdf() is the most efficient
+ pdf(tempfile(fileext = ".pdf"))
+ x_tbl <- suppressWarnings(ggplot2::ggplot_gtable(ggplot2::ggplot_build(x)))
+ y_tbl <- suppressWarnings(ggplot2::ggplot_gtable(ggplot2::ggplot_build(y)))
+ dev.off()
+ # we could probably do a better index equivalency check than just scrubbing
+ # them off, but I haven't figured out how it works
+ x_unlisted <- gsub("\\d+", "XXX", unlist(x_tbl))
+ y_unlisted <- gsub("\\d+", "XXX", unlist(y_tbl))
+ names(x_unlisted) <- gsub("\\d+", "XXX", names(x_tbl))
+ names(y_unlisted) <- gsub("\\d+", "XXX", names(y_tbl))
+ identical(x_unlisted, y_unlisted)
+}
+
+expect_faithful_ggplot_construction <- function(p, ...) {
+ tt <- Sys.getenv("TESTTHAT")
+ Sys.setenv(TESTTHAT = "false")
+ on.exit(Sys.setenv(TESTTHAT = tt))
+ code <- construct(p, check = FALSE, ...)$code
+ reconstructed <- eval(parse(text = code))
+ testthat::expect_true(equivalent_ggplot(p, reconstructed))
+}
+
+keep_only_non_defaults <- function(x, f) {
+ fmls <- Filter(function(x) !identical(x, quote(expr=)), formals(f))
+ default_values <- lapply(fmls, function(arg) {
+ try(eval(arg, environment(f)), silent = TRUE)
+ })
+ default_values <- Filter(function(x) !inherits(x, "try-error"), default_values)
+ for (nm in names(default_values)) {
+ if (identical(x[[nm]], default_values[[nm]])) x[[nm]] <- NULL
+ }
+ x
+}
+
+snakeize <- function (x) {
+ x <- gsub("([A-Za-z])([A-Z])([a-z])", "\\1_\\2\\3", x)
+ x <- gsub(".", "_", x, fixed = TRUE)
+ x <- gsub("([a-z])([A-Z])", "\\1_\\2", x)
+ tolower(x)
+}
+
+
+compare_proxy_weakref <- function(x, path) {
+ wr <- list(key = rlang::wref_key(x), value = rlang::wref_value(x))
+ list(object = wr, path = path)
+}
+
+# expr is like `R < "4.3" && dplyr >= "1.0.0"`
+# evaluate in env where R and package names are versions
+with_versions <- function(expr, lib.loc = NULL) {
+ expr <- substitute(expr)
+ vars <- setdiff(all.vars(expr), "R")
+ versions <- suppressWarnings(
+ lapply(vars, packageDescription, lib.loc = lib.loc, fields = "Version")
+ )
+ # dismiss vars that aren't packages
+ keep <- !is.na(versions)
+ versions <- versions[keep]
+ versions <- lapply(versions, as.package_version)
+ names(versions) <- vars[keep]
+ R <- R.Version()
+ R <- as.package_version(sprintf("%s.%s", R$major, R$minor))
+ mask <- c(
+ list(R = R),
+ versions,
+ `==` = base::`==`,
+ `!=` = base::`!=`,
+ `>=` = base::`>=`,
+ `>` = base::`>`,
+ `<=` = base::`<=`,
+ `<` = base::`<`
+ )
+ eval(expr, envir = mask, enclos = parent.frame())
+}
+
+indent <- function(x, depth = 1) {
+ if (length(x) == 0) return(x)
+ paste0(paste0(rep(" ", depth), collapse = ""), x)
+}
+
+split_by_line <- function(x) {
+ with_newline <- paste0(x, "\n")
+ split <- strsplit(with_newline, "\n", fixed = TRUE)
+ unlist(split, recursive = FALSE)
+}
+
+# evaluate default values in the function's namespace
+# fun, pkg: strings
+defaults_arg_values <- function(fun_val, pkg) {
+ args_lng <- head(as.list(fun_val), -1)
+ defaults_lng <- Filter(function(x) !identical(x, quote(expr=)), args_lng)
+ lapply(defaults_lng, eval, asNamespace(pkg))
+}
+
+highlight_code <- function(x, code_theme = NULL, colored = getOption("constructive_pretty", TRUE)) {
+ if (isFALSE(colored)) {
+ return(x)
+ }
+ cli::code_highlight(x, code_theme)
+}
+
+strip <- function(x) {
+ attributes(x) <- attributes(x)["names"]
+ x
+}
+
+# note: system("locale charmap") gives the system encoding on unix but not sure
+# about windows
+native_encoding <- function() {
+ out <- sub("^.*\\.([^.]+)$", "\\1", Sys.getlocale("LC_CTYPE"))
+ if (out == "ISO8859-1") out <- "latin1"
+ out
+}
+
+is_na_real <- function(x) {
+ is.na(x) & !is.nan(x)
+}
+
+names_need_repair <- function(nms, c_names = TRUE) {
+ !is.null(nms) && (
+ anyNA(nms) ||
+ all(nms == "") ||
+ !is.null(attributes(nms)) ||
+ (c_names && any(c("recursive", "use.names") %in% nms))
+ )
+}
+
+user_env <- function() {
+ envs <- sys.frames()
+ ns <- topenv()
+ i <- Position(function(x) identical(topenv(x), ns), envs)
+ # sys.frames() doesn't contain .GlobalEnv
+ parent.frame(length(envs) - i + 1)
+}
+
+compare_proxy_S7_object <- function(x, path) {
+ if (is.function(x)) {
+ x <- rlang::zap_srcref(x)
+ }
+ list(object = x, path = path)
+}
diff --git a/sub/constructive.core/R/zzz.R b/sub/constructive.core/R/zzz.R
new file mode 100644
index 00000000..f168b72a
--- /dev/null
+++ b/sub/constructive.core/R/zzz.R
@@ -0,0 +1,23 @@
+all_opts_funs <- NULL
+
+.onLoad <- function(libname, pkgname) {
+ ns <- asNamespace(pkgname)
+ all_opts_funs_chr <- ls(ns, all.names = TRUE, pattern = "^opts_")
+ all_opts_funs <<- mget(all_opts_funs_chr, ns)
+ s3_register("roxygen2::roxy_tag_parse", "roxy_tag_enumerateOptFunctions")
+ s3_register("roxygen2::roxy_tag_rd", "roxy_tag_enumerateOptFunctions")
+ # Initialize registry for this session
+ globals[["external_pointers"]] <- list()
+}
+
+global_variables <- function() {
+ files <- list.files(system.file("R", package = "constructive"), full.names = TRUE)
+ nms <-
+ sort(unique(unlist(
+ lapply(files, function(file) all.names(parse(file = file), unique = TRUE))
+ )))
+ utils::globalVariables(nms)
+}
+
+global_variables()
+rm(global_variables)
diff --git a/sub/constructive.core/README.md b/sub/constructive.core/README.md
new file mode 100644
index 00000000..eea8aa77
--- /dev/null
+++ b/sub/constructive.core/README.md
@@ -0,0 +1,25 @@
+# constructive.core
+
+Core infrastructure for the constructive package ecosystem.
+
+## Overview
+
+This package contains the core functionality for generating R code that recreates R objects:
+
+- The default `.cstr_construct()` method
+- Infrastructure functions for code generation (`.cstr_apply()`, `.cstr_wrap()`, etc.)
+- Base type constructors (character, integer, double, logical, complex, raw, list, environment, function, NULL, etc.)
+- Helper utilities for deparse, formatting, and attribute repair
+- Main user-facing functions (`construct()`, `construct_multi()`, `construct_diff()`, etc.)
+
+## Purpose
+
+The `constructive.core` package is designed to be a low-dependency foundation that other packages in the constructive ecosystem can build upon. It provides the essential machinery for code generation without including class-specific methods for packages like ggplot2, data.table, tibble, etc.
+
+## Installation
+
+This package is part of the constructive monorepo and is typically installed automatically as a dependency of the main `constructive` package.
+
+## License
+
+MIT
diff --git a/sub/constructive.core/inst/WORDLIST b/sub/constructive.core/inst/WORDLIST
new file mode 100644
index 00000000..06d3565c
--- /dev/null
+++ b/sub/constructive.core/inst/WORDLIST
@@ -0,0 +1,97 @@
+arg
+args
+AsIs
+ast
+atomics
+attributeless
+backtraces
+behaviour
+charToRaw
+citationFooter
+citationHeader
+ClassGenerator
+classGeneratorFunction
+classPrototypeDef
+classRepresentation
+cli
+cli's
+constructive's
+CoordCartesian
+CoordFixed
+CoordFlip
+CoordMap
+CoordMunch
+CoordPolar
+CoordQuickmap
+CoordSf
+CoordTrans
+cryptonite
+cstr
+cynkra
+df
+difftime
+dm
+dput
+é
+errorCondition
+externalptr
+FacetWrap
+formatter
+ggplot
+ggproto
+github
+hexmode
+homoglyphs
+integerish
+lazydata
+Maelle
+magrittr
+mts
+NSE
+objets
+octmode
+ORCID
+overriden
+parsable
+pkgdown
+POSIXct
+POSIXlt
+prettycode
+quosure
+quosures
+README
+rect
+recurse
+refering
+reprex
+reprexes
+rethrow
+rlang
+rowwise
+roxygen
+ScalesList
+simpleCondition
+simpleError
+simpleMessage
+simpleUnit
+simpleWarning
+srcref
+stringsAsFactors
+styler
+tbl
+tibble
+tibbles
+timezones
+tribble
+uneavaluated
+uneval
+unevaluated
+unformatted
+unicode
+vctrs
+warningCondition
+weakref
+xts
+yearmon
+yearqtr
+zooreg
diff --git a/sub/constructive.core/inst/new_class_template.R b/sub/constructive.core/inst/new_class_template.R
new file mode 100644
index 00000000..2b8626af
--- /dev/null
+++ b/sub/constructive.core/inst/new_class_template.R
@@ -0,0 +1,42 @@
+#' @importFrom constructive .cstr_options .cstr_construct .cstr_apply .cstr_repair_attributes
+NULL
+
+#' Constructive options for class '.CLASS1.'
+#'
+#' These options will be used on objects of class '.CLASS1.'.
+#'
+#' Depending on `constructor`, we construct the object as follows:
+#' * `".CONSTRUCTOR."` (default): We build the object using `.PKG::CONSTRUCTOR.()`.
+#' * `"next"` : Use the constructor for the next supported class.
+#'
+#' @param constructor String. Name of the function used to construct the object.
+#' @param ... Additional options used by user defined constructors through the `opts` object
+#' @return An object of class
+#' @export
+opts_.CLASS1. <- function(constructor = c(".CONSTRUCTOR.", "next"), ...) {
+ .cstr_options(".CLASS1.", constructor = constructor[[1]], ...)
+}
+
+#' @export
+#' @method .cstr_construct .CLASS1.
+.cstr_construct..CLASS1. <- function(x, ...) {
+ opts <- list(...)$opts$.CLASS1. %||% opts_.CLASS1.()
+ if (is_corrupted_.CLASS1.(x) || opts$constructor == "next") return(NextMethod())
+ UseMethod(".cstr_construct..CLASS1.", structure(NA, class = opts$constructor))
+}
+
+is_corrupted_.CLASS1. <- function(x) {
+ FALSE
+}
+
+#' @export
+#' @method .cstr_construct..CLASS1. .CONSTRUCTOR.
+.cstr_construct..CLASS1...CONSTRUCTOR. <- function(x, ...) {
+ # opts <- list(...)$opts$.CLASS1. %||% opts_.CLASS1.()
+ args <- list()
+ code <- .cstr_apply(args, fun = ".PKG::CONSTRUCTOR.", ...)
+ .cstr_repair_attributes(
+ x, code, ...,
+ idiomatic_class = .CLASS.
+ )
+}
diff --git a/sub/constructive.core/inst/new_class_template_commented.R b/sub/constructive.core/inst/new_class_template_commented.R
new file mode 100644
index 00000000..94305f3a
--- /dev/null
+++ b/sub/constructive.core/inst/new_class_template_commented.R
@@ -0,0 +1,66 @@
+#' @importFrom constructive .cstr_options .cstr_construct .cstr_apply .cstr_repair_attributes
+NULL
+
+#' Constructive options for class '.CLASS1.'
+#'
+#' These options will be used on objects of class '.CLASS1.'.
+#'
+#' Depending on `constructor`, we construct the object as follows:
+#' * `".CONSTRUCTOR."` (default): We build the object using `.PKG::CONSTRUCTOR.()`.
+#' * `"next"` : Use the constructor for the next supported class.
+#'
+#' @param constructor String. Name of the function used to construct the object.
+#' @param ... Additional options used by user defined constructors through the `opts` object
+#' @return An object of class
+#' @export
+opts_.CLASS1. <- function(constructor = c(".CONSTRUCTOR.", "next"), ...) {
+ # What's forwarded through `...`will be accessible through the `opts`
+ # object in the methods.
+ # You might add arguments to the function, to document those options,
+ # don't forget to forward them below as well
+ .cstr_options(".CLASS1.", constructor = constructor[[1]], ...)
+}
+
+#' @export
+#' @method .cstr_construct .CLASS1.
+.cstr_construct..CLASS1. <- function(x, ...) {
+ # There is probably no need for you to modify this function at all
+ opts <- list(...)$opts$.CLASS1. %||% opts_.CLASS1.()
+ if (is_corrupted_.CLASS1.(x) || opts$constructor == "next") return(NextMethod())
+ # This odd looking code dispatches to a method based on the name of
+ # the constructor rather than the class
+ UseMethod(".cstr_construct..CLASS1.", structure(NA, class = opts$constructor))
+}
+
+is_corrupted_.CLASS1. <- function(x) {
+ # check here if the object has the right structure to be constructed
+ # leaving FALSE is fine but you'll be vulnerable to corrupted objects
+ FALSE
+}
+
+#' @export
+#' @method .cstr_construct..CLASS1. .CONSTRUCTOR.
+.cstr_construct..CLASS1...CONSTRUCTOR. <- function(x, ...) {
+ # If needed, fetch additional options fed through opts_.CLASS1.()
+ # opts <- list(...)$opts$.CLASS1. %||% opts_.CLASS1.()
+
+ # Instead of the call below we need to fetch the args of the constructor in `x`.
+ args <- list()
+
+ # This creates a call .CONSTRUCTOR.(...) where ... is the constructed code
+ # of the arguments stored in `args`
+ # Sometimes we want to construct the code of the args separately, i.e. store
+ # code rather than objects in `args`, and use `recurse = FALSE` below
+ code <- .cstr_apply(args, fun = ".PKG::CONSTRUCTOR.", ...)
+
+ # .cstr_repair_attributes() makes sure that attributes that are not built
+ # by the idiomatic constructor are generated
+ .cstr_repair_attributes(
+ x, code, ...,
+ # attributes built by the constructor
+ # ignore =,
+
+ # not necessarily just a string, but the whole class(x) vector
+ idiomatic_class = .CLASS.
+ )
+}
diff --git a/sub/constructive.core/inst/new_class_template_commented_no_import.R b/sub/constructive.core/inst/new_class_template_commented_no_import.R
new file mode 100644
index 00000000..6d6b681e
--- /dev/null
+++ b/sub/constructive.core/inst/new_class_template_commented_no_import.R
@@ -0,0 +1,61 @@
+#' Constructive options for class '.CLASS1.'
+#'
+#' These options will be used on objects of class '.CLASS1.'.
+#'
+#' Depending on `constructor`, we construct the object as follows:
+#' * `".CONSTRUCTOR."` (default): We build the object using `.PKG::CONSTRUCTOR.()`.
+#' * `"next"` : Use the constructor for the next supported class.
+#'
+#' @param constructor String. Name of the function used to construct the object.
+#' @param ... Additional options used by user defined constructors through the `opts` object
+#' @return An object of class
+#' @export
+opts_.CLASS1. <- function(constructor = c(".CONSTRUCTOR.", "next"), ...) {
+ # What's forwarded through `...`will be accessible through the `opts`
+ # object in the methods.
+ # You might add arguments to the function, to document those options,
+ # don't forget to forward them below as well
+ constructive::.cstr_options(".CLASS1.", constructor = constructor[[1]], ...)
+}
+
+#' @exportS3Method constructive::.cstr_construct
+.cstr_construct..CLASS1. <- function(x, ...) {
+ # There is probably no need for you to modify this function at all
+ opts <- list(...)$opts$.CLASS1. %||% opts_.CLASS1.()
+ if (is_corrupted_.CLASS1.(x) || opts$constructor == "next") return(NextMethod())
+ # This odd looking code dispatches to a method based on the name of
+ # the constructor rather than the class
+ UseMethod(".cstr_construct..CLASS1.", structure(NA, class = opts$constructor))
+}
+
+is_corrupted_.CLASS1. <- function(x) {
+ # check here if the object has the right structure to be constructed
+ # leaving FALSE is fine but you'll be vulnerable to corrupted objects
+ FALSE
+}
+
+#' @export
+.cstr_construct..CLASS1...CONSTRUCTOR. <- function(x, ...) {
+ # If needed, fetch additional options fed through opts_.CLASS1.()
+ # opts <- list(...)$opts$.CLASS1. %||% opts_.CLASS1.()
+
+ # Instead of the call below we need to fetch the args of the constructor in `x`.
+ args <- list()
+
+ # This creates a call .CONSTRUCTOR.(...) where ... is the constructed code
+ # of the arguments stored in `args`
+ # Sometimes we want to construct the code of the args separately, i.e. store
+ # code rather than objects in `args`, and use `recurse = FALSE` below
+ code <- constructive::.cstr_apply(args, fun = ".PKG::CONSTRUCTOR.", ...)
+
+ # .cstr_repair_attributes() makes sure that attributes that are not built
+ # by the idiomatic constructor are generated
+ constructive::.cstr_repair_attributes(
+ x, code, ...,
+ # attributes built by the constructor
+ # ignore =,
+
+ # not necessarily just a string, but the whole class(x) vector
+ idiomatic_class = .CLASS.
+ )
+}
diff --git a/sub/constructive.core/inst/new_class_template_no_import.R b/sub/constructive.core/inst/new_class_template_no_import.R
new file mode 100644
index 00000000..c007a75b
--- /dev/null
+++ b/sub/constructive.core/inst/new_class_template_no_import.R
@@ -0,0 +1,37 @@
+#' Constructive options for class '.CLASS1.'
+#'
+#' These options will be used on objects of class '.CLASS1.'.
+#'
+#' Depending on `constructor`, we construct the object as follows:
+#' * `".CONSTRUCTOR."` (default): We build the object using `.PKG::CONSTRUCTOR.()`.
+#' * `"next"` : Use the constructor for the next supported class.
+#'
+#' @param constructor String. Name of the function used to construct the object.
+#' @param ... Additional options used by user defined constructors through the `opts` object
+#' @return An object of class
+#' @export
+opts_.CLASS1. <- function(constructor = c(".CONSTRUCTOR.", "next"), ...) {
+ constructive::.cstr_options(".CLASS1.", constructor = constructor[[1]], ...)
+}
+
+#' @exportS3Method constructive::.cstr_construct
+.cstr_construct..CLASS1. <- function(x, ...) {
+ opts <- list(...)$opts$.CLASS1. %||% opts_.CLASS1.()
+ if (is_corrupted_.CLASS1.(x) || opts$constructor == "next") return(NextMethod())
+ UseMethod(".cstr_construct..CLASS1.", structure(NA, class = opts$constructor))
+}
+
+is_corrupted_.CLASS1. <- function(x) {
+ FALSE
+}
+
+#' @export
+.cstr_construct..CLASS1...CONSTRUCTOR. <- function(x, ...) {
+ # opts <- list(...)$opts$.CLASS1. %||% opts_.CLASS1.()
+ args <- list()
+ code <- constructive::.cstr_apply(args, fun = ".PKG::CONSTRUCTOR.", ...)
+ constructive::.cstr_repair_attributes(
+ x, code, ...,
+ idiomatic_class = .CLASS.
+ )
+}
diff --git a/sub/constructive.core/inst/new_constructor_template.R b/sub/constructive.core/inst/new_constructor_template.R
new file mode 100644
index 00000000..980ea414
--- /dev/null
+++ b/sub/constructive.core/inst/new_constructor_template.R
@@ -0,0 +1,13 @@
+#' @importFrom constructive .cstr_construct .cstr_apply
+NULL
+
+#' @export
+.cstr_construct..CLASS1...CONSTRUCTOR. <- function(x, ...) {
+ # opts <- list(...)$opts$.CLASS1. %||% opts_.CLASS1.()
+ args <- list()
+ code <- .cstr_apply(args, fun = ".PKG::CONSTRUCTOR.", ...)
+ .cstr_repair_attributes(
+ x, code, ...,
+ idiomatic_class = .CLASS.
+ )
+}
diff --git a/sub/constructive.core/inst/new_constructor_template_commented.R b/sub/constructive.core/inst/new_constructor_template_commented.R
new file mode 100644
index 00000000..f9ab643c
--- /dev/null
+++ b/sub/constructive.core/inst/new_constructor_template_commented.R
@@ -0,0 +1,28 @@
+#' @importFrom constructive .cstr_construct .cstr_apply
+NULL
+
+#' @export
+.cstr_construct..CLASS1...CONSTRUCTOR. <- function(x, ...) {
+ # Uncomment if your constructor needs additional options from opts_.CLASS1.()
+ # opts <- list(...)$opts$.CLASS1. %||% opts_.CLASS1.()
+
+ # Instead of the call below we need to fetch the args of the constructor in `x`.
+ args <- list()
+
+ # This creates a call .CONSTRUCTOR.(...) where ... is the constructed code
+ # of the arguments stored in `args`
+ # Sometimes we want to construct the code of the args separately, i.e. store
+ # code rather than objects in `args`, and use `recurse = FALSE` below
+ code <- .cstr_apply(args, fun = ".PKG::CONSTRUCTOR.", ...)
+
+ # .cstr_repair_attributes() makes sure that attributes that are not built
+ # by the idiomatic constructor are generated
+ .cstr_repair_attributes(
+ x, code, ...,
+ # attributes built by the constructor
+ # ignore =,
+
+ # not necessarily just a string, but the whole class(x) vector
+ idiomatic_class = .CLASS.
+ )
+}
diff --git a/sub/constructive.core/inst/new_constructor_template_commented_no_import.R b/sub/constructive.core/inst/new_constructor_template_commented_no_import.R
new file mode 100644
index 00000000..73dd5a5e
--- /dev/null
+++ b/sub/constructive.core/inst/new_constructor_template_commented_no_import.R
@@ -0,0 +1,25 @@
+#' @exportS3Method constructive::.cstr_construct..CLASS1.
+.cstr_construct..CLASS1...CONSTRUCTOR. <- function(x, ...) {
+ # Uncomment if your constructor needs additional options from opts_.CLASS1.()
+ # opts <- list(...)$opts$.CLASS1. %||% opts_.CLASS1.()
+
+ # Instead of the call below we need to fetch the args of the constructor in `x`.
+ args <- list()
+
+ # This creates a call .CONSTRUCTOR.(...) where ... is the constructed code
+ # of the arguments stored in `args`
+ # Sometimes we want to construct the code of the args separately, i.e. store
+ # code rather than objects in `args`, and use `recurse = FALSE` below
+ code <- constructive::.cstr_apply(args, fun = ".PKG::CONSTRUCTOR.", ...)
+
+ # .cstr_repair_attributes() makes sure that attributes that are not built
+ # by the idiomatic constructor are generated
+ constructive::.cstr_repair_attributes(
+ x, code, ...,
+ # attributes built by the constructor
+ # ignore =,
+
+ # not necessarily just a string, but the whole class(x) vector
+ idiomatic_class = .CLASS.
+ )
+}
diff --git a/sub/constructive.core/inst/new_constructor_template_no_import.R b/sub/constructive.core/inst/new_constructor_template_no_import.R
new file mode 100644
index 00000000..67b5497f
--- /dev/null
+++ b/sub/constructive.core/inst/new_constructor_template_no_import.R
@@ -0,0 +1,10 @@
+#' @exportS3Method constructive::.cstr_construct..CLASS1.
+.cstr_construct..CLASS1...CONSTRUCTOR. <- function(x, ...) {
+ # opts <- list(...)$opts$.CLASS1. %||% opts_.CLASS1.()
+ args <- list()
+ code <- constructive::.cstr_apply(args, fun = ".PKG::CONSTRUCTOR.", ...)
+ constructive::.cstr_repair_attributes(
+ x, code, ...,
+ idiomatic_class = .CLASS.
+ )
+}
diff --git a/sub/constructive.core/src/constructive.cpp b/sub/constructive.core/src/constructive.cpp
new file mode 100644
index 00000000..98ebd481
--- /dev/null
+++ b/sub/constructive.core/src/constructive.cpp
@@ -0,0 +1,57 @@
+#include
+#include
+#include
+#include // for NULL, strtoull
+#include // for uintptr_t
+#include // for Rf_error
+#include
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/* .Call calls */
+SEXP external_pointer_address(SEXP);
+SEXP objectFromAddress(SEXP);
+
+static const R_CallMethodDef CallEntries[] = {
+ {"external_pointer_address", (DL_FUNC) &external_pointer_address, 1},
+ {"objectFromAddress", (DL_FUNC) &objectFromAddress, 1},
+ {NULL, NULL, 0}
+};
+
+void R_init_constructive_core(DllInfo *dll)
+{
+ R_registerRoutines(dll, NULL, CallEntries, NULL, NULL);
+ R_useDynamicSymbols(dll, FALSE);
+}
+
+#ifdef __cplusplus
+} /* extern "C" */
+#endif
+
+SEXP external_pointer_address(SEXP s) {
+ if (TYPEOF(s) != EXTPTRSXP) {
+ Rf_error("external_pointer_address() expects an input of type 'externalptr'");
+ }
+ char buf[32]; /* <-- fix: was char* buf[20] */
+ snprintf(buf, sizeof buf, "%p", R_ExternalPtrAddr(s));
+ return Rf_mkString(buf);
+}
+
+// Used by .env() to retrieve environments by address (session-local, unsafe across sessions)
+SEXP objectFromAddress(SEXP a) {
+ if (TYPEOF(a) != STRSXP || XLENGTH(a) != 1) {
+ Rf_error("'a' must be a length-1 character vector");
+ }
+ const char* s = CHAR(STRING_ELT(a, 0));
+ char* end = NULL;
+ unsigned long long u = strtoull(s, &end, 0); // base 0 handles 0x...
+ if (end == s || (end && *end != '\0')) {
+ Rf_error("'a' is not a formatted unsigned integer address");
+ }
+ uintptr_t p = (uintptr_t) u;
+ SEXP result = (SEXP) p;
+ if (TYPEOF(result) != ENVSXP) return R_NilValue;
+ return result;
+}
diff --git a/sub/constructive.core/tests/testthat.R b/sub/constructive.core/tests/testthat.R
new file mode 100644
index 00000000..20f78169
--- /dev/null
+++ b/sub/constructive.core/tests/testthat.R
@@ -0,0 +1,4 @@
+library(testthat)
+library(constructive.core)
+
+test_check("constructive.core")
diff --git a/sub/constructive.core/tests/testthat/_snaps/construct_diff.md b/sub/constructive.core/tests/testthat/_snaps/construct_diff.md
new file mode 100644
index 00000000..0bdb39e4
--- /dev/null
+++ b/sub/constructive.core/tests/testthat/_snaps/construct_diff.md
@@ -0,0 +1,74 @@
+# construct_diff
+
+ Code
+ construct_diff(list(a = head(cars, 2), b = "aaaaaaaaaaaaaaaaaaaa", c = "Foo"),
+ list(a = head(iris, 1), b = "aaaaaaaaaaaaaaaaaaaa", c = "foo"), interactive = FALSE)
+ Output
+ < list(a = head(cars, 2), b = "aaaaaa.. > list(a = head(iris, 1), b = "aaaaaa..
+ @@ 1,5 @@ @@ 1,11 @@
+ list( list(
+ < a = data.frame(speed = 4, dist = c( > a = data.frame(
+ : 2, 10)), ~
+ ~ > Sepal.Length = 5.1,
+ ~ > Sepal.Width = 3.5,
+ ~ > Petal.Length = 1.4,
+ ~ > Petal.Width = 0.2,
+ ~ > Species = factor("setosa", levels
+ ~ : = c("setosa", "versicolor", "virgini
+ ~ : ca"))
+ ~ > ),
+ b = "aaaaaaaaaaaaaaaaaaaa", b = "aaaaaaaaaaaaaaaaaaaa",
+ < c = "Foo" > c = "foo"
+ ) )
+ Code
+ construct_diff(list(a = head(cars, 2), b = "aaaaaaaaaaaaaaaaaaaa", c = "Foo"),
+ list(a = head(iris, 1), b = "aaaaaaaaaaaaaaaaaaaa", c = "foo"), interactive = FALSE)
+ Output
+ < list(a = head(cars, 2), b = "aaaaaa.. > list(a = head(iris, 1), b = "aaaaaa..
+ @@ 1,5 @@ @@ 1,11 @@
+ list( list(
+ < a = data.frame(speed = 4, dist = c( > a = data.frame(
+ : 2, 10)), ~
+ ~ > Sepal.Length = 5.1,
+ ~ > Sepal.Width = 3.5,
+ ~ > Petal.Length = 1.4,
+ ~ > Petal.Width = 0.2,
+ ~ > Species = factor("setosa", levels
+ ~ : = c("setosa", "versicolor", "virgini
+ ~ : ca"))
+ ~ > ),
+ b = "aaaaaaaaaaaaaaaaaaaa", b = "aaaaaaaaaaaaaaaaaaaa",
+ < c = "Foo" > c = "foo"
+ ) )
+ Code
+ construct_diff(list(a = head(cars, 2), b = "aaaaaaaaaaaaaaaaaaaa", c = "Foo"),
+ list(a = head(iris, 1), b = "aaaaaaaaaaaaaaaaaaaa", c = "foo"), opts_data.frame(
+ "read.table"), interactive = FALSE)
+ Output
+ < list(a = head(cars, 2), b = "aaaaaa.. > list(a = head(iris, 1), b = "aaaaaa..
+ @@ 1,9 @@ @@ 1,11 @@
+ list( list(
+ < a = read.table(header = TRUE, text > a = data.frame(
+ : = " ~
+ < speed dist > Sepal.Length = 5.1,
+ < 4. 2. > Sepal.Width = 3.5,
+ < 4. 10. > Petal.Length = 1.4,
+ < "), > Petal.Width = 0.2,
+ ~ > Species = factor("setosa", levels
+ ~ : = c("setosa", "versicolor", "virgini
+ ~ : ca"))
+ ~ > ),
+ b = "aaaaaaaaaaaaaaaaaaaa", b = "aaaaaaaaaaaaaaaaaaaa",
+ < c = "Foo" > c = "foo"
+ ) )
+ Code
+ construct_diff(1, 1)
+ Message
+ No difference to show!
+ Code
+ construct_diff("é", iconv("é", to = "latin1"), interactive = FALSE)
+ Output
+ < "é" > iconv("é", to = "latin1")
+ @@ 1 @@ @@ 1 @@
+ < "\U{E9}" > "\xe9" |> (`Encoding<-`)("latin1")
+
diff --git a/sub/constructive.core/tests/testthat/_snaps/construct_dput.md b/sub/constructive.core/tests/testthat/_snaps/construct_dput.md
new file mode 100644
index 00000000..aebf513a
--- /dev/null
+++ b/sub/constructive.core/tests/testthat/_snaps/construct_dput.md
@@ -0,0 +1,95 @@
+# `construct_dput()`, `construct_base()`, classes arg
+
+ Code
+ ts_ <- ts(1:10, frequency = 4, start = c(1959, 2))
+ construct_dput(ts_)
+ Output
+ 1:10 |>
+ structure(tsp = c(1959.25, 1961.5, 4), class = "ts")
+ Code
+ construct_base(ts_)
+ Output
+ ts(1:10, frequency = 4, start = 1959.25)
+ Code
+ construct(ts_, classes = "{base}")
+ Output
+ 1:10 |>
+ structure(tsp = c(1959.25, 1961.5, 4), class = "ts")
+ Code
+ iris2 <- head(iris, 2)
+ construct_dput(iris2)
+ Output
+ list(
+ Sepal.Length = c(5.1, 4.9),
+ Sepal.Width = c(3.5, 3),
+ Petal.Length = c(1.4, 1.4),
+ Petal.Width = c(0.2, 0.2),
+ Species = c(1L, 1L) |>
+ structure(levels = c("setosa", "versicolor", "virginica"), class = "factor")
+ ) |>
+ structure(row.names = c(NA, -2L), class = "data.frame")
+ Code
+ construct_base(iris2)
+ Output
+ data.frame(
+ Sepal.Length = c(5.1, 4.9),
+ Sepal.Width = c(3.5, 3),
+ Petal.Length = 1.4,
+ Petal.Width = 0.2,
+ Species = factor("setosa", levels = c("setosa", "versicolor", "virginica"))
+ )
+ Code
+ construct(iris2, classes = "{base}")
+ Output
+ data.frame(
+ Sepal.Length = c(5.1, 4.9),
+ Sepal.Width = c(3.5, 3),
+ Petal.Length = 1.4,
+ Petal.Width = 0.2,
+ Species = factor("setosa", levels = c("setosa", "versicolor", "virginica"))
+ )
+ Code
+ construct(iris2, classes = "-{base}")
+ Output
+ list(
+ Sepal.Length = c(5.1, 4.9),
+ Sepal.Width = c(3.5, 3),
+ Petal.Length = c(1.4, 1.4),
+ Petal.Width = c(0.2, 0.2),
+ Species = c(1L, 1L) |>
+ structure(levels = c("setosa", "versicolor", "virginica"), class = "factor")
+ ) |>
+ structure(row.names = c(NA, -2L), class = "data.frame")
+ Code
+ construct(iris2, classes = "factor")
+ Output
+ list(
+ Sepal.Length = c(5.1, 4.9),
+ Sepal.Width = c(3.5, 3),
+ Petal.Length = c(1.4, 1.4),
+ Petal.Width = c(0.2, 0.2),
+ Species = factor(c("setosa", "setosa"), levels = c("setosa", "versicolor", "virginica"))
+ ) |>
+ structure(row.names = c(NA, -2L), class = "data.frame")
+ Code
+ construct(iris2, classes = "-factor")
+ Output
+ data.frame(
+ Sepal.Length = c(5.1, 4.9),
+ Sepal.Width = c(3.5, 3),
+ Petal.Length = 1.4,
+ Petal.Width = 0.2,
+ Species = 1L |>
+ structure(levels = c("setosa", "versicolor", "virginica"), class = "factor")
+ )
+ Code
+ construct_dput(dplyr::band_members)
+ Output
+ list(name = c("Mick", "John", "Paul"), band = c("Stones", "Beatles", "Beatles")) |>
+ structure(class = c("tbl_df", "tbl", "data.frame"), row.names = c(NA, -3L))
+ Code
+ construct_base(dplyr::band_members)
+ Output
+ data.frame(name = c("Mick", "John", "Paul"), band = c("Stones", "Beatles", "Beatles")) |>
+ structure(class = c("tbl_df", "tbl", "data.frame"))
+
diff --git a/sub/constructive.core/tests/testthat/_snaps/construct_multi.md b/sub/constructive.core/tests/testthat/_snaps/construct_multi.md
new file mode 100644
index 00000000..6e22587d
--- /dev/null
+++ b/sub/constructive.core/tests/testthat/_snaps/construct_multi.md
@@ -0,0 +1,94 @@
+# construct_multi
+
+ Code
+ construct_multi(list(a = letters, b = .leap.seconds))
+ Output
+ a <- c(
+ "a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o",
+ "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z"
+ )
+
+ b <- as.POSIXct(
+ c(
+ "1972-07-01", "1973-01-01", "1974-01-01", "1975-01-01", "1976-01-01",
+ "1977-01-01", "1978-01-01", "1979-01-01", "1980-01-01", "1981-07-01",
+ "1982-07-01", "1983-07-01", "1985-07-01", "1988-01-01", "1990-01-01",
+ "1991-01-01", "1992-07-01", "1993-07-01", "1994-07-01", "1996-01-01",
+ "1997-07-01", "1999-01-01", "2006-01-01", "2009-01-01", "2012-07-01",
+ "2015-07-01", "2017-01-01"
+ ),
+ tz = "GMT"
+ )
+
+
+---
+
+ Code
+ construct_multi(new_environment(list(a = letters, b = .leap.seconds)))
+ Output
+ b <- as.POSIXct(
+ c(
+ "1972-07-01", "1973-01-01", "1974-01-01", "1975-01-01", "1976-01-01",
+ "1977-01-01", "1978-01-01", "1979-01-01", "1980-01-01", "1981-07-01",
+ "1982-07-01", "1983-07-01", "1985-07-01", "1988-01-01", "1990-01-01",
+ "1991-01-01", "1992-07-01", "1993-07-01", "1994-07-01", "1996-01-01",
+ "1997-07-01", "1999-01-01", "2006-01-01", "2009-01-01", "2012-07-01",
+ "2015-07-01", "2017-01-01"
+ ),
+ tz = "GMT"
+ )
+
+ a <- c(
+ "a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o",
+ "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z"
+ )
+
+
+---
+
+ Code
+ construct_multi(new_environment(list(a = letters, b = .leap.seconds)),
+ include_dotted = FALSE)
+ Output
+ b <- as.POSIXct(
+ c(
+ "1972-07-01", "1973-01-01", "1974-01-01", "1975-01-01", "1976-01-01",
+ "1977-01-01", "1978-01-01", "1979-01-01", "1980-01-01", "1981-07-01",
+ "1982-07-01", "1983-07-01", "1985-07-01", "1988-01-01", "1990-01-01",
+ "1991-01-01", "1992-07-01", "1993-07-01", "1994-07-01", "1996-01-01",
+ "1997-07-01", "1999-01-01", "2006-01-01", "2009-01-01", "2012-07-01",
+ "2015-07-01", "2017-01-01"
+ ),
+ tz = "GMT"
+ )
+
+ a <- c(
+ "a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o",
+ "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z"
+ )
+
+
+---
+
+ Code
+ a <- 1
+ foo <- (function(x, y) {
+ force(x)
+ "а" <- 2
+ construct_multi(environment())
+ })
+ foo(a, a)
+ Output
+ delayedAssign(
+ "y",
+ value = a,
+ eval.env = constructive::.env(
+ "0x123456789",
+ parents = c("0x123456789", "0x123456789", "namespace:constructive")
+ )
+ )
+ x <- 1
+
+ "\U{430}" <- 2
+
+
diff --git a/sub/constructive.core/tests/testthat/_snaps/construct_signature.md b/sub/constructive.core/tests/testthat/_snaps/construct_signature.md
new file mode 100644
index 00000000..7ca2e7dd
--- /dev/null
+++ b/sub/constructive.core/tests/testthat/_snaps/construct_signature.md
@@ -0,0 +1,11 @@
+# construct_signature
+
+ Code
+ construct_signature(transform)
+ Output
+ transform(`_data`, ...)
+ Code
+ construct_signature(lm)
+ Output
+ lm(formula, data, subset, weights, na.action, method = "qr", model = TRUE, x = FALSE, y = FALSE, qr = TRUE, singular.ok = TRUE, contrasts = NULL, offset, ...)
+
diff --git a/sub/constructive.core/tests/testthat/_snaps/deparse_call.md b/sub/constructive.core/tests/testthat/_snaps/deparse_call.md
new file mode 100644
index 00000000..0c274967
--- /dev/null
+++ b/sub/constructive.core/tests/testthat/_snaps/deparse_call.md
@@ -0,0 +1,580 @@
+# deparse_call()
+
+ Code
+ deparse_call(call("::", 1, 2), style = FALSE)
+ Output
+ [1] "`::`(1, 2)"
+ Code
+ deparse_call(call("::", "a", quote(b)), style = FALSE)
+ Output
+ [1] "\"a\"::b"
+ Code
+ deparse_call(call("::", quote(a), "b"), style = FALSE)
+ Output
+ [1] "a::\"b\""
+ Code
+ deparse_call(call(":::", 1, 2), style = FALSE)
+ Output
+ [1] "`:::`(1, 2)"
+ Code
+ deparse_call(call(":::", "a", quote(b)), style = FALSE)
+ Output
+ [1] "\"a\":::b"
+ Code
+ deparse_call(call(":::", quote(a), "b"), style = FALSE)
+ Output
+ [1] "a:::\"b\""
+ Code
+ deparse_call(call("+", 1, 2, 3), style = FALSE)
+ Output
+ [1] "`+`(1, 2, 3)"
+ Code
+ deparse_call(call("+", 1, 2), style = FALSE)
+ Output
+ [1] "1 + 2"
+ Code
+ deparse_call(call("+", 1), style = FALSE)
+ Output
+ [1] "+1"
+ Code
+ deparse_call(call("+"), style = FALSE)
+ Output
+ [1] "`+`()"
+ Code
+ deparse_call(call("$", "a", "b", "c"), style = FALSE)
+ Output
+ [1] "`$`(\"a\", \"b\", \"c\")"
+ Code
+ deparse_call(call("$", "a", "b"), style = FALSE)
+ Output
+ [1] "\"a\"$\"b\""
+ Code
+ deparse_call(call("$", quote(a), "b"), style = FALSE)
+ Output
+ [1] "a$\"b\""
+ Code
+ deparse_call(call("$", quote(a), quote(b)), style = FALSE)
+ Output
+ [1] "a$b"
+ Code
+ deparse_call(call("$", "a", 1), style = FALSE)
+ Output
+ [1] "`$`(\"a\", 1)"
+ Code
+ deparse_call(call("$", 1, "b"), style = FALSE)
+ Output
+ [1] "1$\"b\""
+ Code
+ deparse_call(call("$"), style = FALSE)
+ Output
+ [1] "`$`()"
+ Code
+ deparse_call(call("$"), style = FALSE)
+ Output
+ [1] "`$`()"
+ Code
+ deparse_call(call(":", 1, 2, 3), style = FALSE)
+ Output
+ [1] "`:`(1, 2, 3)"
+ Code
+ deparse_call(call(":", 1, 2), style = FALSE)
+ Output
+ [1] "1:2"
+ Code
+ deparse_call(call(":", 1), style = FALSE)
+ Output
+ [1] "`:`(1)"
+ Code
+ deparse_call(call(":"), style = FALSE)
+ Output
+ [1] "`:`()"
+ Code
+ deparse_call(call("(", 1, 2), style = FALSE)
+ Output
+ [1] "`(`(1, 2)"
+ Code
+ deparse_call(call("(", 1), style = FALSE)
+ Output
+ [1] "(1)"
+ Code
+ deparse_call(call("("), style = FALSE)
+ Output
+ [1] "`(`()"
+ Code
+ deparse_call(call("non-syntactic", 1), style = FALSE)
+ Output
+ [1] "`non-syntactic`(1)"
+ Code
+ deparse_call(quote(foo(bar(baz(x), 1), arg = 2, empty = )), style = FALSE)
+ Output
+ [1] "foo(bar(baz(x), 1), arg = 2, empty = )"
+ Code
+ deparse_call(quote(foo(bar(baz(x), 1), arg = 2, empty = )), pipe = TRUE, style = FALSE)
+ Output
+ [1] "x |> baz() |> bar(1) |> foo(arg = 2, empty = )"
+ Code
+ deparse_call(quote(foo(a = 1, 2)), pipe = TRUE, style = FALSE)
+ Output
+ [1] "foo(a = 1, 2)"
+ Code
+ deparse_call(quote(function(x, y = 1, z = a) {
+ x + y
+ }), style = FALSE)
+ Output
+ [1] "function(x, y = 1, z = a) {\n x + y\n}"
+ Code
+ deparse_call(quote(function(x, y = 1, z = a) {
+ x + y
+ }), one_liner = TRUE, style = FALSE)
+ Output
+ [1] "function(x, y = 1, z = a) {x + y}"
+ Code
+ deparse_call(quote(if (cond) this else that), style = FALSE)
+ Output
+ [1] "if (cond) this else that"
+ Code
+ deparse_call(quote(if (cond) {
+ this
+ } else {
+ that
+ }), style = FALSE)
+ Output
+ [1] "if (cond) {\n this\n} else {\n that\n}"
+ Code
+ deparse_call(quote(while (cond) this), style = FALSE)
+ Output
+ [1] "while (cond) this"
+ Code
+ deparse_call(quote(while (cond) {
+ this
+ }), style = FALSE)
+ Output
+ [1] "while (cond) {\n this\n}"
+ Code
+ deparse_call(quote(for (i in this) that), style = FALSE)
+ Output
+ [1] "for (i in this) that"
+ Code
+ deparse_call(quote(for (i in this) {
+ that
+ }), style = FALSE)
+ Output
+ [1] "for (i in this) {\n that\n}"
+ Code
+ deparse_call(quote(repeat this), style = FALSE)
+ Output
+ [1] "repeat this"
+ Code
+ deparse_call(quote(repeat {
+ this
+ }), style = FALSE)
+ Output
+ [1] "repeat {\n this\n}"
+ Code
+ deparse_call(quote(`*a*`))
+ Output
+ `*a*`
+ Code
+ deparse_call(quote(a(b = 1, c)))
+ Output
+ a(b = 1, c)
+ Code
+ deparse_call(quote(a[b = 1, c]))
+ Output
+ a[b = 1, c]
+ Code
+ deparse_call(quote(a[[b = 1, c]]))
+ Output
+ a[[b = 1, c]]
+ Code
+ deparse_call(quote(a(
+ bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb = 1,
+ c)))
+ Output
+ a(
+ bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb = 1,
+ c
+ )
+ Code
+ deparse_call(quote(a[
+ bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb = 1,
+ c]))
+ Output
+ a[
+ bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb = 1,
+ c
+ ]
+ Code
+ deparse_call(quote(a[[
+ bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb = 1,
+ c]]))
+ Output
+ a[[
+ bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb = 1,
+ c
+ ]]
+ Code
+ deparse_call(quote(a(b(
+ c12345678901234567890123456789012345678901234567890123456789012345678901234567890))))
+ Output
+ a(
+ b(
+ c12345678901234567890123456789012345678901234567890123456789012345678901234567890
+ )
+ )
+ Code
+ deparse_call(quote(a({
+ c12345678901234567890123456789012345678901234567890123456789012345678901234567890
+ }, b)))
+ Output
+ a(
+ {
+ c12345678901234567890123456789012345678901234567890123456789012345678901234567890
+ },
+ b
+ )
+ Code
+ deparse_call(quote(function(`_x`) `_x`))
+ Output
+ function(`_x`) `_x`
+ Code
+ deparse_call(quote(list(`a + b` = a + b)))
+ Output
+ list(`a + b` = a + b)
+ Code
+ deparse_call(quote((`boo<-`)(x)))
+ Output
+ (`boo<-`)(x)
+ Code
+ deparse_call(quote(`boo<-`[[1]](x)))
+ Output
+ `boo<-`[[1]](x)
+
+---
+
+ Code
+ deparse_call(eval(str2lang("quote(`=`(x, 1))")))
+ Output
+ x = 1
+ Code
+ deparse_call(eval(str2lang("quote(list(`=`(x, 1)))")))
+ Output
+ list(`=`(x, 1))
+ Code
+ deparse_call(eval(str2lang("quote((`=`(x, 1)))")))
+ Output
+ (x = 1)
+ Code
+ deparse_call(quote(list(x = 1)))
+ Output
+ list(x = 1)
+ Code
+ deparse_call(quote({
+ x = 1
+ }))
+ Output
+ {
+ x = 1
+ }
+
+---
+
+ Code
+ deparse_call(quote({{ x }}), style = FALSE)
+ Output
+ [1] "{{ x }}"
+ Code
+ deparse_call(quote({
+ {
+ 1
+ }
+ }), style = FALSE)
+ Output
+ [1] "{\n {\n 1\n }\n}"
+ Code
+ deparse_call(quote({
+ {
+ 1
+ }
+ }), one_liner = TRUE, style = FALSE)
+ Output
+ [1] "{{1}}"
+ Code
+ deparse_call("\"")
+ Output
+ '"'
+ Code
+ deparse_call("\"", escape = TRUE)
+ Output
+ "\""
+ Code
+ deparse_call("ü")
+ Output
+ "\U{FC}"
+ Code
+ deparse_call("ü", unicode_representation = "latin")
+ Output
+ "ü"
+
+---
+
+ Code
+ deparse_call(quote((x <- 1) <- 2))
+ Output
+ (x <- 1) <- 2
+ Code
+ deparse_call(quote(if (TRUE) 1 <- 1))
+ Output
+ if (TRUE) 1 <- 1
+ Code
+ deparse_call(quote(for (i in j) 1 <- 1))
+ Output
+ for (i in j) 1 <- 1
+ Code
+ deparse_call(quote(while (TRUE) 1 <- 1))
+ Output
+ while (TRUE) 1 <- 1
+ Code
+ deparse_call(quote(repeat 1 <- 1))
+ Output
+ repeat 1 <- 1
+
+# deparse_call() for R >= 4.1
+
+ Code
+ deparse_call(quote(`🐶`), style = FALSE)
+ Output
+ [1] "`\\xf0\\x9f\\x90\\xb6`"
+ Code
+ deparse_call(quote(`🐶`), unicode_representation = "unicode")
+ Output
+ `🐶`
+
+# square brackets
+
+ Code
+ deparse_call(call("[", 1, 2, 3), style = FALSE)
+ Output
+ [1] "1[2, 3]"
+ Code
+ deparse_call(call("[", 1, 2), style = FALSE)
+ Output
+ [1] "1[2]"
+ Code
+ deparse_call(call("[", 1), style = FALSE)
+ Output
+ [1] "`[`(1)"
+ Code
+ deparse_call(call("["), style = FALSE)
+ Output
+ [1] "`[`()"
+ Code
+ deparse_call(call("[[", 1, 2, 3), style = FALSE)
+ Output
+ [1] "1[[2, 3]]"
+ Code
+ deparse_call(call("[[", 1, 2), style = FALSE)
+ Output
+ [1] "1[[2]]"
+ Code
+ deparse_call(call("[[", 1), style = FALSE)
+ Output
+ [1] "`[[`(1)"
+ Code
+ deparse_call(call("[["), style = FALSE)
+ Output
+ [1] "`[[`()"
+ Code
+ deparse_call(call("[", quote(expr = ), quote(expr = )), style = FALSE)
+ Output
+ [1] "`[`(, )"
+ Code
+ deparse_call(call("[", 1, quote(expr = )), style = FALSE)
+ Output
+ [1] "1[]"
+ Code
+ deparse_call(call("[", quote(a + b), 1), style = FALSE)
+ Output
+ [1] "`[`(a + b, 1)"
+ Code
+ deparse_call(quote(a$b[[c]]))
+ Output
+ a$b[[c]]
+ Code
+ deparse_call(quote(a[[b]]$c))
+ Output
+ a[[b]]$c
+ Code
+ deparse_call(quote(a[[b$c]]))
+ Output
+ a[[b$c]]
+ Code
+ deparse_call(call("[", quote(while (TRUE) { }), 1), style = FALSE)
+ Output
+ [1] "`[`(while (TRUE) { }, 1)"
+ Code
+ deparse_call(call("[", quote(if (TRUE) { }), 1), style = FALSE)
+ Output
+ [1] "`[`(if (TRUE) { }, 1)"
+ Code
+ deparse_call(call("[", quote(for (a in b) { }), 1), style = FALSE)
+ Output
+ [1] "`[`(for (a in b) { }, 1)"
+ Code
+ deparse_call(call("[", quote(repeat { }), 1), style = FALSE)
+ Output
+ [1] "`[`(repeat { }, 1)"
+ Code
+ deparse_call(call("[", quote(function() { }), 1), style = FALSE)
+ Output
+ [1] "`[`(function() { }, 1)"
+ Code
+ deparse_call(call("[", call("function", 1, 2), 1), style = FALSE)
+ Output
+ [1] "`[`(`function`(1, 2), 1)"
+
+# curly braces
+
+ Code
+ deparse_call(call("{"), style = FALSE)
+ Output
+ [1] "{ }"
+ Code
+ deparse_call(call("{", 1, 2), style = FALSE)
+ Output
+ [1] "{\n 1\n 2\n}"
+ Code
+ deparse_call(call("{", 1, 2), one_liner = TRUE, style = FALSE)
+ Output
+ [1] "{1; 2}"
+ Code
+ deparse_call(call("{", 1, quote(expr = )), style = FALSE)
+ Output
+ [1] "`{`(1, )"
+
+# Use lisp notation when the caller expr calls a control flow construct
+
+ Code
+ deparse_call(substitute(X(Y), list(X = quote(if (TRUE) { }), Y = 1)))
+ Output
+ `if`(TRUE, { })(1)
+ Code
+ deparse_call(substitute(X(Y), list(X = quote(while (TRUE) { }), Y = 1)))
+ Output
+ `while`(TRUE, { })(1)
+ Code
+ deparse_call(substitute(X(Y), list(X = quote(for (a in b) { }), Y = 1)))
+ Output
+ `for`(a, b, { })(1)
+ Code
+ deparse_call(substitute(X(Y), list(X = quote(repeat { }), Y = 1)))
+ Output
+ `repeat`({ })(1)
+
+# Operator precedence is well handled
+
+ Code
+ deparse_call(str2lang("`^`(`+`(a, b), c)"))
+ Output
+ `^`(a + b, c)
+ Code
+ deparse_call(str2lang("`+`(`^`(a, b), c)"))
+ Output
+ a^b + c
+ Code
+ deparse_call(str2lang("`%in%`(`*`(a, b), c)"))
+ Output
+ `%in%`(a * b, c)
+ Code
+ deparse_call(str2lang("`*`(`%in%`(a, b), c)"))
+ Output
+ a %in% b * c
+ Code
+ deparse_call(str2lang("`+`(`+`(1, 2), 4)"))
+ Output
+ 1 + 2 + 4
+ Code
+ deparse_call(str2lang("`-`(1+2)"))
+ Output
+ `-`(1 + 2)
+ Code
+ deparse_call(str2lang("`<-`(`<<-`(1, 2), 4)"))
+ Output
+ `<-`(1 <<- 2, 4)
+ Code
+ deparse_call(str2lang("`+`(x, y)(z)"))
+ Output
+ `+`(x, y)(z)
+ Code
+ deparse_call(quote(x <- a::b(y)))
+ Output
+ x <- a::b(y)
+ Code
+ deparse_call(quote(x <- a:::b(y)))
+ Output
+ x <- a:::b(y)
+ Code
+ deparse_call(quote(x <- a$b(y)))
+ Output
+ x <- a$b(y)
+ Code
+ deparse_call(quote(x <- a@b(y)))
+ Output
+ x <- a@b(y)
+ Code
+ deparse_call(quote(x <- a::b$c(y)))
+ Output
+ x <- a::b$c(y)
+ Code
+ deparse_call(str2lang("`^`(`^`(1, 2), 4)"))
+ Output
+ `^`(1^2, 4)
+ Code
+ deparse_call(str2lang("`^`(4, `^`(1, 2))"))
+ Output
+ 4^1^2
+ Code
+ deparse_call(str2lang("`+`(4, `+`(1, 2))"))
+ Output
+ `+`(4, 1 + 2)
+ Code
+ deparse_call(substitute(X + Y, list(X = quote(repeat { }), Y = 1)))
+ Output
+ `+`(repeat { }, 1)
+ Code
+ deparse_call(substitute(X + Y, list(X = 1, Y = quote(repeat { }))))
+ Output
+ 1 + repeat { }
+ Code
+ deparse_call(substitute(X ? Y, list(X = quote(repeat { }), Y = 1)))
+ Output
+ repeat { } ? 1
+ Code
+ deparse_call(substitute(X ? Y, list(X = 1, Y = quote(repeat { }))))
+ Output
+ 1 ? repeat { }
+ Code
+ deparse_call(substitute(X$Y, list(X = quote(repeat { }), Y = 1)))
+ Output
+ `$`(repeat { }, 1)
+ Code
+ deparse_call(substitute(X$Y, list(X = 1, Y = quote(repeat { }))))
+ Output
+ `$`(1, repeat { })
+ Code
+ deparse_call(substitute(X(Y), list(X = quote(repeat { }), Y = 1)))
+ Output
+ `repeat`({ })(1)
+ Code
+ deparse_call(substitute(X[Y], list(X = quote(repeat { }), Y = 1)))
+ Output
+ `[`(repeat { }, 1)
+ Code
+ deparse_call(quote(+repeat { }))
+ Output
+ +repeat { }
+ Code
+ deparse_call(quote(+repeat { }))
+ Output
+ +repeat { }
+
diff --git a/sub/constructive.core/tests/testthat/_snaps/opts.md b/sub/constructive.core/tests/testthat/_snaps/opts.md
new file mode 100644
index 00000000..ea405b24
--- /dev/null
+++ b/sub/constructive.core/tests/testthat/_snaps/opts.md
@@ -0,0 +1,9 @@
+# opts
+
+ Code
+ opts_formula()
+ Output
+
+ constructor: "default"
+ environment: TRUE
+
diff --git a/sub/constructive.core/tests/testthat/_snaps/s3-array.md b/sub/constructive.core/tests/testthat/_snaps/s3-array.md
new file mode 100644
index 00000000..5d89d135
--- /dev/null
+++ b/sub/constructive.core/tests/testthat/_snaps/s3-array.md
@@ -0,0 +1,37 @@
+# array
+
+ Code
+ construct(as.array(month.abb))
+ Output
+ array(
+ c("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"),
+ dim = 12L
+ )
+ Code
+ construct(as.array(month.abb), opts_array("next"))
+ Output
+ c("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec") |>
+ structure(dim = 12L)
+ Code
+ construct(array(1:3, c(2, 4)))
+ Output
+ matrix(c(1L, 2L, 3L, 1L, 2L, 3L, 1L, 2L), nrow = 2L, ncol = 4L)
+ Code
+ construct(structure(1, class = "array"))
+ Output
+ 1 |>
+ structure(class = "array")
+ Code
+ construct(structure(1, class = "array", dim = 1))
+ Output
+ array(1, dim = 1L) |>
+ structure(class = "array")
+
+# classed array
+
+ Code
+ construct(structure(array(1:27, c(3, 3, 3)), class = "a"))
+ Output
+ array(1:27, dim = rep(3L, 3L)) |>
+ structure(class = "a")
+
diff --git a/sub/constructive.core/tests/testthat/setup.R b/sub/constructive.core/tests/testthat/setup.R
new file mode 100644
index 00000000..e0671dc2
--- /dev/null
+++ b/sub/constructive.core/tests/testthat/setup.R
@@ -0,0 +1,32 @@
+colon_colon <- `::`
+
+`::` <- function(x, y) {
+ x_sym <- substitute(x)
+ y_sym <- substitute(y)
+ tryCatch(
+ inject(colon_colon(!!x_sym, !!y_sym)),
+ packageNotFoundError = function(e) {
+ skip_if_not_installed(as_string(x_sym))
+ }
+ )
+}
+
+# we want regular behavior of internal generics in the tests
+`[` <- base::`[`
+`$` <- base::`$`
+length <- base::length
+
+expect_snapshot <- function(code) {
+ eval.parent(substitute(
+ testthat::expect_snapshot(
+ code,
+ transform = function(out) {
+ out <- gsub("%>%", "|>", out, fixed = TRUE)
+ out <- gsub("= [.]([,)])", "= _\\1", out)
+ out
+ }
+ )
+ ))
+}
+# have a copy in the global env for some examples in CI
+.GlobalEnv$expect_snapshot <- expect_snapshot
diff --git a/sub/constructive.core/tests/testthat/test-abort.R b/sub/constructive.core/tests/testthat/test-abort.R
new file mode 100644
index 00000000..4c101ac7
--- /dev/null
+++ b/sub/constructive.core/tests/testthat/test-abort.R
@@ -0,0 +1,32 @@
+test_that("abort", {
+ expect_snapshot({
+ foo <- function(x = c("a", "b"), y, z, ...) {
+ .cstr_combine_errors(
+ x <- rlang::arg_match(x),
+ abort_not_boolean(y),
+ abort_not_null_or_integerish(z),
+ rlang::check_dots_empty()
+ )
+ }
+ err <- try(foo("z","z","z","z"), silent = TRUE)
+ cat(attr(err, "condition")$message)
+ fun <- function(x) x
+ try(abort_not_string(fun))
+ try(abort_not_env_or_named_list(letters))
+ try(abort_not_env_or_named_list(list(1,2)))
+ try(abort_wrong_data(letters))
+ try(abort_wrong_data(list(letters)))
+ try(abort_wrong_data("unknown"))
+ try(abort_wrong_data(list("unknown")))
+ try(abort_wrong_data(fun))
+ try(abort_wrong_data(list(fun)))
+ })
+})
+
+test_that("describe", {
+ expect_snapshot({
+ fun <- function(x) x
+ writeLines(describe(letters))
+ writeLines(describe(fun))
+ })
+})
diff --git a/sub/constructive.core/tests/testthat/test-construct-helpers.R b/sub/constructive.core/tests/testthat/test-construct-helpers.R
new file mode 100644
index 00000000..b65aca7c
--- /dev/null
+++ b/sub/constructive.core/tests/testthat/test-construct-helpers.R
@@ -0,0 +1,9 @@
+test_that("all_classes contains all classes", {
+ # infer all implemented classes from object names
+ all_methods <- ls(asNamespace("constructive"), pattern = "^[.]cstr_construct[.]", all.names = TRUE)
+ high_level_methods <- all_methods[sapply(all_methods, function(x) sum(startsWith(all_methods, paste0(x, "."))) > 1)]
+ implemented_classes <- sub("^[.]cstr_construct[.]", "", high_level_methods)
+ to_add_to_all_classes <- setdiff(implemented_classes, unlist(all_classes))
+ expect_length(to_add_to_all_classes, 0)
+})
+
diff --git a/sub/constructive.core/tests/testthat/test-construct_diff.R b/sub/constructive.core/tests/testthat/test-construct_diff.R
new file mode 100644
index 00000000..3a66fa82
--- /dev/null
+++ b/sub/constructive.core/tests/testthat/test-construct_diff.R
@@ -0,0 +1,30 @@
+test_that("construct_diff", {
+ # stangely we have a different indentation for ubuntu with R 4.1 (one more space)
+ # it's hard to solve and doesn't seem that important so we just skip the test
+ # for this situation
+ if (with_versions(R < "4.2.0")) skip_on_os("linux")
+
+ expect_snapshot({
+ construct_diff(
+ list(a = head(cars,2), b = "aaaaaaaaaaaaaaaaaaaa", c = "Foo"),
+ list(a = head(iris,1), b = "aaaaaaaaaaaaaaaaaaaa", c = "foo"),
+ interactive = FALSE
+ )
+
+ construct_diff(
+ list(a = head(cars,2), b = "aaaaaaaaaaaaaaaaaaaa", c = "Foo"),
+ list(a = head(iris,1), b = "aaaaaaaaaaaaaaaaaaaa", c = "foo"),
+ interactive = FALSE
+ )
+
+ construct_diff(
+ list(a = head(cars,2), b = "aaaaaaaaaaaaaaaaaaaa", c = "Foo"),
+ list(a = head(iris,1), b = "aaaaaaaaaaaaaaaaaaaa", c = "foo"),
+ opts_data.frame("read.table"),
+ interactive = FALSE
+ )
+
+ construct_diff(1,1)
+ construct_diff("é", iconv("é", to = "latin1"), interactive = FALSE)
+ })
+})
diff --git a/sub/constructive.core/tests/testthat/test-construct_dput.R b/sub/constructive.core/tests/testthat/test-construct_dput.R
new file mode 100644
index 00000000..a772ccca
--- /dev/null
+++ b/sub/constructive.core/tests/testthat/test-construct_dput.R
@@ -0,0 +1,19 @@
+test_that("`construct_dput()`, `construct_base()`, classes arg", {
+ expect_snapshot({
+ ts_ <- ts(1:10, frequency = 4, start = c(1959, 2))
+ construct_dput(ts_)
+ construct_base(ts_)
+ construct(ts_, classes = "{base}")
+
+ iris2 <- head(iris, 2)
+ construct_dput(iris2)
+ construct_base(iris2)
+ construct(iris2, classes = "{base}")
+ construct(iris2, classes = "-{base}")
+ construct(iris2, classes = "factor")
+ construct(iris2, classes = "-factor")
+
+ construct_dput(dplyr::band_members)
+ construct_base(dplyr::band_members)
+ })
+})
diff --git a/sub/constructive.core/tests/testthat/test-construct_dump.R b/sub/constructive.core/tests/testthat/test-construct_dump.R
new file mode 100644
index 00000000..b1f2d282
--- /dev/null
+++ b/sub/constructive.core/tests/testthat/test-construct_dump.R
@@ -0,0 +1,7 @@
+test_that("construct_dump", {
+ tmp <- tempfile(fileext = ".R")
+ construct_dump(list(cars = cars), path = tmp)
+ e <- new.env()
+ source(tmp, local = e)
+ expect_equal(e$cars, cars)
+})
diff --git a/sub/constructive.core/tests/testthat/test-construct_multi.R b/sub/constructive.core/tests/testthat/test-construct_multi.R
new file mode 100644
index 00000000..8de87c82
--- /dev/null
+++ b/sub/constructive.core/tests/testthat/test-construct_multi.R
@@ -0,0 +1,48 @@
+test_that("construct_multi", {
+ # For stability
+ .leap.seconds <- as.POSIXct(
+ c(
+ "1972-07-01", "1973-01-01", "1974-01-01", "1975-01-01", "1976-01-01",
+ "1977-01-01", "1978-01-01", "1979-01-01", "1980-01-01", "1981-07-01",
+ "1982-07-01", "1983-07-01", "1985-07-01", "1988-01-01", "1990-01-01",
+ "1991-01-01", "1992-07-01", "1993-07-01", "1994-07-01", "1996-01-01",
+ "1997-07-01", "1999-01-01", "2006-01-01", "2009-01-01", "2012-07-01",
+ "2015-07-01", "2017-01-01"
+ ),
+ tz = "GMT"
+ )
+
+ expect_snapshot(
+ construct_multi(list(a = letters, b = .leap.seconds))
+ )
+ expect_snapshot(
+ construct_multi(new_environment(list(a = letters, b = .leap.seconds)))
+ )
+
+ expect_snapshot(
+ construct_multi(
+ new_environment(list(a = letters, b = .leap.seconds)),
+ include_dotted = FALSE
+ )
+ )
+
+ expect_error(
+ construct_multi(list(letters, .leap.seconds)),
+ "named"
+ )
+ expect_error(
+ construct_multi(letters),
+ "named"
+ )
+
+ expect_snapshot({
+ a <- 1
+ foo <- function(x, y) {
+ force(x)
+ "\U{430}" <- 2 # cyrillic "a"
+ construct_multi(environment())
+ }
+
+ foo(a, a)
+ })
+})
diff --git a/sub/constructive.core/tests/testthat/test-construct_reprex.R b/sub/constructive.core/tests/testthat/test-construct_reprex.R
new file mode 100644
index 00000000..57ec314d
--- /dev/null
+++ b/sub/constructive.core/tests/testthat/test-construct_reprex.R
@@ -0,0 +1,43 @@
+test_that("construct_reprex", {
+ fun <- function() {
+ hello <- 0
+ outer(100, hello + world)
+ }
+
+ outer <- function(a, b) {
+ a <- a + 1
+ c <- 3
+ inner1(a, c)
+ inner2(a, c)
+ inner3(a, c)
+ }
+
+ inner1 <- function(x, y) {
+ writeLines("# 1 ------------------------------------------------------\n")
+ x <- x + 1
+ z <- 3
+ reprex <- construct_reprex()
+ print(reprex)
+ }
+
+ inner2 <- function(x, y) {
+ writeLines("\n# 2 ------------------------------------------------------\n")
+ x <- x + 1
+ z <- 3
+ reprex <- construct_reprex(1)
+ print(reprex)
+ }
+
+ inner3 <- function(x, y) {
+ writeLines("\n# 3 ------------------------------------------------------\n")
+ x <- x + 1
+ z <- 3
+ .z <- 33
+ reprex <- construct_reprex(2, include_dotted = FALSE)
+ print(reprex)
+ }
+
+ expect_snapshot({
+ fun()
+ })
+})
diff --git a/sub/constructive.core/tests/testthat/test-construct_signature.R b/sub/constructive.core/tests/testthat/test-construct_signature.R
new file mode 100644
index 00000000..f1c81226
--- /dev/null
+++ b/sub/constructive.core/tests/testthat/test-construct_signature.R
@@ -0,0 +1,6 @@
+test_that("construct_signature", {
+ expect_snapshot({
+ construct_signature(transform)
+ construct_signature(lm)
+ })
+})
diff --git a/sub/constructive.core/tests/testthat/test-contains_self_reference.R b/sub/constructive.core/tests/testthat/test-contains_self_reference.R
new file mode 100644
index 00000000..5ddc3f29
--- /dev/null
+++ b/sub/constructive.core/tests/testthat/test-contains_self_reference.R
@@ -0,0 +1,93 @@
+test_that("contains_self_reference", {
+ expect_false(contains_self_reference(1))
+ expect_false(contains_self_reference(baseenv()))
+
+ env <- new.env(parent = baseenv())
+ # redundant definition is ok, circular is not!
+ expect_false(contains_self_reference(list(env, env)))
+
+ env <- new.env(parent = baseenv())
+ env$e <- env
+ expect_true(contains_self_reference(env))
+ expect_true(contains_self_reference(list(env)))
+
+ env <- new.env(parent = baseenv())
+ env$x <- list(env)
+ expect_true(contains_self_reference(env))
+
+ env <- new.env(parent = baseenv())
+ env$x <- structure(1, foo = env)
+ expect_true(contains_self_reference(env))
+
+ env <- new.env(parent = baseenv())
+ attr(env, "foo") <- env
+ expect_true(contains_self_reference(env))
+
+ env <- new.env(parent = baseenv())
+ env$f <- function() NULL
+ environment(env$f) <- env
+ expect_true(contains_self_reference(env))
+ expect_false(contains_self_reference(env, check_function = FALSE))
+
+ parent <- new.env()
+ env <- new.env(parent = parent)
+ attr(parent, "foo") <- env
+ expect_true(contains_self_reference(env))
+})
+
+test_that("self reference fails properly", {
+ env <- new.env(parent = baseenv())
+ env$x <- list(env)
+ expect_error(construct(env, opts_environment("list2env")), "self-references")
+ expect_error(construct(env, opts_environment("new_environment")), "self-references")
+ expect_error(construct(env, opts_environment("as.environment")), "self-references")
+ expect_snapshot(construct(env, opts_environment("predefine")))
+
+ env <- new.env(parent = baseenv())
+ env$x <- structure(1, foo = env)
+ expect_error(construct(env, opts_environment("list2env")), "self-references")
+ expect_error(construct(env, opts_environment("new_environment")), "self-references")
+ expect_error(construct(env, opts_environment("as.environment")), "self-references")
+ expect_snapshot(construct(env, opts_environment("predefine")))
+
+ env <- new.env(parent = baseenv())
+ attr(env, "foo") <- env
+ expect_error(construct(env, opts_environment("list2env")), "self-references")
+ expect_error(construct(env, opts_environment("new_environment")), "self-references")
+ expect_error(construct(env, opts_environment("as.environment")), "self-references")
+ expect_snapshot(construct(env, opts_environment("predefine")))
+
+ env <- new.env(parent = baseenv())
+ env$f <- function() NULL
+ environment(env$f) <- env
+ expect_error(construct(env, opts_environment("list2env")), "self-references")
+ expect_error(construct(env, opts_environment("new_environment")), "self-references")
+ expect_error(construct(env, opts_environment("as.environment")), "self-references")
+ expect_no_error(construct(
+ env,
+ opts_environment("list2env"),
+ opts_function(environment = FALSE),
+ check = FALSE))
+ expect_no_error(construct(
+ env,
+ opts_environment("new_environment"),
+ opts_function(environment = FALSE),
+ check = FALSE))
+ expect_no_error(construct(
+ env,
+ opts_environment("as.environment"),
+ opts_function(environment = FALSE),
+ check = FALSE))
+ expect_snapshot(construct(env, opts_environment("predefine")))
+
+ parent <- new.env(parent = baseenv())
+ env <- new.env(parent = parent)
+ attr(parent, "foo") <- env
+ expect_no_error(construct(env, opts_environment("list2env"), check = FALSE))
+ expect_no_error(construct(env, opts_environment("new_environment"), check = FALSE))
+ expect_no_error(construct(env, opts_environment("as.environment"), check = FALSE))
+ expect_error(construct(env, opts_environment("list2env", recurse = TRUE)), "self-references")
+ expect_error(construct(env, opts_environment("new_environment", recurse = TRUE)), "self-references")
+ # FIXME: this doesn't work yet but it's quite contrived!
+ # expect_snapshot(construct(env, opts_environment(predefine = TRUE)))
+})
diff --git a/sub/constructive.core/tests/testthat/test-deparse_call.R b/sub/constructive.core/tests/testthat/test-deparse_call.R
new file mode 100644
index 00000000..18c91d42
--- /dev/null
+++ b/sub/constructive.core/tests/testthat/test-deparse_call.R
@@ -0,0 +1,200 @@
+test_that("deparse_call()", {
+ expect_snapshot({
+ deparse_call(call("::", 1, 2), style = FALSE)
+ deparse_call(call("::", "a", quote(b)), style = FALSE)
+ deparse_call(call("::", quote(a), "b"), style = FALSE)
+ deparse_call(call(":::", 1, 2), style = FALSE)
+ deparse_call(call(":::", "a", quote(b)), style = FALSE)
+ deparse_call(call(":::", quote(a), "b"), style = FALSE)
+ deparse_call(call("+", 1, 2, 3), style = FALSE)
+ deparse_call(call("+", 1, 2), style = FALSE)
+ deparse_call(call("+", 1), style = FALSE)
+ deparse_call(call("+"), style = FALSE)
+ deparse_call(call("$", "a", "b", "c"), style = FALSE)
+ deparse_call(call("$", "a", "b"), style = FALSE)
+ deparse_call(call("$", quote(a), "b"), style = FALSE)
+ deparse_call(call("$", quote(a), quote(b)), style = FALSE)
+ deparse_call(call("$", "a", 1), style = FALSE)
+ deparse_call(call("$", 1, "b"), style = FALSE)
+ deparse_call(call("$"), style = FALSE)
+ deparse_call(call("$"), style = FALSE)
+ deparse_call(call(":", 1, 2, 3), style = FALSE)
+ deparse_call(call(":", 1, 2), style = FALSE)
+ deparse_call(call(":", 1), style = FALSE)
+ deparse_call(call(":"), style = FALSE)
+ deparse_call(call("(", 1, 2), style = FALSE)
+ deparse_call(call("(", 1), style = FALSE)
+ deparse_call(call("("), style = FALSE)
+ deparse_call(call("non-syntactic", 1), style = FALSE)
+
+ deparse_call(quote(foo(bar(baz(x), 1), arg = 2, empty=)), style = FALSE)
+ deparse_call(quote(foo(bar(baz(x), 1), arg = 2, empty=)), pipe = TRUE, style = FALSE)
+ # don't pipe if named arg since we can't be sure it's the same from static analysis
+ deparse_call(quote(foo(a=1, 2)), pipe = TRUE, style = FALSE)
+
+ deparse_call(quote(function(x,y=1,z=a) {x+y}), style = FALSE)
+ deparse_call(quote(function(x,y=1,z=a) {x+y}), one_liner = TRUE, style = FALSE)
+
+ deparse_call(quote(if (cond) this else that), style = FALSE)
+ deparse_call(quote(if (cond) {this} else {that}), style = FALSE)
+ deparse_call(quote(while (cond) this), style = FALSE)
+ deparse_call(quote(while (cond) {this}), style = FALSE)
+ deparse_call(quote(for (i in this) that), style = FALSE)
+ deparse_call(quote(for (i in this) {that}), style = FALSE)
+ deparse_call(quote(repeat this), style = FALSE)
+ deparse_call(quote(repeat {this}), style = FALSE)
+
+ # non syntatic symbols
+ deparse_call(quote(`*a*`))
+
+ # brackets and function calls with names
+ deparse_call(quote(a(b=1, c)))
+ deparse_call(quote(a[b=1, c]))
+ deparse_call(quote(a[[b=1, c]]))
+ deparse_call(quote(a(bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb=1, c)))
+ deparse_call(quote(a[bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb=1, c]))
+ # looks odd, but that's on {styler} : https://github.com/r-lib/styler/issues/1029
+ deparse_call(quote(a[[bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb=1, c]]))
+
+ # Multiline calls
+ deparse_call(quote(a(b(c12345678901234567890123456789012345678901234567890123456789012345678901234567890))))
+ deparse_call(quote(a({c12345678901234567890123456789012345678901234567890123456789012345678901234567890}, b)))
+
+ # function with non syntactic formal names
+ deparse_call(quote(function(`_x`) `_x`))
+
+ # call to function with too many args and a first arg that is not a pairlist
+ # this cannot be tested because of testthat/rlang limitations
+ # deparse_call(quote(`function`(a(b, c), d, e)))
+
+ # non-syntactig argument name
+ deparse_call(quote(list(`a + b` = a + b)))
+
+ # non syntactic function calls
+ deparse_call(quote((`boo<-`)(x)))
+ deparse_call(quote(`boo<-`[[1]](x)))
+ })
+
+ expect_snapshot({
+ # Avoid testthat corruption
+ deparse_call(eval(str2lang("quote(`=`(x, 1))")))
+ deparse_call(eval(str2lang("quote(list(`=`(x, 1)))")))
+ deparse_call(eval(str2lang("quote((`=`(x, 1)))")))
+ deparse_call(quote(list(x = 1)))
+ deparse_call(quote({x = 1}))
+ })
+
+ expect_snapshot({
+ deparse_call(quote({{x}}), style = FALSE) # proper tunnel
+ deparse_call(quote({{1}}), style = FALSE) # not a symbol
+ deparse_call(quote({{1}}), one_liner = TRUE, style = FALSE)
+ deparse_call('"')
+ deparse_call('"', escape = TRUE)
+ deparse_call("ü")
+ deparse_call("ü", unicode_representation = "latin")
+ })
+
+ expect_snapshot({
+ deparse_call(quote(1 -> x <- 2))
+ deparse_call(quote(1 -> if(TRUE) 1))
+ deparse_call(quote(1 -> for(i in j) 1))
+ deparse_call(quote(1 -> while(TRUE) 1))
+ deparse_call(quote(1 -> repeat 1))
+ })
+})
+
+test_that("deparse_call() for R >= 4.1", {
+ # Due to bypass.R
+ skip_if(base::`<`(getRversion(), "4.1"))
+ expect_snapshot({
+ deparse_call(quote(`🐶`), style = FALSE)
+ deparse_call(quote(`🐶`), unicode_representation = "unicode")
+ })
+})
+
+test_that("deparse_call() fails when the caller is empty", {
+ # Note this prints a "fake" rstudio error when called manually
+ call <- substitute(X(), list(X = quote(expr = )))
+ expect_error(deparse_call(call), regexp = "Found empty symbol")
+ call <- substitute({X(1, 2)}, list(X = quote(expr = )))
+ expect_error(deparse_call(call), regexp = "Found empty symbol")
+})
+
+test_that("deparse_call() fails when the sole arg is empty", {
+ expect_error(deparse_call(call("fun", quote(expr = ))), regexp = "Found empty symbol")
+ expect_error(deparse_call(call("+", quote(expr = ))), regexp = "Found empty symbol")
+})
+
+test_that("square brackets", {
+ expect_snapshot({
+ deparse_call(call("[", 1, 2, 3), style = FALSE)
+ deparse_call(call("[", 1, 2), style = FALSE)
+ deparse_call(call("[", 1), style = FALSE)
+ deparse_call(call("["), style = FALSE)
+ deparse_call(call("[[", 1, 2, 3), style = FALSE)
+ deparse_call(call("[[", 1, 2), style = FALSE)
+ deparse_call(call("[[", 1), style = FALSE)
+ deparse_call(call("[["), style = FALSE)
+ deparse_call(call("[", quote(expr=), quote(expr=)), style = FALSE)
+ deparse_call(call("[", 1, quote(expr=)), style = FALSE)
+ deparse_call(call("[", quote(a+b), 1), style = FALSE)
+ deparse_call(quote(a$b[[c]]))
+ deparse_call(quote(a[[b]]$c))
+ deparse_call(quote(a[[b$c]]))
+ deparse_call(call("[", quote(while (TRUE) {}), 1), style = FALSE)
+ deparse_call(call("[", quote(if (TRUE) {}), 1), style = FALSE)
+ deparse_call(call("[", quote(for (a in b) {}), 1), style = FALSE)
+ deparse_call(call("[", quote(repeat {}), 1), style = FALSE)
+ deparse_call(call("[", quote(function() {}), 1), style = FALSE)
+ deparse_call(call("[", call("function", 1,2), 1), style = FALSE)
+ })
+})
+
+test_that("curly braces", {
+ expect_snapshot({
+ deparse_call(call("{"), style = FALSE)
+ deparse_call(call("{", 1, 2), style = FALSE)
+ deparse_call(call("{", 1, 2), one_liner = TRUE, style = FALSE)
+ deparse_call(call("{", 1, quote(expr = )), style = FALSE)
+ })
+})
+
+test_that("Use lisp notation when the caller expr calls a control flow construct", {
+ expect_snapshot({
+ deparse_call(substitute(X(Y), list(X = quote(if (TRUE) {}), Y = 1)))
+ deparse_call(substitute(X(Y), list(X = quote(while (TRUE) {}), Y = 1)))
+ deparse_call(substitute(X(Y), list(X = quote(for (a in b) {}), Y = 1)))
+ deparse_call(substitute(X(Y), list(X = quote(repeat {}), Y = 1)))
+ })
+})
+
+test_that("Operator precedence is well handled", {
+ expect_snapshot({
+ deparse_call(str2lang("`^`(`+`(a, b), c)"))
+ deparse_call(str2lang("`+`(`^`(a, b), c)"))
+ deparse_call(str2lang("`%in%`(`*`(a, b), c)"))
+ deparse_call(str2lang("`*`(`%in%`(a, b), c)"))
+ deparse_call(str2lang("`+`(`+`(1, 2), 4)"))
+ deparse_call(str2lang("`-`(1+2)"))
+ deparse_call(str2lang("`<-`(`<<-`(1, 2), 4)"))
+ deparse_call(str2lang("`+`(x, y)(z)"))
+ deparse_call(quote(x <- a::b(y)))
+ deparse_call(quote(x <- a:::b(y)))
+ deparse_call(quote(x <- a$b(y)))
+ deparse_call(quote(x <- a@b(y)))
+ deparse_call(quote(x <- a::b$c(y)))
+ deparse_call(str2lang("`^`(`^`(1, 2), 4)"))
+ deparse_call(str2lang("`^`(4, `^`(1, 2))"))
+ deparse_call(str2lang("`+`(4, `+`(1, 2))"))
+ deparse_call(substitute(X + Y, list(X = quote(repeat {}), Y = 1)))
+ deparse_call(substitute(X + Y, list(X = 1, Y = quote(repeat {}))))
+ deparse_call(substitute(X ? Y, list(X = quote(repeat {}), Y = 1)))
+ deparse_call(substitute(X ? Y, list(X = 1, Y = quote(repeat {}))))
+ deparse_call(substitute(X$Y, list(X = quote(repeat {}), Y = 1)))
+ deparse_call(substitute(X$Y, list(X = 1, Y = quote(repeat {}))))
+ deparse_call(substitute(X(Y), list(X = quote(repeat {}), Y = 1)))
+ deparse_call(substitute(X[Y], list(X = quote(repeat {}), Y = 1)))
+ deparse_call(quote(+repeat {}))
+ deparse_call(quote(+repeat {}))
+ })
+})
diff --git a/sub/constructive.core/tests/testthat/test-encoding.R b/sub/constructive.core/tests/testthat/test-encoding.R
new file mode 100644
index 00000000..61a84503
--- /dev/null
+++ b/sub/constructive.core/tests/testthat/test-encoding.R
@@ -0,0 +1,21 @@
+test_that("Encoding", {
+ expect_snapshot(
+ construct(data.frame(
+ x = c("ü","a"),
+ y = c("loooooooooooooooooooooooooooooooooong_enough_for_multiline_output")
+ ))
+ )
+})
+
+test_that("non UTF-8 encodings with UTF-8 system", {
+ skip_if(!l10n_info()$`UTF-8`)
+ expect_snapshot({
+ x <- iconv("hello\U{A0}world", to = "latin1")
+ construct(x)
+ x <- iconv("こんにちは", to = "shift_jis")
+ construct(x)
+ x <- "hello\xa0world"
+ Encoding(x) <- "latin1"
+ construct(x)
+ })
+})
diff --git a/sub/constructive.core/tests/testthat/test-opts.R b/sub/constructive.core/tests/testthat/test-opts.R
new file mode 100644
index 00000000..8be2219c
--- /dev/null
+++ b/sub/constructive.core/tests/testthat/test-opts.R
@@ -0,0 +1,3 @@
+test_that("opts", {
+ expect_snapshot(opts_formula())
+})
diff --git a/sub/constructive.core/tests/testthat/test-repair_attributes.R b/sub/constructive.core/tests/testthat/test-repair_attributes.R
new file mode 100644
index 00000000..fb9debb3
--- /dev/null
+++ b/sub/constructive.core/tests/testthat/test-repair_attributes.R
@@ -0,0 +1,5 @@
+test_that("structure corner cases", {
+ a <- 1
+ attributes(a) <- list(.Names = "name1", names = "name2", .Label = "label1", levels = "label2")
+ expect_snapshot(construct(a))
+})
diff --git a/sub/constructive.core/tests/testthat/test-s3-array.R b/sub/constructive.core/tests/testthat/test-s3-array.R
new file mode 100644
index 00000000..cbbd3bd5
--- /dev/null
+++ b/sub/constructive.core/tests/testthat/test-s3-array.R
@@ -0,0 +1,15 @@
+test_that("array", {
+ expect_snapshot({
+ construct(as.array(month.abb))
+ construct(as.array(month.abb), opts_array("next"))
+ construct(array(1:3, c(2,4)))
+ construct(structure(1, class = "array"))
+ construct(structure(1, class = "array", dim = 1))
+ })
+})
+
+test_that("classed array", {
+ expect_snapshot({
+ construct(structure(array(1:27, c(3,3,3)), class = "a"))
+ })
+})
diff --git a/sub/constructive.core/tests/testthat/test-s3-atomic.R b/sub/constructive.core/tests/testthat/test-s3-atomic.R
new file mode 100644
index 00000000..ef445207
--- /dev/null
+++ b/sub/constructive.core/tests/testthat/test-s3-atomic.R
@@ -0,0 +1,232 @@
+test_that("numeric", {
+ expect_snapshot({
+ # by default no scientific notation
+ construct(10000)
+ # by default scientific notation
+ construct(100000)
+ # not truncated
+ construct(.1000000000000001)
+ # truncated
+ construct(.10000000000000001)
+ # by default scientific notation
+ construct(.0000000000000011)
+ # trim
+ construct(c(1, 2, 3), opts_atomic(trim = 0))
+ construct(c(1, 2, 3), opts_atomic(trim = 1))
+ construct(c(1, 2, 3), opts_atomic(trim = 2))
+ construct(c(1, 2, 3), opts_atomic(trim = 1, fill = "rlang"))
+ construct(c(1, 2, 3), opts_atomic(trim = 1, fill = "+"))
+ construct(c(1, 2, 3), opts_atomic(trim = 1, fill = "..."))
+ construct(c(1, 2, 3), opts_atomic(trim = 1, fill = "none"))
+ # don't print useless extra digits (thanks to format(x, digits = 15))
+ construct(0.07)
+ construct(NA_real_)
+ construct(c(1, NA_real_))
+ # one_liner
+ construct(c(0, 1:30))
+ construct(c(0, 1:30), one_liner = TRUE)
+ # empty names
+ construct(structure("a", names = ""))
+ construct(NaN)
+ construct(c(1, NaN))
+ construct(c("\U{430}" = 1))
+
+ construct(c(NaN, NA))
+ construct(c(NaN, NA, NaN))
+ construct(c(NA, NaN, NA))
+
+ })
+})
+
+test_that("other atomic", {
+ expect_snapshot({
+ construct(letters)
+ construct(letters, one_liner = TRUE)
+ construct(letters, opts_atomic(trim = 1, fill = "rlang"))
+ construct(letters, opts_atomic(trim = 1, fill = "+"))
+ construct(letters, opts_atomic(trim = 1, fill = "..."))
+ construct(letters, opts_atomic(trim = 1, fill = "none"))
+ })
+})
+
+
+test_that("simplify atomic", {
+ expect_snapshot({
+ construct(c("a", "a", "b", "c", "c", "c", "c"))
+ construct(c(foo = "a", "a", "b", "c", "c", "c", "c"))
+ construct(c("a", "b", "a", "b","a", "b","a", "b"))
+ construct(c("a", "a", "b", "b", "c", "c"))
+ construct(c(1, 2, 3, 4, 1, 2, 3, 4))
+ construct(as.integer(c(1, 2, 3, 4, 1, 2, 3, 4)))
+ construct(c(2, 4, 6, 8, 2, 4, 6, 8))
+ construct(as.integer(c(2, 4, 6, 8, 2, 4, 6, 8)))
+ construct(c("a", "a", "b", "c", "c", "c", "c"), opts_atomic(compress = FALSE))
+ construct(c(0L, 0L, -1L, .Machine$integer.max))
+ })
+})
+
+test_that("character", {
+ # check = FALSE for raw strings to pass tests on older R versions
+ expect_snapshot({
+ construct("'hello'")
+ construct('"hello"')
+ construct("'\"hello\"'", check = FALSE)
+ construct("'\"hello\"'", check = FALSE)
+ construct("\\", check = FALSE)
+ construct("\\\\", check = FALSE)
+ construct("\n\\")
+ construct("ü", opts_character(unicode_representation = "latin"))
+ construct("ü", check = FALSE)
+ construct("ü\\", opts_character(unicode_representation = "latin", escape = FALSE), check = FALSE)
+ construct("ü\\", opts_character(escape = FALSE))
+ construct(c("\U{430}" = "a"))
+ construct("'\"\n")
+ })
+})
+
+test_that("negative zeroes", {
+ expect_snapshot({
+ construct(-0)
+ construct(c(-0, -0, -0))
+ construct(c(0, -0, -0))
+ # construct(-NA_real_)
+ # construct(-NaN)
+ })
+})
+
+test_that("complex", {
+ expect_snapshot({
+ construct(NA_complex_)
+ construct(c(NA_complex_, NA_complex_))
+ construct(c(NA_complex_, NA_complex_, NA_complex_))
+ construct(c(NA_complex_, NA_complex_, NA_complex_), opts_atomic(compress = FALSE))
+ construct(c(NA_complex_, 1))
+ construct(c(NA_complex_, 1i))
+ construct(1e-10 + 1e10i)
+ construct(c(1e-10 + 1e10i, 2e-10 + 2e10i))
+ construct(complex(real = 1, imaginary = NA))
+ construct(complex(real = 1, imaginary = NaN))
+ construct(complex(real = NaN, imaginary = NaN))
+ construct(complex(real = NA, imaginary = NA))
+ construct(complex(real = NA, imaginary = 1))
+ construct(complex(real = NaN, imaginary = 1))
+ construct(c(complex(real = NaN, imaginary = 1), complex(real = NaN, imaginary = 1)))
+ construct(c(1 + 1i, complex(real = NaN, imaginary = 1)))
+
+ construct(complex(real = -0, imaginary = -0))
+ construct(complex(real = -0, imaginary = 0))
+ construct(complex(real = -0, imaginary = -0))
+ construct(0 + 0i)
+ construct(0 - 0i)
+ construct(-0 - 0i)
+ construct(-0 + 0i)
+ })
+})
+
+
+test_that("NA and empty names", {
+ expect_snapshot({
+ construct(structure(logical(2), names = c("", "")))
+ construct(structure(logical(2), names = c("", NA)))
+ construct(structure(logical(2), names = c(NA, NA)))
+ construct(structure(logical(2), names = c(NA, "a")))
+ construct(structure(logical(2), names = c("", "a")))
+ construct(structure(logical(2), names = c("", "a")))
+ construct(structure(logical(10), names = c("", "a")))
+ construct(structure(logical(2), names = structure(c("b", "a"), foo = 1)))
+
+ construct(structure(integer(2), names = c("", "")))
+ construct(structure(integer(2), names = c("", NA)))
+ construct(structure(integer(2), names = c(NA, NA)))
+ construct(structure(integer(2), names = c(NA, "a")))
+ construct(structure(integer(2), names = c("", "a")))
+ construct(structure(integer(10), names = c("", "a")))
+ construct(structure(integer(2), names = structure(c("b", "a"), foo = 1)))
+
+ construct(structure(double(2), names = c("", "")))
+ construct(structure(double(2), names = c("", NA)))
+ construct(structure(double(2), names = c(NA, NA)))
+ construct(structure(double(2), names = c(NA, "a")))
+ construct(structure(double(2), names = c("", "a")))
+ construct(structure(double(10), names = c("", "a")))
+ construct(structure(double(2), names = structure(c("b", "a"), foo = 1)))
+
+ construct(structure(complex(2), names = c("", "")))
+ construct(structure(complex(2), names = c("", NA)))
+ construct(structure(complex(2), names = c(NA, NA)))
+ construct(structure(complex(2), names = c(NA, "a")))
+ construct(structure(complex(2), names = c("", "a")))
+ construct(structure(complex(10), names = c("", "a")))
+ construct(structure(complex(2), names = structure(c("b", "a"), foo = 1)))
+
+ construct(structure(character(2), names = c("", "")))
+ construct(structure(character(2), names = c("", NA)))
+ construct(structure(character(2), names = c(NA, NA)))
+ construct(structure(character(2), names = c(NA, "a")))
+ construct(structure(character(2), names = c("", "a")))
+ construct(structure(character(10), names = c("", "a")))
+ construct(structure(character(2), names = structure(c("b", "a"), foo = 1)))
+
+ construct(structure(raw(2), names = c("", "")))
+ construct(structure(raw(2), names = c("", NA)))
+ construct(structure(raw(2), names = c(NA, NA)))
+ construct(structure(raw(2), names = c(NA, "a")))
+ construct(structure(raw(2), names = c("", "a")))
+ construct(structure(raw(10), names = c("", "a")))
+ construct(structure(raw(2), names = structure(c("b", "a"), foo = 1)))
+ })
+})
+
+test_that("attributes are repaired on length 0 atomics", {
+ expect_snapshot({
+ construct(structure(character(0), foo = 1))
+ construct(structure(double(0), foo = 1))
+ construct(structure(integer(0), foo = 1))
+ construct(structure(complex(0), foo = 1))
+ construct(structure(logical(0), foo = 1))
+ construct(structure(raw(0), foo = 1))
+ })
+})
+
+test_that("atomic elements named `recursive` or `use.names`", {
+ expect_snapshot({
+ construct(structure(logical(1), names = "recursive"))
+ construct(structure(integer(1), names = "recursive"))
+ construct(structure(numeric(1), names = "recursive"))
+ construct(structure(complex(1), names = "recursive"))
+ construct(structure(raw(1), names = "recursive"))
+ })
+})
+
+test_that("opts_atomic() inheritance", {
+ expect_snapshot({
+ construct(c(TRUE, FALSE, TRUE), opts_logical(trim = 1, fill = "+"))
+ construct(c(TRUE, FALSE, TRUE), opts_atomic(trim = 0), opts_logical(trim = 1, fill = "+"))
+
+ construct(1:3, opts_integer(trim = 1, fill = "+"))
+ construct(1:3, opts_atomic(trim = 0), opts_integer(trim = 1, fill = "+"))
+
+ construct(c(1, 2, 3), opts_double(trim = 1, fill = "+"))
+ construct(c(1, 2, 3), opts_atomic(trim = 0), opts_double(trim = 1, fill = "+"))
+
+ construct(c(1i, 2i, 3i), opts_complex(trim = 1, fill = "+"))
+ construct(c(1i, 2i, 3i), opts_double(trim = 0, fill = "+"))
+ construct(c(1i, 2i, 3i), opts_atomic(trim = 0), opts_complex(trim = 1, fill = "+"))
+
+ construct(as.raw(c(1,2,3)), opts_raw(trim = 1, fill = "+"))
+ construct(as.raw(c(1,2,3)), opts_integer(trim = 0))
+ construct(as.raw(c(1,2,3)), opts_double(trim = 0), opts_raw(representation = "decimal"))
+ construct(as.raw(c(1,2,3)), opts_atomic(trim = 0), opts_raw(trim = 1, fill = "+"))
+
+ construct(letters, opts_character(trim = 1, fill = "+"))
+ construct(letters, opts_atomic(trim = 0), opts_character(trim = 1, fill = "+"))
+
+ construct("🐶", unicode_representation = "ascii")
+ construct("🐶", unicode_representation = "ascii", opts_character(unicode_representation = "unicode"))
+ construct("🐶", unicode_representation = "unicode", opts_character(unicode_representation = "ascii"))
+ construct("🐶", unicode_representation = "ascii", opts_atomic(unicode_representation = "unicode"))
+ construct("🐶", unicode_representation = "unicode", opts_atomic(unicode_representation = "ascii"))
+ construct("🐶", opts_atomic(unicode_representation = "ascii"), opts_character(unicode_representation = "unicode"))
+ construct("🐶", opts_atomic(unicode_representation = "unicode"), opts_character(unicode_representation = "ascii"))
+ })
+})
diff --git a/sub/constructive.core/tests/testthat/test-s3-dots.R b/sub/constructive.core/tests/testthat/test-s3-dots.R
new file mode 100644
index 00000000..e18614e6
--- /dev/null
+++ b/sub/constructive.core/tests/testthat/test-s3-dots.R
@@ -0,0 +1,18 @@
+test_that("dots", {
+ expect_snapshot({
+ # if dots1 and the evaluation env of `...` is in the same env we have
+ # infinite recursion issues so we use `local()`
+ dots1 <- local((function(...) get("..."))(a=x, y))
+ construct(dots1, opts_environment("list2env"))
+ construct(structure(dots1, class = "foo"), opts_environment("list2env"))
+
+ f <- function(...) {
+ y <- 1
+ g(y = y, ...)
+ }
+ g <- function(...) get("...")
+ x <- 1
+ dots2 <- local(f(x = x))
+ construct(dots2, opts_environment("list2env"))
+ })
+})
diff --git a/sub/constructive.core/tests/testthat/test-s3-environment.R b/sub/constructive.core/tests/testthat/test-s3-environment.R
new file mode 100644
index 00000000..cd57652b
--- /dev/null
+++ b/sub/constructive.core/tests/testthat/test-s3-environment.R
@@ -0,0 +1,86 @@
+test_that("environment", {
+ expect_snapshot({
+ # handle special cases
+ construct(globalenv())
+ construct(baseenv())
+ construct(as.environment("package:base"))
+ construct(asNamespace("base"))
+ construct(as.environment("Autoloads"))
+ construct(environment(setNames))
+ # env from list
+ construct(as.environment(head(cars,2)), opts_environment("list2env"))
+ # env "prototype" with constructor = "new.env"
+ construct(as.environment(head(cars,2)), opts_environment(constructor = "new.env"))
+ # but only if can't be guessed
+ construct(environment(setNames), opts_environment(constructor = "new.env"))
+ # envs with a class are correctly forwarded to env method
+ env <- new.env(parent = asNamespace("stats"))
+ class(env) <- "foo"
+ construct(env, opts_environment("list2env"))
+ e1 <- new.env(parent = .GlobalEnv)
+ e1$x <- 1
+ e2 <- new.env(parent = e1)
+ e2$y <- 2
+ e2$.z <- 3
+ construct(e2, opts_environment(constructor = "list2env")) # constructor = "list2env", recurse = FALSE
+ construct(e2, opts_environment(constructor = "new_environment"))
+ construct(e2, opts_environment(constructor = "new.env"))
+ construct(e2, opts_environment(constructor = "topenv"))
+ construct(e2, opts_environment(constructor = "as.environment"))
+ # circularity
+ evalq({
+ e <- new.env()
+ e$f <- e
+ foo <- evalq(~a, e)
+ construct(foo, opts_environment("predefine"), opts_formula(environment = TRUE))
+ }, .GlobalEnv)
+ })
+
+ # FIXME: fails on CI, because of segfault, why ?
+ # expect_error(constructive::.env("0x123456789"), "No environment was found")
+
+ skip_if(with_versions(R < "4.2"))
+ expect_snapshot({
+ construct(e2, opts_environment(constructor = "list2env", recurse = TRUE))
+ construct(e2, opts_environment(constructor = "new_environment", recurse = TRUE))
+ })
+
+ skip_if(identical(Sys.getenv("R_COVR"), "true"))
+ expect_snapshot({
+ construct(constructive::.cstr_construct, opts_environment("predefine"), opts_function(environment = TRUE))
+ })
+
+ expect_snapshot({
+ e <- rlang::env(.GlobalEnv, a = 1, b = 2, c = 3, d = 4)
+ construct(e, check = FALSE)
+ lockEnvironment(e)
+ construct(e, check = FALSE)
+ construct(e, opts_environment("list2env"))
+ lockBinding("a", e)
+ construct(e, opts_environment("list2env"))
+ lockBinding("b", e)
+ construct(e, opts_environment("list2env"))
+ lockBinding("c", e)
+ construct(e, opts_environment("list2env"))
+ lockBinding("d", e)
+ construct(e, opts_environment("list2env"))
+ })
+
+ expect_snapshot({
+ construct(getNamespaceInfo("datasets", "lazydata"))
+ construct(parent.env(asNamespace("stats")))
+ })
+})
+
+test_that("environments with names method are constructed properly", {
+ env <- new.env()
+ env$x <- 1
+ class(env) <- "foo"
+ names.foo <- function(x) "y"
+ expect_snapshot({
+ construct(env, opts_environment("list2env"), check = FALSE)
+ })
+})
+
+
+
diff --git a/sub/constructive.core/tests/testthat/test-s3-externalptr.R b/sub/constructive.core/tests/testthat/test-s3-externalptr.R
new file mode 100644
index 00000000..498463a2
--- /dev/null
+++ b/sub/constructive.core/tests/testthat/test-s3-externalptr.R
@@ -0,0 +1,10 @@
+test_that("externalptr", {
+ expect_snapshot({
+ dt <- data.table::data.table(a = 1)
+ class(dt) <- "data.frame"
+ construct(dt, check = FALSE)
+
+ classed_ptr <- structure(attr(dt, ".internal.selfref"), class = "foo")
+ construct(classed_ptr, check = FALSE)
+ })
+})
diff --git a/sub/constructive.core/tests/testthat/test-s3-function.R b/sub/constructive.core/tests/testthat/test-s3-function.R
new file mode 100644
index 00000000..f5cc6959
--- /dev/null
+++ b/sub/constructive.core/tests/testthat/test-s3-function.R
@@ -0,0 +1,75 @@
+test_that("function", {
+ expect_snapshot({
+ f1 <- as.function(alist(x=, x), .GlobalEnv)
+ f2 <- as.function(alist(x=, {x}), .GlobalEnv)
+
+ construct(f1)
+ construct(f2)
+ construct(f1, opts_function(environment = FALSE))
+
+ construct(f1, opts_function(srcref = TRUE, environment = FALSE))
+ construct(f2, opts_function(srcref = TRUE, environment = FALSE))
+
+ construct(f1, opts_function("as.function"))
+ construct(f2, opts_function("as.function"))
+ construct(f1, opts_function("as.function", environment = FALSE))
+
+ construct(f1, opts_function("new_function"))
+ construct(f2, opts_function("new_function"))
+ construct(f1, opts_function("new_function", environment = FALSE))
+
+ # for reproducibility, since base R changes formatting sometimes even for simple functions
+ setNames <- function (object = nm, nm) {
+ names(object) <- nm
+ object
+ }
+ environment(setNames) <- asNamespace("stats")
+
+ construct(setNames, opts_function(environment = TRUE))
+ construct(setNames, opts_function("as.function", environment = TRUE))
+ # with trim
+ construct(setNames, opts_function(trim = 1))
+
+ # primitives
+ construct(`+`)
+
+ # functions with a class
+ f4 <- f1
+ class(f4) <- "foo"
+ construct(f4)
+
+ # use srcref to keep comments
+ # testthat seems to remove srcrefs so we build it artificially
+ f5 <- (function(x) {
+ x
+ }) %>%
+ structure(
+ srcref = c(1L, 8L, 4L, 1L, 8L, 1L, 1L, 4L) %>%
+ structure(
+ srcfile = list2env(
+ list(
+ fixedNewlines = TRUE,
+ lines = c("foo <- function(x) {", " # foo", " x", "}", ""),
+ filename = ""
+ ),
+ parent = .GlobalEnv
+ ) %>%
+ structure(class = c("srcfilecopy", "srcfile")),
+ class = "srcref"
+ )
+ )
+ construct(f5, opts_function(environment = FALSE), pipe = "magrittr")
+
+ # function without body and without srcref
+ f6 <- function() NULL
+ attr(f6, "srcref") <- NULL
+ construct(f6, opts_function(environment = FALSE))
+
+ f7 <- f2
+ body(f7) <- structure(body(f7), some_attr = "hello")
+ construct(f7, opts_function(environment = FALSE))
+
+ construct(as.function(list(a=list(), quote(a)), envir = .GlobalEnv))
+ })
+})
+
diff --git a/sub/constructive.core/tests/testthat/test-s3-language.R b/sub/constructive.core/tests/testthat/test-s3-language.R
new file mode 100644
index 00000000..52fb4c8e
--- /dev/null
+++ b/sub/constructive.core/tests/testthat/test-s3-language.R
@@ -0,0 +1,47 @@
+test_that("language", {
+ expect_snapshot({
+ construct(quote(a_symbol))
+ construct(as.symbol("a\\b"))
+ construct(quote(a + call))
+ construct(quote(expr=))
+ construct(as.call(list(quote(expr = ))))
+ })
+})
+
+test_that("language after 4.1", {
+ # Due to bypass.R
+ skip_if(base::`<`(getRversion(), "4.1"))
+
+ expect_snapshot({
+ construct(quote(`🐶`))
+ construct(quote(`🐶`), unicode_representation = "unicode")
+ })
+})
+
+test_that("complex language", {
+ expect_snapshot({
+ x <- quote(a(1)(2))
+ attr(x[[1]], "foo") <- "bar"
+ construct(x)
+
+ y <- quote(a(1))
+ y[[1]] <- c("a", "vector")
+ construct(y)
+ })
+})
+
+test_that("We can construct calls with empty callers", {
+ expect_snapshot({
+ construct(substitute(X(), list(X = quote(expr = ))))
+ construct(substitute({X(1, 2)}, list(X = quote(expr = ))))
+ })
+})
+
+test_that("We can construct calls with non syntactic literals", {
+ expect_snapshot({
+ construct(call("fun", -1))
+ construct(call("fun", 1+0i))
+ construct(call("fun", quote(expr=)))
+ construct(call("+", quote(expr=)))
+ })
+})
diff --git a/sub/constructive.core/tests/testthat/test-s3-list.R b/sub/constructive.core/tests/testthat/test-s3-list.R
new file mode 100644
index 00000000..4e745063
--- /dev/null
+++ b/sub/constructive.core/tests/testthat/test-s3-list.R
@@ -0,0 +1,44 @@
+test_that("list", {
+ # For stability
+ .leap.seconds <- as.POSIXct(
+ c(
+ "1972-07-01", "1973-01-01", "1974-01-01", "1975-01-01", "1976-01-01",
+ "1977-01-01", "1978-01-01", "1979-01-01", "1980-01-01", "1981-07-01",
+ "1982-07-01", "1983-07-01", "1985-07-01", "1988-01-01", "1990-01-01",
+ "1991-01-01", "1992-07-01", "1993-07-01", "1994-07-01", "1996-01-01",
+ "1997-07-01", "1999-01-01", "2006-01-01", "2009-01-01", "2012-07-01",
+ "2015-07-01", "2017-01-01"
+ ),
+ tz = "GMT"
+ )
+
+ expect_snapshot({
+ construct(list(a = 1, b = list(c(1L, 3L), list(.leap.seconds[1:2]))))
+
+ x1 <- as.list(letters[1:4])
+ construct(x1)
+ construct(x1, opts_list("list2"))
+
+ x2 <- as.list(letters)
+ construct(x2)
+ construct(x2, opts_list("list2"))
+
+ construct(x2, opts_list(trim = 2)) # fill = "vector"
+ construct(x2, opts_list(trim = 26))
+ construct(x2, opts_list(trim = 30))
+ construct(x2, opts_list(trim = 2, fill = "new_list"))
+ construct(x2, opts_list(trim = 2, fill = "+"))
+ construct(x2, opts_list(trim = 2, fill = "none"))
+ construct(x2, opts_list(trim = 2, fill = "..."))
+ construct(list("\U{430}" = 1))
+ })
+
+ corrupted_list <- structure(list(1), class = c("corrupted"))
+ length.corrupted <- function(x) stop()
+ `[.corrupted` <- function(...) stop()
+ `[[.corrupted` <- function(...) stop()
+ expect_error(length(corrupted_list))
+ expect_snapshot({
+ construct(corrupted_list)
+ })
+})
diff --git a/sub/constructive.core/tests/testthat/test-s3-matrix.R b/sub/constructive.core/tests/testthat/test-s3-matrix.R
new file mode 100644
index 00000000..067f91a5
--- /dev/null
+++ b/sub/constructive.core/tests/testthat/test-s3-matrix.R
@@ -0,0 +1,29 @@
+test_that("matrix", {
+ expect_snapshot({
+ construct(WorldPhones)
+ construct(matrix(1:9, 3))
+ construct(matrix(1:9, 1))
+ construct(matrix(1:9, 3), opts_matrix("array"))
+ construct(matrix(1:9, 3), opts_matrix("next"))
+ })
+})
+
+test_that("classed matrix", {
+ expect_snapshot({
+ construct(structure(matrix(1:9, 3), class = "a"))
+ })
+})
+
+test_that("matrix with rbind and cbind", {
+ expect_snapshot({
+ construct(matrix(1:4, 2), opts_matrix("cbind"))
+ construct(matrix(1:4, 2, dimnames = list(c("a", "b"), c("c", "d"))), opts_matrix("cbind"))
+ construct(matrix(1:4, 2, dimnames = list(c("a", "b"))), opts_matrix("cbind"))
+ construct(matrix(1:4, 2, dimnames = list(NULL, c("c", "d"))), opts_matrix("cbind"))
+
+ construct(matrix(1:4, 2), opts_matrix("rbind"))
+ construct(matrix(1:4, 2, dimnames = list(c("a", "b"), c("c", "d"))), opts_matrix("rbind"))
+ construct(matrix(1:4, 2, dimnames = list(c("a", "b"))), opts_matrix("rbind"))
+ construct(matrix(1:4, 2, dimnames = list(NULL, c("c", "d"))), opts_matrix("rbind"))
+ })
+})
diff --git a/sub/constructive.core/tests/testthat/test-s3-pairlist.R b/sub/constructive.core/tests/testthat/test-s3-pairlist.R
new file mode 100644
index 00000000..21b14e5a
--- /dev/null
+++ b/sub/constructive.core/tests/testthat/test-s3-pairlist.R
@@ -0,0 +1,6 @@
+test_that("pairlist", {
+ expect_snapshot({
+ construct(pairlist(a=1, 2))
+ construct(pairlist(a=1, 2), opts_pairlist("pairlist2"))
+ })
+})
diff --git a/sub/constructive.core/tests/testthat/test-s3-raw.R b/sub/constructive.core/tests/testthat/test-s3-raw.R
new file mode 100644
index 00000000..7e03a0de
--- /dev/null
+++ b/sub/constructive.core/tests/testthat/test-s3-raw.R
@@ -0,0 +1,18 @@
+test_that("raw", {
+ # check = FALSE for raw strings to pass tests on older R versions
+ expect_snapshot({
+ construct(raw(1))
+ construct(raw(2))
+ construct(raw(10))
+ construct(structure(raw(2), foo = 1))
+
+ construct(raw(1), opts_raw(representation = "decimal"))
+ construct(raw(2), opts_raw(representation = "decimal"))
+ construct(raw(10), opts_raw(representation = "decimal"))
+
+ construct(
+ as.raw(c(0x68, 0x65, 0x6c, 0x6c, 0x6f, 0x77, 0x6f, 0x72, 0x6c, 0x64)),
+ opts_raw("charToRaw")
+ )
+ })
+})
diff --git a/sub/constructive.core/tests/testthat/test-s4.R b/sub/constructive.core/tests/testthat/test-s4.R
new file mode 100644
index 00000000..12f3a757
--- /dev/null
+++ b/sub/constructive.core/tests/testthat/test-s4.R
@@ -0,0 +1,22 @@
+test_that("s4", {
+ expect_snapshot({
+ track <- setClass("track", slots = c(x="numeric", y="numeric"))
+ construct(track)
+
+ t1 <- track(x = 1:3, y = 4:6)
+ construct(t1)
+
+ trackCurve <- setClass("trackCurve", slots = c(smooth = "numeric"), contains = "track")
+ construct(trackCurve)
+
+ t1s <- trackCurve(t1, smooth = 1:3)
+ construct(t1s)
+
+ construct(prototype(1, a = 2))
+ construct(getClass("numeric"))
+
+ track0 <- track
+ attr(track0, "class") <- NULL
+ construct(track0)
+ })
+})
diff --git a/sub/constructive.core/tests/testthat/test-utils.R b/sub/constructive.core/tests/testthat/test-utils.R
new file mode 100644
index 00000000..9f8cfa1b
--- /dev/null
+++ b/sub/constructive.core/tests/testthat/test-utils.R
@@ -0,0 +1,27 @@
+test_that("pipe works for one liners", {
+ expect_snapshot({
+ x <- 1
+ attr(x, "foo") <- 2
+ construct(x, one_liner = TRUE)
+ })
+})
+
+test_that("data", {
+ expect_snapshot({
+ construct(cars, data = "datasets")
+ construct(mean, data = "base")
+ construct(mean, data = asNamespace("base"))
+ construct(list(mean, cars), data = list(asNamespace("base"), "datasets"))
+ })
+})
+
+test_that("split_by_line()", {
+ expect_equal(split_by_line(""), "")
+ expect_equal(split_by_line("a"), "a")
+ expect_equal(split_by_line("a\n"), c("a", ""))
+ expect_equal(split_by_line("a\nb"), c("a", "b"))
+ expect_equal(split_by_line("a\nb\n"), c("a", "b", ""))
+ expect_equal(split_by_line(c("a", "b")), c("a", "b"))
+ expect_equal(split_by_line(c("a\n", "b")), c("a", "", "b"))
+ expect_equal(split_by_line(c("a", "b\n")), c("a", "b", ""))
+})