diff --git a/.github/workflows/check-standard.yaml b/.github/workflows/check-standard.yaml index 32fa063..5ec6df9 100644 --- a/.github/workflows/check-standard.yaml +++ b/.github/workflows/check-standard.yaml @@ -29,7 +29,7 @@ jobs: R_KEEP_PKG_SOURCE: yes steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v4 - uses: r-lib/actions/setup-pandoc@v2 @@ -41,9 +41,7 @@ jobs: - uses: r-lib/actions/setup-r-dependencies@v2 with: - extra-packages: | - any::rcmdcheck - RConsortium/OOP-WG + extra-packages: any::rcmdcheck needs: check - uses: r-lib/actions/check-r-package@v2 diff --git a/DESCRIPTION b/DESCRIPTION index 47707e2..012b375 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,25 +1,40 @@ Package: sqlr -Title: Build SQL queries for creating/altering tables -Version: 0.0.1.9000 +Title: Represent and Generate SQL Schemas +Version: 0.0.0.9000 Authors@R: c( person("Nicolas", "Bennett", email = "r@nbenn.ch", role = c("aut", "cre"))) Description: - Starting with MardaDB/MySQL and possibly expanding to other SQL dialects, the aim of this package is to help with generating queries for creating and altering tables. + A dialect-independent representation of a relational schema -- tables, + columns, types, constraints and indexes -- that can be built up from R, + rendered as data definition language for a given SQL dialect, and learned + back from a live database. Dialect support is provided by companion + packages. Depends: - R (>= 3.6.0), - R7 (>= 0.0.0.9000) + R (>= 4.1) Imports: - DBI, - methods + S7, + utils Suggests: - testthat (>= 3.0.0), - RPostgres + testthat (>= 3.0.0) URL: https://github.com/nbenn/sqlr BugReports: https://github.com/nbenn/sqlr/issues License: MIT + file LICENSE Encoding: UTF-8 -LazyData: true -RoxygenNote: 7.2.1 -Remotes: - RConsortium/OOP-WG Config/testthat/edition: 3 +Config/roxygen2/version: 8.1.0 +Collate: + 'sqlr-package.R' + 'class_sql.R' + 'class_type.R' + 'type_shorthand.R' + 'class_column.R' + 'class_constraint.R' + 'class_index.R' + 'class_table.R' + 'class_schema.R' + 'class_dialect.R' + 'generics.R' + 'registry.R' + 'order.R' + 'render.R' + 'compare.R' diff --git a/NAMESPACE b/NAMESPACE index 833ae86..f6fb647 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,10 +1,58 @@ # Generated by roxygen2: do not edit by hand -export() -export(int) -export(parse_sql) -export(render_sql) -export(simulate_postgres) -export(smallint) -import(R7) -importFrom(DBI,SQL) +export(as_sqlr_type) +export(sqlr_bigint) +export(sqlr_binary_type) +export(sqlr_blob) +export(sqlr_boolean) +export(sqlr_boolean_type) +export(sqlr_catalog) +export(sqlr_char) +export(sqlr_check) +export(sqlr_column) +export(sqlr_constraint) +export(sqlr_date) +export(sqlr_decimal_type) +export(sqlr_defers_constraints) +export(sqlr_dialect) +export(sqlr_diff) +export(sqlr_double) +export(sqlr_equal) +export(sqlr_float_type) +export(sqlr_for) +export(sqlr_foreign_key) +export(sqlr_identity) +export(sqlr_index) +export(sqlr_index_spec) +export(sqlr_int) +export(sqlr_integer_type) +export(sqlr_json) +export(sqlr_json_type) +export(sqlr_numeric) +export(sqlr_other) +export(sqlr_other_type) +export(sqlr_parse_type) +export(sqlr_primary_key) +export(sqlr_quote) +export(sqlr_quote_literal) +export(sqlr_real) +export(sqlr_reflect) +export(sqlr_reflect_schema) +export(sqlr_register_dialect) +export(sqlr_render) +export(sqlr_render_type) +export(sqlr_schema) +export(sqlr_smallint) +export(sqlr_sql) +export(sqlr_string_type) +export(sqlr_table) +export(sqlr_text) +export(sqlr_time) +export(sqlr_time_type) +export(sqlr_timestamp) +export(sqlr_type) +export(sqlr_unique) +export(sqlr_uuid) +export(sqlr_uuid_type) +export(sqlr_varchar) +import(S7) diff --git a/R/class_column.R b/R/class_column.R new file mode 100644 index 0000000..b515fdb --- /dev/null +++ b/R/class_column.R @@ -0,0 +1,83 @@ +#' Table columns +#' +#' A column of a [sqlr_table()]. `identity` describes an automatically +#' generated key; it is what a dialect maps its `SERIAL`-style spellings onto. +#' +#' @param name Column name. +#' @param type A [sqlr_type], or a string parsed by [as_sqlr_type()]. +#' @param null Whether the column admits `NULL`. A column named in a primary +#' key is forced to `FALSE`, matching what every engine reports back. +#' @param default Default value: a length-one atomic, a [sqlr_sql()] +#' expression, or `NULL` for none. +#' @param description Comment attached to the column. +#' @param identity An [sqlr_identity()], or `NULL`. +#' @param attrs Named list of dialect-specific attributes, ignored by dialects +#' that do not recognise them. +#' @param generated Whether the identity always applies, or yields to a +#' supplied value. +#' @param start,increment Sequence start and step. +#' +#' @return A `sqlr_column` or `sqlr_identity` object. +#' +#' @examples +#' sqlr_column("email", "varchar(255)", null = FALSE) +#' sqlr_column("id", sqlr_bigint(), identity = sqlr_identity()) +#' +#' @export +sqlr_identity <- new_class( + "sqlr_identity", + properties = list( + generated = new_property(class_character, default = "by default"), + start = new_property(class_integer, default = 1L), + increment = new_property(class_integer, default = 1L) + ), + validator = function(self) { + if (!self@generated %in% c("always", "by default")) { + "`generated` must be \"always\" or \"by default\"" + } + } +) + +#' @rdname sqlr_identity +#' @export +sqlr_column <- new_class( + "sqlr_column", + properties = list( + name = class_character, + type = sqlr_type, + null = new_property(class_logical, default = TRUE), + default = new_property(class_any, default = NULL), + description = new_property(class_character, default = NA_character_), + identity = new_property(new_union(NULL, sqlr_identity), default = NULL), + attrs = new_property(class_list, default = quote(list())) + ), + constructor = function(name, type, null = TRUE, default = NULL, + description = NA_character_, identity = NULL, + attrs = list()) { + new_object( + S7_object(), + name = name, + type = as_sqlr_type(type), + null = null, + default = default, + description = description, + identity = identity, + attrs = attrs + ) + }, + validator = function(self) { + if (length(self@name) != 1L || is.na(self@name)) { + return("`name` must be a string") + } + if (length(self@null) != 1L || is.na(self@null)) { + return("`null` must be TRUE or FALSE") + } + if (!valid_default(self@default)) { + "`default` must be NULL, a length-one atomic, or a sqlr_sql()" + } + } +) + +valid_default <- function(x) { + is.null(x) || S7_inherits(x, sqlr_sql) || (is.atomic(x) && length(x) == 1L) +} diff --git a/R/class_con.R b/R/class_con.R deleted file mode 100644 index 1832d96..0000000 --- a/R/class_con.R +++ /dev/null @@ -1,16 +0,0 @@ - -if (requireNamespace("RPostgres", quietly = TRUE)) { - con_pq <- methods::getClass("PqConnection", where = "RPostgres") -} else { - methods::setClass("PqConnection", - contains = methods::getClass("DBIConnection", where = "DBI") - ) - con_pq <- methods::getClass("PqConnection") -} - - -#' Dummy connection object for PostgreSQL -#' @export -simulate_postgres <- function() { - methods::new("PqConnection") -} diff --git a/R/class_constraint.R b/R/class_constraint.R new file mode 100644 index 0000000..1e75354 --- /dev/null +++ b/R/class_constraint.R @@ -0,0 +1,184 @@ +#' Table constraints +#' +#' Primary keys and unique constraints own an [sqlr_index_spec()] describing +#' the index that backs them, rather than being modelled as indexes carrying a +#' flag. This mirrors the database catalogue, where the constraint owns its +#' supporting index, so a reflected schema maps onto the same shape. +#' +#' Constraint identity is structural -- the columns, referenced target or +#' expression. `name` is a renderable attribute, so a schema authored here and +#' the same schema read back from a database compare equal even when the +#' engine chose its own names. +#' +#' @param name Constraint name. `NA` leaves naming to the dialect. +#' @param columns Names of the constrained columns. +#' @param ref_table,ref_schema,ref_columns Foreign key target. +#' @param on_delete,on_update Referential action: one of `"no action"`, +#' `"restrict"`, `"cascade"`, `"set null"` or `"set default"`. +#' @param expr Check expression, as a string or [sqlr_sql()]. +#' @param spec An [sqlr_index_spec()] describing the backing index. +#' @param method Index method, such as `"btree"`. +#' @param include Non-key columns carried in the index. +#' @param where Partial index predicate. +#' @param description Comment attached to the constraint. +#' @param attrs Named list of dialect-specific attributes. +#' +#' @return An object inheriting from `sqlr_constraint`. +#' +#' @examples +#' sqlr_primary_key("id") +#' sqlr_foreign_key("user_id", "users", "id", on_delete = "cascade") +#' sqlr_check("total > 0", name = "orders_total_check") +#' +#' @name sqlr_constraint +NULL + +#' @rdname sqlr_constraint +#' @export +sqlr_index_spec <- new_class( + "sqlr_index_spec", + properties = list( + method = new_property(class_character, default = NA_character_), + include = new_property(class_character, default = quote(character())), + where = new_property(new_union(NULL, sqlr_sql), default = NULL), + attrs = new_property(class_list, default = quote(list())) + ) +) + +#' @rdname sqlr_constraint +#' @export +sqlr_constraint <- new_class( + "sqlr_constraint", + abstract = TRUE, + properties = list( + name = new_property(class_character, default = NA_character_), + description = new_property(class_character, default = NA_character_), + attrs = new_property(class_list, default = quote(list())) + ) +) + +#' @rdname sqlr_constraint +#' @export +sqlr_primary_key <- new_class( + "sqlr_primary_key", + parent = sqlr_constraint, + properties = list( + columns = class_character, + spec = new_property(sqlr_index_spec, default = quote(sqlr_index_spec())) + ), + constructor = function(columns, name = NA_character_, + spec = sqlr_index_spec(), + description = NA_character_, attrs = list()) { + new_object( + S7_object(), + name = name, + description = description, + attrs = attrs, + columns = columns, + spec = spec + ) + }, + validator = function(self) { + if (!length(self@columns)) "`columns` must name at least one column" + } +) + +#' @rdname sqlr_constraint +#' @export +sqlr_unique <- new_class( + "sqlr_unique", + parent = sqlr_constraint, + properties = list( + columns = class_character, + spec = new_property(sqlr_index_spec, default = quote(sqlr_index_spec())) + ), + constructor = function(columns, name = NA_character_, + spec = sqlr_index_spec(), + description = NA_character_, attrs = list()) { + new_object( + S7_object(), + name = name, + description = description, + attrs = attrs, + columns = columns, + spec = spec + ) + }, + validator = function(self) { + if (!length(self@columns)) "`columns` must name at least one column" + } +) + +referential_actions <- c( + "no action", "restrict", "cascade", "set null", "set default" +) + +#' @rdname sqlr_constraint +#' @export +sqlr_foreign_key <- new_class( + "sqlr_foreign_key", + parent = sqlr_constraint, + properties = list( + columns = class_character, + ref_table = class_character, + ref_columns = class_character, + ref_schema = new_property(class_character, default = NA_character_), + on_delete = new_property(class_character, default = "no action"), + on_update = new_property(class_character, default = "no action") + ), + constructor = function(columns, ref_table, ref_columns, + ref_schema = NA_character_, + on_delete = "no action", on_update = "no action", + name = NA_character_, description = NA_character_, + attrs = list()) { + new_object( + S7_object(), + name = name, + description = description, + attrs = attrs, + columns = columns, + ref_table = ref_table, + ref_columns = ref_columns, + ref_schema = ref_schema, + on_delete = tolower(on_delete), + on_update = tolower(on_update) + ) + }, + validator = function(self) { + if (!length(self@columns)) { + return("`columns` must name at least one column") + } + if (length(self@columns) != length(self@ref_columns)) { + return("`columns` and `ref_columns` must be the same length") + } + if (length(self@ref_table) != 1L || is.na(self@ref_table)) { + return("`ref_table` must be a string") + } + bad <- setdiff(c(self@on_delete, self@on_update), referential_actions) + if (length(bad)) { + paste0( + "referential action must be one of ", + paste0("\"", referential_actions, "\"", collapse = ", ") + ) + } + } +) + +#' @rdname sqlr_constraint +#' @export +sqlr_check <- new_class( + "sqlr_check", + parent = sqlr_constraint, + properties = list(expr = sqlr_sql), + constructor = function(expr, name = NA_character_, + description = NA_character_, attrs = list()) { + if (!S7_inherits(expr, sqlr_sql)) expr <- sqlr_sql(text = expr) + new_object( + S7_object(), + name = name, + description = description, + attrs = attrs, + expr = expr + ) + } +) diff --git a/R/class_dialect.R b/R/class_dialect.R new file mode 100644 index 0000000..9d3ddf3 --- /dev/null +++ b/R/class_dialect.R @@ -0,0 +1,26 @@ +#' SQL dialects +#' +#' A dialect is what rendering and reflection dispatch on. It is deliberately +#' not the connection: a dialect object can be built without a driver package +#' installed, which keeps sqlr free of database dependencies and lets the whole +#' test suite run with no server. +#' +#' `sqlr_dialect` is abstract. It carries the rendering every engine shares, +#' which concrete dialects in companion packages inherit and override. It is +#' never instantiated and never used as a fallback, so there is no generic +#' pseudo-dialect emitting SQL that no engine has been tested against. +#' +#' @param version Engine version, governing version-dependent rendering. +#' @param attrs Named list of dialect-specific attributes. +#' +#' @return An object inheriting from `sqlr_dialect`. +#' +#' @export +sqlr_dialect <- new_class( + "sqlr_dialect", + abstract = TRUE, + properties = list( + version = new_property(class_character, default = NA_character_), + attrs = new_property(class_list, default = quote(list())) + ) +) diff --git a/R/class_index.R b/R/class_index.R new file mode 100644 index 0000000..4ef16d1 --- /dev/null +++ b/R/class_index.R @@ -0,0 +1,55 @@ +#' Standalone indexes +#' +#' An index that is not backing a constraint. Indexes created implicitly by a +#' primary key or unique constraint belong to that constraint's +#' [sqlr_index_spec()] and are not reported here by [sqlr_reflect()]. +#' +#' @param name Index name. +#' @param columns Indexed column names. +#' @param desc Per-column descending flags, recycled to `columns`. +#' @param unique Whether the index enforces uniqueness. +#' @param spec An [sqlr_index_spec()] describing method, includes and +#' predicate. +#' @param description Comment attached to the index. +#' @param attrs Named list of dialect-specific attributes. +#' +#' @return A `sqlr_index` object. +#' +#' @examples +#' sqlr_index("val", name = "orders_val_idx") +#' +#' @export +sqlr_index <- new_class( + "sqlr_index", + properties = list( + name = new_property(class_character, default = NA_character_), + columns = class_character, + desc = new_property(class_logical, default = quote(logical())), + unique = new_property(class_logical, default = FALSE), + spec = new_property(sqlr_index_spec, default = quote(sqlr_index_spec())), + description = new_property(class_character, default = NA_character_), + attrs = new_property(class_list, default = quote(list())) + ), + constructor = function(columns, name = NA_character_, desc = FALSE, + unique = FALSE, spec = sqlr_index_spec(), + description = NA_character_, attrs = list()) { + new_object( + S7_object(), + name = name, + columns = columns, + desc = rep_len(desc, length(columns)), + unique = unique, + spec = spec, + description = description, + attrs = attrs + ) + }, + validator = function(self) { + if (!length(self@columns)) { + return("`columns` must name at least one column") + } + if (length(self@desc) != length(self@columns)) { + "`desc` must be the same length as `columns`" + } + } +) diff --git a/R/class_int.R b/R/class_int.R deleted file mode 100644 index 798c257..0000000 --- a/R/class_int.R +++ /dev/null @@ -1,16 +0,0 @@ - -#' Integer types -#' @param .data R7 doc -#' @export -int <- new_class("int", parent = class_integer) - -#' @rdname int -#' @export -smallint <- new_class("smallint", parent = class_integer, - validator = function(self) { - dat <- R7_data(self) - if (any(dat < -32768L) || any(dat > 32767L)) { - "value range exceeded" - } - } -) diff --git a/R/class_schema.R b/R/class_schema.R new file mode 100644 index 0000000..085dd6b --- /dev/null +++ b/R/class_schema.R @@ -0,0 +1,66 @@ +#' Schemas and catalogues +#' +#' A schema is a named collection of tables; a catalogue holds several schemas, +#' which is what [sqlr_reflect()] returns when asked for more than one and what +#' cross-schema foreign keys resolve against. +#' +#' @param name Schema name. +#' @param ... [sqlr_table()]s, or [sqlr_schema()]s for `sqlr_catalog()`. +#' @param description Comment attached to the schema. +#' @param attrs Named list of dialect-specific attributes. +#' +#' @return A `sqlr_schema` or `sqlr_catalog` object. +#' +#' @examples +#' sqlr_schema("public", sqlr_table("t", sqlr_column("id", sqlr_int()))) +#' +#' @export +sqlr_schema <- new_class( + "sqlr_schema", + properties = list( + name = new_property(class_character, default = NA_character_), + tables = new_property(class_list, default = quote(list())), + description = new_property(class_character, default = NA_character_), + attrs = new_property(class_list, default = quote(list())) + ), + constructor = function(name = NA_character_, ..., + description = NA_character_, attrs = list()) { + new_object( + S7_object(), + name = name, + tables = keep_class(list(...), sqlr_table), + description = description, + attrs = attrs + ) + }, + validator = function(self) { + nms <- table_names(self) + if (anyDuplicated(nms)) "table names must be unique" + } +) + +#' @rdname sqlr_schema +#' @export +sqlr_catalog <- new_class( + "sqlr_catalog", + properties = list( + schemas = new_property(class_list, default = quote(list())), + attrs = new_property(class_list, default = quote(list())) + ), + constructor = function(..., attrs = list()) { + new_object( + S7_object(), + schemas = keep_class(list(...), sqlr_schema), + attrs = attrs + ) + } +) + +table_names <- function(x) { + vapply(x@tables, function(tbl) tbl@name, character(1L)) +} + +schema_table <- function(x, name) { + hit <- match(name, table_names(x)) + if (is.na(hit)) NULL else x@tables[[hit]] +} diff --git a/R/class_sql.R b/R/class_sql.R new file mode 100644 index 0000000..943d49b --- /dev/null +++ b/R/class_sql.R @@ -0,0 +1,29 @@ +#' Verbatim SQL +#' +#' Wraps a string that is to be emitted as-is, without quoting or escaping. +#' Accepted anywhere a value, expression or type may appear. +#' +#' @param text String of SQL. +#' +#' @return An object of class `sqlr_sql`. +#' +#' @examples +#' sqlr_sql("now()") +#' +#' @export +sqlr_sql <- new_class( + "sqlr_sql", + properties = list(text = class_character), + validator = function(self) { + if (length(self@text) != 1L || is.na(self@text)) "`text` must be a string" + } +) + +method(print, sqlr_sql) <- function(x, ...) { + cat(" ", x@text, "\n", sep = "") + invisible(x) +} + +as_sql_text <- function(x) { + if (S7_inherits(x, sqlr_sql)) x@text else as.character(x) +} diff --git a/R/class_table.R b/R/class_table.R new file mode 100644 index 0000000..b97335c --- /dev/null +++ b/R/class_table.R @@ -0,0 +1,96 @@ +#' Tables +#' +#' Columns, constraints and indexes are passed positionally in any order. +#' Columns named in a primary key have `null` forced to `FALSE`, which the SQL +#' standard implies and every engine reports back, so an authored table +#' compares equal to its own reflection. +#' +#' @param name Table name. +#' @param ... [sqlr_column()]s, [sqlr_constraint]s and [sqlr_index()]es. +#' @param description Comment attached to the table. +#' @param attrs Named list of dialect-specific attributes. +#' +#' @return A `sqlr_table` object. +#' +#' @examples +#' sqlr_table( +#' "users", +#' sqlr_column("id", sqlr_bigint()), +#' sqlr_column("email", "varchar(255)", null = FALSE), +#' sqlr_primary_key("id") +#' ) +#' +#' @export +sqlr_table <- new_class( + "sqlr_table", + properties = list( + name = class_character, + columns = new_property(class_list, default = quote(list())), + constraints = new_property(class_list, default = quote(list())), + indexes = new_property(class_list, default = quote(list())), + description = new_property(class_character, default = NA_character_), + attrs = new_property(class_list, default = quote(list())) + ), + constructor = function(name, ..., description = NA_character_, + attrs = list()) { + parts <- list(...) + new_object( + S7_object(), + name = name, + columns = imply_not_null( + keep_class(parts, sqlr_column), + keep_class(parts, sqlr_constraint) + ), + constraints = keep_class(parts, sqlr_constraint), + indexes = keep_class(parts, sqlr_index), + description = description, + attrs = attrs + ) + }, + validator = function(self) { + if (length(self@name) != 1L || is.na(self@name)) { + return("`name` must be a string") + } + + nms <- column_names(self) + if (anyDuplicated(nms)) { + return("column names must be unique") + } + + unknown <- setdiff(constrained_columns(self), nms) + if (length(unknown)) { + paste0( + "constraints and indexes name unknown columns: ", + paste0(unknown, collapse = ", ") + ) + } + } +) + +keep_class <- function(x, cls) { + x[vapply(x, S7_inherits, logical(1L), class = cls)] +} + +column_names <- function(x) { + vapply(x@columns, function(col) col@name, character(1L)) +} + +constrained_columns <- function(x) { + from_constraints <- lapply(x@constraints, function(con) { + if (S7_inherits(con, sqlr_check)) character() else con@columns + }) + unique(unlist(c(from_constraints, lapply(x@indexes, function(i) i@columns)))) +} + +imply_not_null <- function(columns, constraints) { + keys <- keep_class(constraints, sqlr_primary_key) + if (!length(keys)) { + return(columns) + } + + key_columns <- unlist(lapply(keys, function(k) k@columns)) + lapply(columns, function(col) { + if (col@name %in% key_columns) col@null <- FALSE + col + }) +} diff --git a/R/class_type.R b/R/class_type.R new file mode 100644 index 0000000..7b213e4 --- /dev/null +++ b/R/class_type.R @@ -0,0 +1,259 @@ +#' SQL column types +#' +#' A dialect-independent description of a column's type. Each dialect maps +#' these onto its own spelling when rendering, and back again when reflecting. +#' `raw` carries the verbatim spelling a database reported, and is set by +#' [sqlr_reflect()] rather than by hand. +#' +#' `sqlr_other()` carries a type sqlr does not model. It renders verbatim and +#' survives a round trip, but nothing can be inferred about it. +#' +#' @param bytes Width of an integer or float type. +#' @param unsigned Whether an integer type is unsigned. +#' @param size Length of a character or binary type; `NA` for unbounded. +#' @param fixed Whether a character or binary type is blank-padded. +#' @param precision,scale Total digits and digits after the decimal point. +#' @param kind Whether a time type is a `"date"`, `"time"` or `"timestamp"`. +#' @param with_timezone Whether a time type carries a time zone. +#' @param binary Whether JSON is stored in a decomposed binary form. +#' @param name Name of an unmodelled type. +#' @param raw Verbatim type spelling as reported by a database. +#' +#' @return An object inheriting from `sqlr_type`. +#' +#' @examples +#' sqlr_varchar(255) +#' sqlr_numeric(10, 2) +#' sqlr_timestamp(with_timezone = TRUE) +#' +#' @name sqlr_type +NULL + +#' @rdname sqlr_type +#' @export +sqlr_type <- new_class( + "sqlr_type", + abstract = TRUE, + properties = list( + raw = new_property(class_character, default = NA_character_) + ), + validator = function(self) { + if (length(self@raw) != 1L) "`raw` must be a string" + } +) + +#' @rdname sqlr_type +#' @export +sqlr_integer_type <- new_class( + "sqlr_integer_type", + parent = sqlr_type, + properties = list( + bytes = new_property(class_integer, default = 4L), + unsigned = new_property(class_logical, default = FALSE) + ), + validator = function(self) { + if (!self@bytes %in% c(1L, 2L, 4L, 8L)) "`bytes` must be 1, 2, 4 or 8" + } +) + +#' @rdname sqlr_type +#' @export +sqlr_float_type <- new_class( + "sqlr_float_type", + parent = sqlr_type, + properties = list(bytes = new_property(class_integer, default = 8L)), + validator = function(self) { + if (!self@bytes %in% c(4L, 8L)) "`bytes` must be 4 or 8" + } +) + +#' @rdname sqlr_type +#' @export +sqlr_decimal_type <- new_class( + "sqlr_decimal_type", + parent = sqlr_type, + properties = list( + precision = new_property(class_integer, default = NA_integer_), + scale = new_property(class_integer, default = NA_integer_) + ) +) + +#' @rdname sqlr_type +#' @export +sqlr_string_type <- new_class( + "sqlr_string_type", + parent = sqlr_type, + properties = list( + size = new_property(class_integer, default = NA_integer_), + fixed = new_property(class_logical, default = FALSE) + ) +) + +#' @rdname sqlr_type +#' @export +sqlr_binary_type <- new_class( + "sqlr_binary_type", + parent = sqlr_type, + properties = list( + size = new_property(class_integer, default = NA_integer_), + fixed = new_property(class_logical, default = FALSE) + ) +) + +#' @rdname sqlr_type +#' @export +sqlr_boolean_type <- new_class("sqlr_boolean_type", parent = sqlr_type) + +#' @rdname sqlr_type +#' @export +sqlr_time_type <- new_class( + "sqlr_time_type", + parent = sqlr_type, + properties = list( + kind = new_property(class_character, default = "timestamp"), + with_timezone = new_property(class_logical, default = FALSE), + precision = new_property(class_integer, default = NA_integer_) + ), + validator = function(self) { + if (!self@kind %in% c("date", "time", "timestamp")) { + "`kind` must be \"date\", \"time\" or \"timestamp\"" + } + } +) + +#' @rdname sqlr_type +#' @export +sqlr_json_type <- new_class( + "sqlr_json_type", + parent = sqlr_type, + properties = list(binary = new_property(class_logical, default = FALSE)) +) + +#' @rdname sqlr_type +#' @export +sqlr_uuid_type <- new_class("sqlr_uuid_type", parent = sqlr_type) + +#' @rdname sqlr_type +#' @export +sqlr_other_type <- new_class( + "sqlr_other_type", + parent = sqlr_type, + properties = list(name = class_character), + validator = function(self) { + if (length(self@name) != 1L || is.na(self@name)) "`name` must be a string" + } +) + +#' @rdname sqlr_type +#' @export +sqlr_smallint <- function(unsigned = FALSE, raw = NA_character_) { + sqlr_integer_type(bytes = 2L, unsigned = unsigned, raw = raw) +} + +#' @rdname sqlr_type +#' @export +sqlr_int <- function(unsigned = FALSE, raw = NA_character_) { + sqlr_integer_type(bytes = 4L, unsigned = unsigned, raw = raw) +} + +#' @rdname sqlr_type +#' @export +sqlr_bigint <- function(unsigned = FALSE, raw = NA_character_) { + sqlr_integer_type(bytes = 8L, unsigned = unsigned, raw = raw) +} + +#' @rdname sqlr_type +#' @export +sqlr_real <- function(raw = NA_character_) { + sqlr_float_type(bytes = 4L, raw = raw) +} + +#' @rdname sqlr_type +#' @export +sqlr_double <- function(raw = NA_character_) { + sqlr_float_type(bytes = 8L, raw = raw) +} + +#' @rdname sqlr_type +#' @export +sqlr_numeric <- function(precision = NA, scale = NA, raw = NA_character_) { + sqlr_decimal_type( + precision = as.integer(precision), + scale = as.integer(scale), + raw = raw + ) +} + +#' @rdname sqlr_type +#' @export +sqlr_varchar <- function(size = NA, raw = NA_character_) { + sqlr_string_type(size = as.integer(size), fixed = FALSE, raw = raw) +} + +#' @rdname sqlr_type +#' @export +sqlr_char <- function(size = NA, raw = NA_character_) { + sqlr_string_type(size = as.integer(size), fixed = TRUE, raw = raw) +} + +#' @rdname sqlr_type +#' @export +sqlr_text <- function(raw = NA_character_) { + sqlr_string_type(size = NA_integer_, fixed = FALSE, raw = raw) +} + +#' @rdname sqlr_type +#' @export +sqlr_blob <- function(size = NA, raw = NA_character_) { + sqlr_binary_type(size = as.integer(size), raw = raw) +} + +#' @rdname sqlr_type +#' @export +sqlr_boolean <- function(raw = NA_character_) sqlr_boolean_type(raw = raw) + +#' @rdname sqlr_type +#' @export +sqlr_date <- function(raw = NA_character_) { + sqlr_time_type(kind = "date", raw = raw) +} + +#' @rdname sqlr_type +#' @export +sqlr_time <- function(with_timezone = FALSE, precision = NA, + raw = NA_character_) { + sqlr_time_type( + kind = "time", + with_timezone = with_timezone, + precision = as.integer(precision), + raw = raw + ) +} + +#' @rdname sqlr_type +#' @export +sqlr_timestamp <- function(with_timezone = FALSE, precision = NA, + raw = NA_character_) { + sqlr_time_type( + kind = "timestamp", + with_timezone = with_timezone, + precision = as.integer(precision), + raw = raw + ) +} + +#' @rdname sqlr_type +#' @export +sqlr_json <- function(binary = FALSE, raw = NA_character_) { + sqlr_json_type(binary = binary, raw = raw) +} + +#' @rdname sqlr_type +#' @export +sqlr_uuid <- function(raw = NA_character_) sqlr_uuid_type(raw = raw) + +#' @rdname sqlr_type +#' @export +sqlr_other <- function(name, raw = NA_character_) { + sqlr_other_type(name = name, raw = raw) +} diff --git a/R/compare.R b/R/compare.R new file mode 100644 index 0000000..a8a58a8 --- /dev/null +++ b/R/compare.R @@ -0,0 +1,169 @@ +#' Compare two schemas +#' +#' Compares structurally rather than by identity: constraints and indexes are +#' matched on what they constrain, not on their order or their names, and the +#' verbatim type spelling a database reported is ignored. This is what lets a +#' schema authored in R be compared against the same schema read back out of a +#' database with [sqlr_reflect()]. +#' +#' Check constraints are matched by name where both carry one. Their +#' expressions are not compared: engines rewrite them on the way in, inserting +#' casts that depend on the column's type, and undoing that reliably would take +#' a full expression parser. +#' +#' @param x,y Objects to compare. +#' +#' @return `sqlr_diff()` a character vector of differences, empty when equal; +#' `sqlr_equal()` a flag. +#' +#' @examples +#' a <- sqlr_table("t", sqlr_column("id", sqlr_int())) +#' sqlr_equal(a, a) +#' +#' @export +sqlr_diff <- function(x, y) { + out <- if (S7_inherits(x, sqlr_schema)) { + diff_schema(x, y) + } else if (S7_inherits(x, sqlr_table)) { + diff_table(x, y, "") + } else { + stop("`x` must be a sqlr_schema or sqlr_table", call. = FALSE) + } + + if (is.null(out)) character() else out +} + +#' @rdname sqlr_diff +#' @export +sqlr_equal <- function(x, y) length(sqlr_diff(x, y)) == 0L + +diff_schema <- function(x, y) { + in_x <- table_names(x) + in_y <- table_names(y) + + out <- c( + if (length(setdiff(in_x, in_y))) { + paste0("missing tables: ", paste0(setdiff(in_x, in_y), collapse = ", ")) + }, + if (length(setdiff(in_y, in_x))) { + paste0("extra tables: ", paste0(setdiff(in_y, in_x), collapse = ", ")) + } + ) + + shared <- intersect(in_x, in_y) + c(out, unlist(lapply(shared, function(nm) { + diff_table(schema_table(x, nm), schema_table(y, nm), paste0(nm, ": ")) + }))) +} + +diff_table <- function(x, y, prefix) { + c( + diff_columns(x, y, prefix), + diff_set( + constraint_keys(x@constraints), constraint_keys(y@constraints), + prefix, "constraint" + ), + diff_set(index_keys(x@indexes), index_keys(y@indexes), prefix, "index") + ) +} + +diff_columns <- function(x, y, prefix) { + in_x <- column_names(x) + in_y <- column_names(y) + + if (!identical(in_x, in_y)) { + return(paste0( + prefix, "columns differ: [", paste0(in_x, collapse = ", "), + "] vs [", paste0(in_y, collapse = ", "), "]" + )) + } + + unlist(lapply(seq_along(x@columns), function(i) { + diff_column(x@columns[[i]], y@columns[[i]], prefix) + })) +} + +diff_column <- function(x, y, prefix) { + where <- paste0(prefix, "column ", x@name, ": ") + + c( + if (!identical(type_key(x@type), type_key(y@type))) { + paste0(where, "type ", type_key(x@type), " vs ", type_key(y@type)) + }, + if (!identical(x@null, y@null)) { + paste0(where, "null ", x@null, " vs ", y@null) + }, + if (!identical(default_key(x@default), default_key(y@default))) { + paste0( + where, "default ", default_key(x@default), " vs ", + default_key(y@default) + ) + }, + if (!identical(is.null(x@identity), is.null(y@identity))) { + paste0(where, "identity present on one side only") + } + ) +} + +type_key <- function(x) { + props <- setdiff(names(props(x)), "raw") + paste0( + class(x)[[1L]], "(", + paste0( + props, "=", + vapply(props, function(p) paste0(prop(x, p), collapse = "/"), character(1L)), + collapse = ", " + ), + ")" + ) +} + +default_key <- function(x) { + if (is.null(x)) "none" else as_sql_text(x) +} + +constraint_keys <- function(constraints) { + sort(vapply(constraints, constraint_key, character(1L))) +} + +constraint_key <- function(x) { + if (S7_inherits(x, sqlr_primary_key)) { + paste0("primary_key(", paste0(x@columns, collapse = ","), ")") + } else if (S7_inherits(x, sqlr_unique)) { + paste0("unique(", paste0(x@columns, collapse = ","), ")") + } else if (S7_inherits(x, sqlr_foreign_key)) { + paste0( + "foreign_key(", paste0(x@columns, collapse = ","), "->", + x@ref_table, "(", paste0(x@ref_columns, collapse = ","), ")", + ",on_delete=", x@on_delete, ",on_update=", x@on_update, ")" + ) + } else { + paste0("check(", if (is.na(x@name)) x@expr@text else x@name, ")") + } +} + +index_keys <- function(indexes) { + sort(vapply( + indexes, + function(x) { + paste0( + if (x@unique) "unique_index(" else "index(", + paste0(x@columns, ifelse(x@desc, " desc", ""), collapse = ","), ")" + ) + }, + character(1L) + )) +} + +diff_set <- function(in_x, in_y, prefix, label) { + c( + if (length(setdiff(in_x, in_y))) { + paste0(prefix, "missing ", label, ": ", + paste0(setdiff(in_x, in_y), collapse = "; ")) + }, + if (length(setdiff(in_y, in_x))) { + paste0(prefix, "extra ", label, ": ", + paste0(setdiff(in_y, in_x), collapse = "; ")) + } + ) +} diff --git a/R/generics.R b/R/generics.R index 93e39c4..c7915fd 100644 --- a/R/generics.R +++ b/R/generics.R @@ -1,31 +1,100 @@ - -#' Generate SQL +#' Render SQL +#' +#' Emits data definition language for `x` in the dialect `dialect`. #' -#' For a given SQL dialect determined by `con`, SQL is generated corresponding -#' to the object passed as `x`. +#' Rendering a schema is not rendering each table in turn. Foreign keys can +#' form cycles -- a self-reference, or two tables pointing at each other -- so +#' the tables are ordered by dependency and any foreign key that would close a +#' cycle is hoisted out into a trailing `ALTER TABLE`. Rendering a single table +#' emits only what that table can state on its own. #' -#' @param x Object -#' @param con Database connection -#' @param ... Generic consistency +#' @param x Object to render. +#' @param dialect A [sqlr_dialect]. +#' @param ... Passed to methods. #' -#' @return SQL string +#' @return A character vector of statements. #' #' @examples -#' render_sql(smallint(), simulate_postgres()) +#' # needs a dialect package, e.g. +#' # sqlr_render(schema, sqlr.postgres::postgres()) +#' +#' @export +sqlr_render <- new_generic("sqlr_render", c("x", "dialect")) + +#' Map between sqlr types and dialect spellings +#' +#' Every dialect owes both directions: reflection has to arrive at the same +#' type object that authoring produced, or an authored schema will never +#' compare equal to the one read back. +#' +#' @param type A [sqlr_type]. +#' @param dialect A [sqlr_dialect]. +#' @param ... Passed to methods; `sqlr_parse_type()` takes the type spelling +#' reported by the database catalogue this way. +#' +#' @return `sqlr_render_type()` a string; `sqlr_parse_type()` a [sqlr_type]. +#' +#' @export +sqlr_render_type <- new_generic("sqlr_render_type", c("type", "dialect")) + +#' @rdname sqlr_render_type +#' @export +sqlr_parse_type <- new_generic("sqlr_parse_type", "dialect") + +#' Quote identifiers and literals #' +#' @param dialect A [sqlr_dialect]. +#' @param ... The identifier or literal to quote, passed to methods. +#' +#' @return A string. +#' +#' @export +sqlr_quote <- new_generic("sqlr_quote", "dialect") + +#' @rdname sqlr_quote +#' @export +sqlr_quote_literal <- new_generic("sqlr_quote_literal", "dialect") + +#' Learn a schema from a database +#' +#' Reads the catalogue of a live database and returns the same representation +#' [sqlr_render()] consumes, so a schema can be rendered, executed and read +#' back for comparison. +#' +#' A dialect must return canonical form: constraint-backed indexes dropped, +#' type spellings collapsed onto [sqlr_type] objects, macro types such as +#' `SERIAL` decomposed, and any casts the engine inserted stripped. Comparison +#' is then plain equality rather than a pile of special cases. +#' +#' @param con A `DBIConnection`. +#' @param schema Schema name to read; `NULL` for the connection default. +#' @param dialect A [sqlr_dialect]; resolved from `con` by default. +#' @param ... Passed to methods. +#' +#' @return A [sqlr_schema()]. +#' +#' @export +sqlr_reflect <- function(con, schema = NULL, dialect = sqlr_for(con), ...) { + sqlr_reflect_schema(dialect, con, schema = schema, ...) +} + +#' @rdname sqlr_reflect #' @export -render_sql <- new_generic("render_sql", c("x", "con")) +sqlr_reflect_schema <- new_generic("sqlr_reflect_schema", "dialect") -#' Parse SQL +#' Whether a dialect can add constraints after the fact #' -#' The inverse operation as [render_sql()], i.e. instantiating an {sqlr} object -#' from an SQL string. +#' Governs how foreign key cycles are broken. Where `TRUE`, a foreign key that +#' would close a cycle is hoisted out of `CREATE TABLE` into a trailing +#' `ALTER TABLE ... ADD CONSTRAINT`, and tables are emitted in dependency +#' order. Where `FALSE` -- SQLite being the case in point, since it has no +#' `ADD CONSTRAINT` -- every constraint stays inline and no ordering is +#' attempted, which is safe on engines that permit forward references. #' -#' @param x SQL string -#' @param con Database connection -#' @param ... Generic consistency +#' @param dialect A [sqlr_dialect]. +#' @param ... Passed to methods. #' -#' @return {sqlr} object +#' @return A flag. #' #' @export -parse_sql <- new_generic("parse_sql", c("x", "con")) +sqlr_defers_constraints <- new_generic("sqlr_defers_constraints", "dialect") diff --git a/R/order.R b/R/order.R new file mode 100644 index 0000000..0eacdd5 --- /dev/null +++ b/R/order.R @@ -0,0 +1,78 @@ +dependency_matrix <- function(schema) { + nms <- table_names(schema) + n <- length(nms) + m <- matrix(FALSE, n, n, dimnames = list(nms, nms)) + + for (i in seq_len(n)) { + for (fk in keep_class(schema@tables[[i]]@constraints, sqlr_foreign_key)) { + j <- match(fk@ref_table, nms) + if (!is.na(j)) m[i, j] <- TRUE + } + } + + m +} + +reachability <- function(m) { + for (k in seq_len(nrow(m))) { + for (i in seq_len(nrow(m))) { + if (m[i, k]) m[i, ] <- m[i, ] | m[k, ] + } + } + + m +} + +cyclic_foreign_keys <- function(schema) { + nms <- table_names(schema) + reach <- reachability(dependency_matrix(schema)) + + lapply(seq_along(schema@tables), function(i) { + vapply( + schema@tables[[i]]@constraints, + function(con) { + if (!S7_inherits(con, sqlr_foreign_key)) { + return(FALSE) + } + j <- match(con@ref_table, nms) + !is.na(j) && (j == i || reach[j, i]) + }, + logical(1L) + ) + }) +} + +table_order <- function(schema, hoisted) { + nms <- table_names(schema) + n <- length(nms) + + deps <- lapply(seq_len(n), function(i) { + inline <- schema@tables[[i]]@constraints[!hoisted[[i]]] + targets <- vapply( + keep_class(inline, sqlr_foreign_key), + function(fk) fk@ref_table, + character(1L) + ) + setdiff(match(intersect(targets, nms), nms), i) + }) + + ordered <- integer() + pending <- seq_len(n) + + while (length(pending)) { + ready <- pending[vapply( + pending, + function(i) all(deps[[i]] %in% ordered), + logical(1L) + )] + + if (!length(ready)) { + ready <- pending[[1L]] + } + + ordered <- c(ordered, ready) + pending <- setdiff(pending, ready) + } + + ordered +} diff --git a/R/registry.R b/R/registry.R new file mode 100644 index 0000000..da4abb7 --- /dev/null +++ b/R/registry.R @@ -0,0 +1,43 @@ +dialect_registry <- new.env(parent = emptyenv()) + +#' Register a dialect for a connection class +#' +#' Called by dialect packages from `.onLoad()`, so that [sqlr_for()] can +#' resolve a connection sqlr itself knows nothing about. +#' +#' @param connection_class Name of the `DBIConnection` subclass. +#' @param factory Function of one argument, the connection, returning a +#' [sqlr_dialect]. +#' @param con A `DBIConnection`. +#' +#' @return `sqlr_register_dialect()` returns `NULL` invisibly; `sqlr_for()` +#' returns a [sqlr_dialect]. +#' +#' @export +sqlr_register_dialect <- function(connection_class, factory) { + stopifnot(is.character(connection_class), is.function(factory)) + assign(connection_class, factory, envir = dialect_registry) + invisible(NULL) +} + +#' @rdname sqlr_register_dialect +#' @export +sqlr_for <- function(con) { + for (cls in class(con)) { + if (exists(cls, envir = dialect_registry, inherits = FALSE)) { + return(get(cls, envir = dialect_registry)(con)) + } + } + + known <- ls(dialect_registry) + stop( + "no sqlr dialect registered for a connection of class \"", + class(con)[[1L]], "\".\n", + if (length(known)) { + paste0("Registered: ", paste0(known, collapse = ", "), ".") + } else { + "Load a dialect package such as sqlr.postgres or sqlr.sqlite." + }, + call. = FALSE + ) +} diff --git a/R/render.R b/R/render.R new file mode 100644 index 0000000..4808253 --- /dev/null +++ b/R/render.R @@ -0,0 +1,203 @@ +method(sqlr_defers_constraints, sqlr_dialect) <- function(dialect, ...) TRUE + +method(sqlr_quote, sqlr_dialect) <- function(dialect, x, ...) { + paste0("\"", gsub("\"", "\"\"", x, fixed = TRUE), "\"") +} + +method(sqlr_quote_literal, sqlr_dialect) <- function(dialect, x, ...) { + if (is.null(x) || (length(x) == 1L && is.na(x))) { + return("NULL") + } + if (is.logical(x)) { + return(if (x) "TRUE" else "FALSE") + } + if (is.numeric(x)) { + return(format(x, scientific = FALSE, trim = TRUE)) + } + paste0("'", gsub("'", "''", as.character(x), fixed = TRUE), "'") +} + +method(sqlr_render, list(sqlr_column, sqlr_dialect)) <- + function(x, dialect, ...) { + parts <- c(sqlr_quote(dialect, x@name), sqlr_render_type(x@type, dialect)) + + if (!is.null(x@identity)) { + parts <- c(parts, render_identity(x@identity, dialect)) + } + + if (!x@null) { + parts <- c(parts, "NOT NULL") + } + + if (!is.null(x@default)) { + parts <- c(parts, paste("DEFAULT", render_value(x@default, dialect))) + } + + paste(parts, collapse = " ") + } + +render_identity <- function(x, dialect) { + generated <- if (x@generated == "always") "ALWAYS" else "BY DEFAULT" + options <- character() + + if (!identical(x@start, 1L)) { + options <- c(options, paste("START WITH", x@start)) + } + if (!identical(x@increment, 1L)) { + options <- c(options, paste("INCREMENT BY", x@increment)) + } + + paste0( + "GENERATED ", generated, " AS IDENTITY", + if (length(options)) paste0(" (", paste(options, collapse = " "), ")") + ) +} + +render_value <- function(x, dialect) { + if (S7_inherits(x, sqlr_sql)) x@text else sqlr_quote_literal(dialect, x) +} + +render_columns <- function(columns, dialect) { + paste0(sqlr_quote(dialect, columns), collapse = ", ") +} + +constraint_prefix <- function(x, dialect) { + if (is.na(x@name)) "" else paste0("CONSTRAINT ", sqlr_quote(dialect, x@name), " ") +} + +method(sqlr_render, list(sqlr_primary_key, sqlr_dialect)) <- + function(x, dialect, ...) { + paste0( + constraint_prefix(x, dialect), + "PRIMARY KEY (", render_columns(x@columns, dialect), ")" + ) + } + +method(sqlr_render, list(sqlr_unique, sqlr_dialect)) <- + function(x, dialect, ...) { + paste0( + constraint_prefix(x, dialect), + "UNIQUE (", render_columns(x@columns, dialect), ")" + ) + } + +method(sqlr_render, list(sqlr_check, sqlr_dialect)) <- + function(x, dialect, ...) { + paste0(constraint_prefix(x, dialect), "CHECK (", x@expr@text, ")") + } + +method(sqlr_render, list(sqlr_foreign_key, sqlr_dialect)) <- + function(x, dialect, ..., qualifier = NA_character_) { + schema <- if (is.na(x@ref_schema)) qualifier else x@ref_schema + target <- qualified_name(x@ref_table, schema, dialect) + + out <- paste0( + constraint_prefix(x, dialect), + "FOREIGN KEY (", render_columns(x@columns, dialect), ") ", + "REFERENCES ", target, " (", render_columns(x@ref_columns, dialect), ")" + ) + + if (x@on_delete != "no action") { + out <- paste0(out, " ON DELETE ", toupper(x@on_delete)) + } + if (x@on_update != "no action") { + out <- paste0(out, " ON UPDATE ", toupper(x@on_update)) + } + + out + } + +method(sqlr_render, list(sqlr_table, sqlr_dialect)) <- + function(x, dialect, ..., qualifier = NA_character_) { + c( + render_create_table(x, dialect, x@constraints, qualifier), + render_table_indexes(x, dialect, qualifier) + ) + } + +render_create_table <- function(x, dialect, constraints, qualifier) { + body <- c( + vapply(x@columns, sqlr_render, character(1L), dialect = dialect), + vapply( + constraints, sqlr_render, character(1L), + dialect = dialect, qualifier = qualifier + ) + ) + + paste0( + "CREATE TABLE ", qualified_name(x@name, qualifier, dialect), " (\n ", + paste0(body, collapse = ",\n "), "\n)" + ) +} + +render_table_indexes <- function(x, dialect, qualifier) { + vapply( + x@indexes, + function(idx) sqlr_render(idx, dialect, table = x@name, qualifier = qualifier), + character(1L) + ) +} + +method(sqlr_render, list(sqlr_index, sqlr_dialect)) <- + function(x, dialect, ..., table, qualifier = NA_character_) { + keys <- paste0( + sqlr_quote(dialect, x@columns), + ifelse(x@desc, " DESC", ""), + collapse = ", " + ) + + paste0( + "CREATE ", if (x@unique) "UNIQUE " else "", "INDEX ", + if (!is.na(x@name)) paste0(sqlr_quote(dialect, x@name), " "), + "ON ", qualified_name(table, qualifier, dialect), " (", keys, ")", + if (!is.null(x@spec@where)) paste0(" WHERE ", x@spec@where@text) + ) + } + +qualified_name <- function(name, qualifier, dialect) { + if (is.na(qualifier)) { + sqlr_quote(dialect, name) + } else { + paste0(sqlr_quote(dialect, qualifier), ".", sqlr_quote(dialect, name)) + } +} + +method(sqlr_render, list(sqlr_schema, sqlr_dialect)) <- + function(x, dialect, ...) { + if (!length(x@tables)) { + return(character()) + } + + hoisted <- if (sqlr_defers_constraints(dialect)) { + cyclic_foreign_keys(x) + } else { + lapply(x@tables, function(tbl) rep(FALSE, length(tbl@constraints))) + } + order <- table_order(x, hoisted) + qualifier <- x@name + + creates <- unlist(lapply(order, function(i) { + tbl <- x@tables[[i]] + inline <- tbl@constraints[!hoisted[[i]]] + c( + render_create_table(tbl, dialect, inline, qualifier), + render_table_indexes(tbl, dialect, qualifier) + ) + })) + + alters <- unlist(lapply(order, function(i) { + tbl <- x@tables[[i]] + vapply( + tbl@constraints[hoisted[[i]]], + function(con) { + paste0( + "ALTER TABLE ", qualified_name(tbl@name, qualifier, dialect), + " ADD ", sqlr_render(con, dialect, qualifier = qualifier) + ) + }, + character(1L) + ) + })) + + c(creates, alters) + } diff --git a/R/sql_int.R b/R/sql_int.R deleted file mode 100644 index 68cddb6..0000000 --- a/R/sql_int.R +++ /dev/null @@ -1,5 +0,0 @@ - -#' @export -method(render_sql, list(smallint, con_pq)) <- function(x, con, ...) { - sql("smallint") -} diff --git a/R/sqlr-package.R b/R/sqlr-package.R index cdef51f..6b72527 100644 --- a/R/sqlr-package.R +++ b/R/sqlr-package.R @@ -1,7 +1,3 @@ - -#' @import R7 -#' @importFrom DBI SQL +#' @import S7 #' @keywords internal "_PACKAGE" - -sql <- SQL diff --git a/R/type_shorthand.R b/R/type_shorthand.R new file mode 100644 index 0000000..983edc0 --- /dev/null +++ b/R/type_shorthand.R @@ -0,0 +1,92 @@ +#' Coerce to a SQL type +#' +#' Accepts a [sqlr_type] unchanged, or parses a string spelling such as +#' `"varchar(255)"` or `"numeric(10, 2)"`. Spellings sqlr does not recognise +#' become [sqlr_other()] and are carried through verbatim. +#' +#' @param x A `sqlr_type`, or a string naming one. +#' +#' @return An object inheriting from `sqlr_type`. +#' +#' @examples +#' as_sqlr_type("varchar(255)") +#' as_sqlr_type("geometry") +#' +#' @export +as_sqlr_type <- function(x) { + if (S7_inherits(x, sqlr_type)) { + return(x) + } + + if (!is.character(x) || length(x) != 1L || is.na(x)) { + stop("`x` must be a sqlr_type or a single type name", call. = FALSE) + } + + spec <- parse_type_spelling(x) + build_type_from_spelling(spec$name, spec$args, x) +} + +parse_type_spelling <- function(x) { + trimmed <- trimws(x) + open <- regexpr("(", trimmed, fixed = TRUE) + + if (open == -1L) { + return(list(name = tolower(trimmed), args = integer())) + } + + close <- utils::tail(gregexpr(")", trimmed, fixed = TRUE)[[1L]], 1L) + if (close < open) { + stop("unbalanced parentheses in type `", x, "`", call. = FALSE) + } + + inner <- substr(trimmed, open + 1L, close - 1L) + args <- suppressWarnings( + as.integer(trimws(strsplit(inner, ",", fixed = TRUE)[[1L]])) + ) + + list(name = tolower(trimws(substr(trimmed, 1L, open - 1L))), args = args) +} + +build_type_from_spelling <- function(name, args, raw) { + arg <- function(i) if (length(args) >= i) args[[i]] else NA_integer_ + + switch( + gsub("[[:space:]]+", " ", name), + "smallint" = , + "int2" = sqlr_smallint(raw = raw), + "int" = , + "integer" = , + "int4" = sqlr_int(raw = raw), + "bigint" = , + "int8" = sqlr_bigint(raw = raw), + "real" = , + "float4" = sqlr_real(raw = raw), + "double" = , + "double precision" = , + "float8" = sqlr_double(raw = raw), + "numeric" = , + "decimal" = sqlr_numeric(arg(1L), arg(2L), raw = raw), + "varchar" = , + "character varying" = sqlr_varchar(arg(1L), raw = raw), + "char" = , + "character" = , + "bpchar" = sqlr_char(arg(1L), raw = raw), + "text" = sqlr_text(raw = raw), + "blob" = , + "bytea" = , + "binary" = sqlr_blob(arg(1L), raw = raw), + "bool" = , + "boolean" = sqlr_boolean(raw = raw), + "date" = sqlr_date(raw = raw), + "time" = sqlr_time(precision = arg(1L), raw = raw), + "timetz" = , + "time with time zone" = sqlr_time(TRUE, arg(1L), raw = raw), + "timestamp" = sqlr_timestamp(precision = arg(1L), raw = raw), + "timestamptz" = , + "timestamp with time zone" = sqlr_timestamp(TRUE, arg(1L), raw = raw), + "json" = sqlr_json(raw = raw), + "jsonb" = sqlr_json(TRUE, raw = raw), + "uuid" = sqlr_uuid(raw = raw), + sqlr_other(name, raw = raw) + ) +} diff --git a/man/as_sqlr_type.Rd b/man/as_sqlr_type.Rd new file mode 100644 index 0000000..07cd10e --- /dev/null +++ b/man/as_sqlr_type.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/type_shorthand.R +\name{as_sqlr_type} +\alias{as_sqlr_type} +\title{Coerce to a SQL type} +\usage{ +as_sqlr_type(x) +} +\arguments{ +\item{x}{A `sqlr_type`, or a string naming one.} +} +\value{ +An object inheriting from `sqlr_type`. +} +\description{ +Accepts a [sqlr_type] unchanged, or parses a string spelling such as +`"varchar(255)"` or `"numeric(10, 2)"`. Spellings sqlr does not recognise +become [sqlr_other()] and are carried through verbatim. +} +\examples{ +as_sqlr_type("varchar(255)") +as_sqlr_type("geometry") + +} diff --git a/man/int.Rd b/man/int.Rd deleted file mode 100644 index 0111293..0000000 --- a/man/int.Rd +++ /dev/null @@ -1,17 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/class_int.R -\name{int} -\alias{int} -\alias{smallint} -\title{Integer types} -\usage{ -int(.data = class_missing) - -smallint(.data = class_missing) -} -\arguments{ -\item{.data}{R7 doc} -} -\description{ -Integer types -} diff --git a/man/parse_sql.Rd b/man/parse_sql.Rd deleted file mode 100644 index f05e573..0000000 --- a/man/parse_sql.Rd +++ /dev/null @@ -1,22 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/generics.R -\name{parse_sql} -\alias{parse_sql} -\title{Parse SQL} -\usage{ -parse_sql(x, con, ...) -} -\arguments{ -\item{x}{SQL string} - -\item{con}{Database connection} - -\item{...}{Generic consistency} -} -\value{ -{sqlr} object -} -\description{ -The inverse operation as [render_sql()], i.e. instantiating an {sqlr} object -from an SQL string. -} diff --git a/man/render_sql.Rd b/man/render_sql.Rd deleted file mode 100644 index 74e3b8d..0000000 --- a/man/render_sql.Rd +++ /dev/null @@ -1,26 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/generics.R -\name{render_sql} -\alias{render_sql} -\title{Generate SQL} -\usage{ -render_sql(x, con, ...) -} -\arguments{ -\item{x}{Object} - -\item{con}{Database connection} - -\item{...}{Generic consistency} -} -\value{ -SQL string -} -\description{ -For a given SQL dialect determined by `con`, SQL is generated corresponding -to the object passed as `x`. -} -\examples{ -render_sql(smallint(), simulate_postgres()) - -} diff --git a/man/simulate_postgres.Rd b/man/simulate_postgres.Rd deleted file mode 100644 index 933d920..0000000 --- a/man/simulate_postgres.Rd +++ /dev/null @@ -1,11 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/class_con.R -\name{simulate_postgres} -\alias{simulate_postgres} -\title{Dummy connection object for PostgreSQL} -\usage{ -simulate_postgres() -} -\description{ -Dummy connection object for PostgreSQL -} diff --git a/man/sqlr-package.Rd b/man/sqlr-package.Rd index 5c37bc3..0dc7a3b 100644 --- a/man/sqlr-package.Rd +++ b/man/sqlr-package.Rd @@ -4,9 +4,9 @@ \name{sqlr-package} \alias{sqlr} \alias{sqlr-package} -\title{sqlr: Build SQL queries for creating/altering tables} +\title{sqlr: Represent and Generate SQL Schemas} \description{ -Starting with MardaDB/MySQL and possibly expanding to other SQL dialects, the aim of this package is to help with generating queries for creating and altering tables. +A dialect-independent representation of a relational schema -- tables, columns, types, constraints and indexes -- that can be built up from R, rendered as data definition language for a given SQL dialect, and learned back from a live database. Dialect support is provided by companion packages. } \seealso{ Useful links: @@ -19,5 +19,10 @@ Useful links: \author{ \strong{Maintainer}: Nicolas Bennett \email{r@nbenn.ch} +Authors: +\itemize{ + \item Nicolas Bennett \email{r@nbenn.ch} +} + } \keyword{internal} diff --git a/man/sqlr_constraint.Rd b/man/sqlr_constraint.Rd new file mode 100644 index 0000000..58f3f21 --- /dev/null +++ b/man/sqlr_constraint.Rd @@ -0,0 +1,104 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/class_constraint.R +\name{sqlr_constraint} +\alias{sqlr_constraint} +\alias{sqlr_index_spec} +\alias{sqlr_primary_key} +\alias{sqlr_unique} +\alias{sqlr_foreign_key} +\alias{sqlr_check} +\title{Table constraints} +\usage{ +sqlr_index_spec( + method = NA_character_, + include = character(), + where = NULL, + attrs = list() +) + +sqlr_constraint( + name = NA_character_, + description = NA_character_, + attrs = list() +) + +sqlr_primary_key( + columns, + name = NA_character_, + spec = sqlr_index_spec(), + description = NA_character_, + attrs = list() +) + +sqlr_unique( + columns, + name = NA_character_, + spec = sqlr_index_spec(), + description = NA_character_, + attrs = list() +) + +sqlr_foreign_key( + columns, + ref_table, + ref_columns, + ref_schema = NA_character_, + on_delete = "no action", + on_update = "no action", + name = NA_character_, + description = NA_character_, + attrs = list() +) + +sqlr_check( + expr, + name = NA_character_, + description = NA_character_, + attrs = list() +) +} +\arguments{ +\item{method}{Index method, such as `"btree"`.} + +\item{include}{Non-key columns carried in the index.} + +\item{where}{Partial index predicate.} + +\item{attrs}{Named list of dialect-specific attributes.} + +\item{name}{Constraint name. `NA` leaves naming to the dialect.} + +\item{description}{Comment attached to the constraint.} + +\item{columns}{Names of the constrained columns.} + +\item{spec}{An [sqlr_index_spec()] describing the backing index.} + +\item{ref_table, ref_schema, ref_columns}{Foreign key target.} + +\item{on_delete, on_update}{Referential action: one of `"no action"`, +`"restrict"`, `"cascade"`, `"set null"` or `"set default"`.} + +\item{expr}{Check expression, as a string or [sqlr_sql()].} +} +\value{ +An object inheriting from `sqlr_constraint`. +} +\description{ +Primary keys and unique constraints own an [sqlr_index_spec()] describing +the index that backs them, rather than being modelled as indexes carrying a +flag. This mirrors the database catalogue, where the constraint owns its +supporting index, so a reflected schema maps onto the same shape. +} +\details{ +Constraint identity is structural -- the columns, referenced target or +expression. `name` is a renderable attribute, so a schema authored here and +the same schema read back from a database compare equal even when the +engine chose its own names. +} +\examples{ +sqlr_primary_key("id") +sqlr_foreign_key("user_id", "users", "id", on_delete = "cascade") +sqlr_check("total > 0", name = "orders_total_check") + +} diff --git a/man/sqlr_defers_constraints.Rd b/man/sqlr_defers_constraints.Rd new file mode 100644 index 0000000..7cf9c33 --- /dev/null +++ b/man/sqlr_defers_constraints.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/generics.R +\name{sqlr_defers_constraints} +\alias{sqlr_defers_constraints} +\title{Whether a dialect can add constraints after the fact} +\usage{ +sqlr_defers_constraints(dialect, ...) +} +\arguments{ +\item{dialect}{A [sqlr_dialect].} + +\item{...}{Passed to methods.} +} +\value{ +A flag. +} +\description{ +Governs how foreign key cycles are broken. Where `TRUE`, a foreign key that +would close a cycle is hoisted out of `CREATE TABLE` into a trailing +`ALTER TABLE ... ADD CONSTRAINT`, and tables are emitted in dependency +order. Where `FALSE` -- SQLite being the case in point, since it has no +`ADD CONSTRAINT` -- every constraint stays inline and no ordering is +attempted, which is safe on engines that permit forward references. +} diff --git a/man/sqlr_dialect.Rd b/man/sqlr_dialect.Rd new file mode 100644 index 0000000..6e795ad --- /dev/null +++ b/man/sqlr_dialect.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/class_dialect.R +\name{sqlr_dialect} +\alias{sqlr_dialect} +\title{SQL dialects} +\usage{ +sqlr_dialect(version = NA_character_, attrs = list()) +} +\arguments{ +\item{version}{Engine version, governing version-dependent rendering.} + +\item{attrs}{Named list of dialect-specific attributes.} +} +\value{ +An object inheriting from `sqlr_dialect`. +} +\description{ +A dialect is what rendering and reflection dispatch on. It is deliberately +not the connection: a dialect object can be built without a driver package +installed, which keeps sqlr free of database dependencies and lets the whole +test suite run with no server. +} +\details{ +`sqlr_dialect` is abstract. It carries the rendering every engine shares, +which concrete dialects in companion packages inherit and override. It is +never instantiated and never used as a fallback, so there is no generic +pseudo-dialect emitting SQL that no engine has been tested against. +} diff --git a/man/sqlr_diff.Rd b/man/sqlr_diff.Rd new file mode 100644 index 0000000..c393bc1 --- /dev/null +++ b/man/sqlr_diff.Rd @@ -0,0 +1,36 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/compare.R +\name{sqlr_diff} +\alias{sqlr_diff} +\alias{sqlr_equal} +\title{Compare two schemas} +\usage{ +sqlr_diff(x, y) + +sqlr_equal(x, y) +} +\arguments{ +\item{x, y}{Objects to compare.} +} +\value{ +`sqlr_diff()` a character vector of differences, empty when equal; + `sqlr_equal()` a flag. +} +\description{ +Compares structurally rather than by identity: constraints and indexes are +matched on what they constrain, not on their order or their names, and the +verbatim type spelling a database reported is ignored. This is what lets a +schema authored in R be compared against the same schema read back out of a +database with [sqlr_reflect()]. +} +\details{ +Check constraints are matched by name where both carry one. Their +expressions are not compared: engines rewrite them on the way in, inserting +casts that depend on the column's type, and undoing that reliably would take +a full expression parser. +} +\examples{ +a <- sqlr_table("t", sqlr_column("id", sqlr_int())) +sqlr_equal(a, a) + +} diff --git a/man/sqlr_identity.Rd b/man/sqlr_identity.Rd new file mode 100644 index 0000000..ed1d3fa --- /dev/null +++ b/man/sqlr_identity.Rd @@ -0,0 +1,54 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/class_column.R +\name{sqlr_identity} +\alias{sqlr_identity} +\alias{sqlr_column} +\title{Table columns} +\usage{ +sqlr_identity(generated = "by default", start = 1L, increment = 1L) + +sqlr_column( + name, + type, + null = TRUE, + default = NULL, + description = NA_character_, + identity = NULL, + attrs = list() +) +} +\arguments{ +\item{generated}{Whether the identity always applies, or yields to a +supplied value.} + +\item{start, increment}{Sequence start and step.} + +\item{name}{Column name.} + +\item{type}{A [sqlr_type], or a string parsed by [as_sqlr_type()].} + +\item{null}{Whether the column admits `NULL`. A column named in a primary +key is forced to `FALSE`, matching what every engine reports back.} + +\item{default}{Default value: a length-one atomic, a [sqlr_sql()] +expression, or `NULL` for none.} + +\item{description}{Comment attached to the column.} + +\item{identity}{An [sqlr_identity()], or `NULL`.} + +\item{attrs}{Named list of dialect-specific attributes, ignored by dialects +that do not recognise them.} +} +\value{ +A `sqlr_column` or `sqlr_identity` object. +} +\description{ +A column of a [sqlr_table()]. `identity` describes an automatically +generated key; it is what a dialect maps its `SERIAL`-style spellings onto. +} +\examples{ +sqlr_column("email", "varchar(255)", null = FALSE) +sqlr_column("id", sqlr_bigint(), identity = sqlr_identity()) + +} diff --git a/man/sqlr_index.Rd b/man/sqlr_index.Rd new file mode 100644 index 0000000..4a35bc3 --- /dev/null +++ b/man/sqlr_index.Rd @@ -0,0 +1,44 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/class_index.R +\name{sqlr_index} +\alias{sqlr_index} +\title{Standalone indexes} +\usage{ +sqlr_index( + columns, + name = NA_character_, + desc = FALSE, + unique = FALSE, + spec = sqlr_index_spec(), + description = NA_character_, + attrs = list() +) +} +\arguments{ +\item{columns}{Indexed column names.} + +\item{name}{Index name.} + +\item{desc}{Per-column descending flags, recycled to `columns`.} + +\item{unique}{Whether the index enforces uniqueness.} + +\item{spec}{An [sqlr_index_spec()] describing method, includes and +predicate.} + +\item{description}{Comment attached to the index.} + +\item{attrs}{Named list of dialect-specific attributes.} +} +\value{ +A `sqlr_index` object. +} +\description{ +An index that is not backing a constraint. Indexes created implicitly by a +primary key or unique constraint belong to that constraint's +[sqlr_index_spec()] and are not reported here by [sqlr_reflect()]. +} +\examples{ +sqlr_index("val", name = "orders_val_idx") + +} diff --git a/man/sqlr_quote.Rd b/man/sqlr_quote.Rd new file mode 100644 index 0000000..808e970 --- /dev/null +++ b/man/sqlr_quote.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/generics.R +\name{sqlr_quote} +\alias{sqlr_quote} +\alias{sqlr_quote_literal} +\title{Quote identifiers and literals} +\usage{ +sqlr_quote(dialect, ...) + +sqlr_quote_literal(dialect, ...) +} +\arguments{ +\item{dialect}{A [sqlr_dialect].} + +\item{...}{The identifier or literal to quote, passed to methods.} +} +\value{ +A string. +} +\description{ +Quote identifiers and literals +} diff --git a/man/sqlr_reflect.Rd b/man/sqlr_reflect.Rd new file mode 100644 index 0000000..b7f59bf --- /dev/null +++ b/man/sqlr_reflect.Rd @@ -0,0 +1,34 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/generics.R +\name{sqlr_reflect} +\alias{sqlr_reflect} +\alias{sqlr_reflect_schema} +\title{Learn a schema from a database} +\usage{ +sqlr_reflect(con, schema = NULL, dialect = sqlr_for(con), ...) + +sqlr_reflect_schema(dialect, ...) +} +\arguments{ +\item{con}{A `DBIConnection`.} + +\item{schema}{Schema name to read; `NULL` for the connection default.} + +\item{dialect}{A [sqlr_dialect]; resolved from `con` by default.} + +\item{...}{Passed to methods.} +} +\value{ +A [sqlr_schema()]. +} +\description{ +Reads the catalogue of a live database and returns the same representation +[sqlr_render()] consumes, so a schema can be rendered, executed and read +back for comparison. +} +\details{ +A dialect must return canonical form: constraint-backed indexes dropped, +type spellings collapsed onto [sqlr_type] objects, macro types such as +`SERIAL` decomposed, and any casts the engine inserted stripped. Comparison +is then plain equality rather than a pile of special cases. +} diff --git a/man/sqlr_register_dialect.Rd b/man/sqlr_register_dialect.Rd new file mode 100644 index 0000000..6e68d3f --- /dev/null +++ b/man/sqlr_register_dialect.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/registry.R +\name{sqlr_register_dialect} +\alias{sqlr_register_dialect} +\alias{sqlr_for} +\title{Register a dialect for a connection class} +\usage{ +sqlr_register_dialect(connection_class, factory) + +sqlr_for(con) +} +\arguments{ +\item{connection_class}{Name of the `DBIConnection` subclass.} + +\item{factory}{Function of one argument, the connection, returning a +[sqlr_dialect].} + +\item{con}{A `DBIConnection`.} +} +\value{ +`sqlr_register_dialect()` returns `NULL` invisibly; `sqlr_for()` + returns a [sqlr_dialect]. +} +\description{ +Called by dialect packages from `.onLoad()`, so that [sqlr_for()] can +resolve a connection sqlr itself knows nothing about. +} diff --git a/man/sqlr_render.Rd b/man/sqlr_render.Rd new file mode 100644 index 0000000..0232f5a --- /dev/null +++ b/man/sqlr_render.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/generics.R +\name{sqlr_render} +\alias{sqlr_render} +\title{Render SQL} +\usage{ +sqlr_render(x, dialect, ...) +} +\arguments{ +\item{x}{Object to render.} + +\item{dialect}{A [sqlr_dialect].} + +\item{...}{Passed to methods.} +} +\value{ +A character vector of statements. +} +\description{ +Emits data definition language for `x` in the dialect `dialect`. +} +\details{ +Rendering a schema is not rendering each table in turn. Foreign keys can +form cycles -- a self-reference, or two tables pointing at each other -- so +the tables are ordered by dependency and any foreign key that would close a +cycle is hoisted out into a trailing `ALTER TABLE`. Rendering a single table +emits only what that table can state on its own. +} +\examples{ +# needs a dialect package, e.g. +# sqlr_render(schema, sqlr.postgres::postgres()) + +} diff --git a/man/sqlr_render_type.Rd b/man/sqlr_render_type.Rd new file mode 100644 index 0000000..64bbad1 --- /dev/null +++ b/man/sqlr_render_type.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/generics.R +\name{sqlr_render_type} +\alias{sqlr_render_type} +\alias{sqlr_parse_type} +\title{Map between sqlr types and dialect spellings} +\usage{ +sqlr_render_type(type, dialect, ...) + +sqlr_parse_type(dialect, ...) +} +\arguments{ +\item{type}{A [sqlr_type].} + +\item{dialect}{A [sqlr_dialect].} + +\item{...}{Passed to methods; `sqlr_parse_type()` takes the type spelling +reported by the database catalogue this way.} +} +\value{ +`sqlr_render_type()` a string; `sqlr_parse_type()` a [sqlr_type]. +} +\description{ +Every dialect owes both directions: reflection has to arrive at the same +type object that authoring produced, or an authored schema will never +compare equal to the one read back. +} diff --git a/man/sqlr_schema.Rd b/man/sqlr_schema.Rd new file mode 100644 index 0000000..4775347 --- /dev/null +++ b/man/sqlr_schema.Rd @@ -0,0 +1,37 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/class_schema.R +\name{sqlr_schema} +\alias{sqlr_schema} +\alias{sqlr_catalog} +\title{Schemas and catalogues} +\usage{ +sqlr_schema( + name = NA_character_, + ..., + description = NA_character_, + attrs = list() +) + +sqlr_catalog(..., attrs = list()) +} +\arguments{ +\item{name}{Schema name.} + +\item{...}{[sqlr_table()]s, or [sqlr_schema()]s for `sqlr_catalog()`.} + +\item{description}{Comment attached to the schema.} + +\item{attrs}{Named list of dialect-specific attributes.} +} +\value{ +A `sqlr_schema` or `sqlr_catalog` object. +} +\description{ +A schema is a named collection of tables; a catalogue holds several schemas, +which is what [sqlr_reflect()] returns when asked for more than one and what +cross-schema foreign keys resolve against. +} +\examples{ +sqlr_schema("public", sqlr_table("t", sqlr_column("id", sqlr_int()))) + +} diff --git a/man/sqlr_sql.Rd b/man/sqlr_sql.Rd new file mode 100644 index 0000000..257d38c --- /dev/null +++ b/man/sqlr_sql.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/class_sql.R +\name{sqlr_sql} +\alias{sqlr_sql} +\title{Verbatim SQL} +\usage{ +sqlr_sql(text = character(0)) +} +\arguments{ +\item{text}{String of SQL.} +} +\value{ +An object of class `sqlr_sql`. +} +\description{ +Wraps a string that is to be emitted as-is, without quoting or escaping. +Accepted anywhere a value, expression or type may appear. +} +\examples{ +sqlr_sql("now()") + +} diff --git a/man/sqlr_table.Rd b/man/sqlr_table.Rd new file mode 100644 index 0000000..832f55e --- /dev/null +++ b/man/sqlr_table.Rd @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/class_table.R +\name{sqlr_table} +\alias{sqlr_table} +\title{Tables} +\usage{ +sqlr_table(name, ..., description = NA_character_, attrs = list()) +} +\arguments{ +\item{name}{Table name.} + +\item{...}{[sqlr_column()]s, [sqlr_constraint]s and [sqlr_index()]es.} + +\item{description}{Comment attached to the table.} + +\item{attrs}{Named list of dialect-specific attributes.} +} +\value{ +A `sqlr_table` object. +} +\description{ +Columns, constraints and indexes are passed positionally in any order. +Columns named in a primary key have `null` forced to `FALSE`, which the SQL +standard implies and every engine reports back, so an authored table +compares equal to its own reflection. +} +\examples{ +sqlr_table( + "users", + sqlr_column("id", sqlr_bigint()), + sqlr_column("email", "varchar(255)", null = FALSE), + sqlr_primary_key("id") +) + +} diff --git a/man/sqlr_type.Rd b/man/sqlr_type.Rd new file mode 100644 index 0000000..24fe44b --- /dev/null +++ b/man/sqlr_type.Rd @@ -0,0 +1,138 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/class_type.R +\name{sqlr_type} +\alias{sqlr_type} +\alias{sqlr_integer_type} +\alias{sqlr_float_type} +\alias{sqlr_decimal_type} +\alias{sqlr_string_type} +\alias{sqlr_binary_type} +\alias{sqlr_boolean_type} +\alias{sqlr_time_type} +\alias{sqlr_json_type} +\alias{sqlr_uuid_type} +\alias{sqlr_other_type} +\alias{sqlr_smallint} +\alias{sqlr_int} +\alias{sqlr_bigint} +\alias{sqlr_real} +\alias{sqlr_double} +\alias{sqlr_numeric} +\alias{sqlr_varchar} +\alias{sqlr_char} +\alias{sqlr_text} +\alias{sqlr_blob} +\alias{sqlr_boolean} +\alias{sqlr_date} +\alias{sqlr_time} +\alias{sqlr_timestamp} +\alias{sqlr_json} +\alias{sqlr_uuid} +\alias{sqlr_other} +\title{SQL column types} +\usage{ +sqlr_type(raw = NA_character_) + +sqlr_integer_type(raw = NA_character_, bytes = 4L, unsigned = FALSE) + +sqlr_float_type(raw = NA_character_, bytes = 8L) + +sqlr_decimal_type( + raw = NA_character_, + precision = NA_integer_, + scale = NA_integer_ +) + +sqlr_string_type(raw = NA_character_, size = NA_integer_, fixed = FALSE) + +sqlr_binary_type(raw = NA_character_, size = NA_integer_, fixed = FALSE) + +sqlr_boolean_type(raw = NA_character_) + +sqlr_time_type( + raw = NA_character_, + kind = "timestamp", + with_timezone = FALSE, + precision = NA_integer_ +) + +sqlr_json_type(raw = NA_character_, binary = FALSE) + +sqlr_uuid_type(raw = NA_character_) + +sqlr_other_type(raw = NA_character_, name = character(0)) + +sqlr_smallint(unsigned = FALSE, raw = NA_character_) + +sqlr_int(unsigned = FALSE, raw = NA_character_) + +sqlr_bigint(unsigned = FALSE, raw = NA_character_) + +sqlr_real(raw = NA_character_) + +sqlr_double(raw = NA_character_) + +sqlr_numeric(precision = NA, scale = NA, raw = NA_character_) + +sqlr_varchar(size = NA, raw = NA_character_) + +sqlr_char(size = NA, raw = NA_character_) + +sqlr_text(raw = NA_character_) + +sqlr_blob(size = NA, raw = NA_character_) + +sqlr_boolean(raw = NA_character_) + +sqlr_date(raw = NA_character_) + +sqlr_time(with_timezone = FALSE, precision = NA, raw = NA_character_) + +sqlr_timestamp(with_timezone = FALSE, precision = NA, raw = NA_character_) + +sqlr_json(binary = FALSE, raw = NA_character_) + +sqlr_uuid(raw = NA_character_) + +sqlr_other(name, raw = NA_character_) +} +\arguments{ +\item{raw}{Verbatim type spelling as reported by a database.} + +\item{bytes}{Width of an integer or float type.} + +\item{unsigned}{Whether an integer type is unsigned.} + +\item{precision, scale}{Total digits and digits after the decimal point.} + +\item{size}{Length of a character or binary type; `NA` for unbounded.} + +\item{fixed}{Whether a character or binary type is blank-padded.} + +\item{kind}{Whether a time type is a `"date"`, `"time"` or `"timestamp"`.} + +\item{with_timezone}{Whether a time type carries a time zone.} + +\item{binary}{Whether JSON is stored in a decomposed binary form.} + +\item{name}{Name of an unmodelled type.} +} +\value{ +An object inheriting from `sqlr_type`. +} +\description{ +A dialect-independent description of a column's type. Each dialect maps +these onto its own spelling when rendering, and back again when reflecting. +`raw` carries the verbatim spelling a database reported, and is set by +[sqlr_reflect()] rather than by hand. +} +\details{ +`sqlr_other()` carries a type sqlr does not model. It renders verbatim and +survives a round trip, but nothing can be inferred about it. +} +\examples{ +sqlr_varchar(255) +sqlr_numeric(10, 2) +sqlr_timestamp(with_timezone = TRUE) + +} diff --git a/tests/testthat.R b/tests/testthat.R index 779e27f..f2d046f 100644 --- a/tests/testthat.R +++ b/tests/testthat.R @@ -1,11 +1,3 @@ -# This file is part of the standard setup for testthat. -# It is recommended that you do not modify it. -# -# Where should you do additional test configuration? -# Learn more about the roles of various files in: -# * https://r-pkgs.org/tests.html -# * https://testthat.r-lib.org/reference/test_package.html#special-files - library(testthat) library(sqlr) diff --git a/tests/testthat/helper-dialect.R b/tests/testthat/helper-dialect.R new file mode 100644 index 0000000..ce2cb85 --- /dev/null +++ b/tests/testthat/helper-dialect.R @@ -0,0 +1,14 @@ +library(S7) + +test_dialect <- new_class("test_dialect", parent = sqlr_dialect) + +method(sqlr_render_type, list(sqlr_type, test_dialect)) <- + function(type, dialect, ...) "TYPE" + +method(sqlr_render_type, list(sqlr_integer_type, test_dialect)) <- + function(type, dialect, ...) paste0("INT", type@bytes) + +method(sqlr_render_type, list(sqlr_string_type, test_dialect)) <- + function(type, dialect, ...) { + if (is.na(type@size)) "TEXT" else paste0("VARCHAR(", type@size, ")") + } diff --git a/tests/testthat/test-compare.R b/tests/testthat/test-compare.R new file mode 100644 index 0000000..0fe93a6 --- /dev/null +++ b/tests/testthat/test-compare.R @@ -0,0 +1,43 @@ +test_that("constraint order and naming do not affect equality", { + a <- sqlr_table( + "t", + sqlr_column("id", sqlr_int()), + sqlr_column("email", sqlr_text()), + sqlr_primary_key("id", name = "t_pkey"), + sqlr_unique("email", name = "t_email_key") + ) + b <- sqlr_table( + "t", + sqlr_column("id", sqlr_int()), + sqlr_column("email", sqlr_text()), + sqlr_unique("email", name = "uq_t_email"), + sqlr_primary_key("id", name = "pk_t") + ) + + expect_true(sqlr_equal(a, b)) +}) + +test_that("the reflected type spelling is ignored", { + a <- sqlr_table("t", sqlr_column("id", sqlr_int())) + b <- sqlr_table("t", sqlr_column("id", sqlr_int(raw = "int4"))) + + expect_true(sqlr_equal(a, b)) +}) + +test_that("differences are reported", { + a <- sqlr_table("t", sqlr_column("id", sqlr_int())) + b <- sqlr_table("t", sqlr_column("id", sqlr_bigint())) + + expect_match(sqlr_diff(a, b), "type") + + c <- sqlr_table("t", sqlr_column("id", sqlr_int(), null = FALSE)) + expect_match(sqlr_diff(a, c), "null") +}) + +test_that("missing and extra tables are reported", { + a <- sqlr_schema("s", sqlr_table("x", sqlr_column("id", sqlr_int()))) + b <- sqlr_schema("s", sqlr_table("y", sqlr_column("id", sqlr_int()))) + + expect_match(sqlr_diff(a, b), "missing tables: x", all = FALSE) + expect_match(sqlr_diff(a, b), "extra tables: y", all = FALSE) +}) diff --git a/tests/testthat/test-int.R b/tests/testthat/test-int.R deleted file mode 100644 index eb53e55..0000000 --- a/tests/testthat/test-int.R +++ /dev/null @@ -1,9 +0,0 @@ - -test_that("integer sql generation", { - - res <- render_sql(smallint(), simulate_postgres()) - - expect_s4_class(res, "SQL") - - expect_identical(as.character(res), "smallint") -}) diff --git a/tests/testthat/test-registry.R b/tests/testthat/test-registry.R new file mode 100644 index 0000000..d1c978e --- /dev/null +++ b/tests/testthat/test-registry.R @@ -0,0 +1,12 @@ +test_that("an unregistered connection class is an error, not a fallback", { + fake <- structure(list(), class = "NoSuchConnection") + + expect_error(sqlr_for(fake), "no sqlr dialect registered") +}) + +test_that("a registered dialect resolves", { + sqlr_register_dialect("FakeConnection", function(con) test_dialect()) + fake <- structure(list(), class = "FakeConnection") + + expect_s3_class(sqlr_for(fake), "sqlr::sqlr_dialect") +}) diff --git a/tests/testthat/test-render.R b/tests/testthat/test-render.R new file mode 100644 index 0000000..1cc07cc --- /dev/null +++ b/tests/testthat/test-render.R @@ -0,0 +1,110 @@ +test_that("a table renders its columns and constraints", { + out <- sqlr_render( + sqlr_table( + "users", + sqlr_column("id", sqlr_bigint()), + sqlr_column("email", "varchar(255)", null = FALSE), + sqlr_primary_key("id", name = "users_pkey") + ), + test_dialect() + ) + + expect_length(out, 1L) + expect_match(out, "CREATE TABLE \"users\"") + expect_match(out, "\"id\" INT8 NOT NULL") + expect_match(out, "\"email\" VARCHAR\\(255\\) NOT NULL") + expect_match(out, "CONSTRAINT \"users_pkey\" PRIMARY KEY \\(\"id\"\\)") +}) + +test_that("tables are ordered so referenced tables come first", { + schema <- sqlr_schema( + "s", + sqlr_table( + "orders", + sqlr_column("id", sqlr_int()), + sqlr_column("user_id", sqlr_int()), + sqlr_foreign_key("user_id", "users", "id") + ), + sqlr_table("users", sqlr_column("id", sqlr_int()), sqlr_primary_key("id")) + ) + + out <- sqlr_render(schema, test_dialect()) + + expect_lt(grep("CREATE TABLE \"s\".\"users\"", out), grep("CREATE TABLE \"s\".\"orders\"", out)) +}) + +test_that("a self-referencing foreign key is hoisted out of CREATE TABLE", { + schema <- sqlr_schema( + "s", + sqlr_table( + "employees", + sqlr_column("id", sqlr_int()), + sqlr_column("manager_id", sqlr_int()), + sqlr_primary_key("id"), + sqlr_foreign_key("manager_id", "employees", "id", name = "mgr_fk") + ) + ) + + out <- sqlr_render(schema, test_dialect()) + + expect_length(out, 2L) + expect_false(grepl("FOREIGN KEY", out[[1L]])) + expect_match(out[[2L]], "^ALTER TABLE \"s\".\"employees\" ADD CONSTRAINT \"mgr_fk\"") +}) + +test_that("mutually referencing tables still render", { + schema <- sqlr_schema( + "s", + sqlr_table( + "a", + sqlr_column("id", sqlr_int()), + sqlr_column("b_id", sqlr_int()), + sqlr_foreign_key("b_id", "b", "id") + ), + sqlr_table( + "b", + sqlr_column("id", sqlr_int()), + sqlr_column("a_id", sqlr_int()), + sqlr_foreign_key("a_id", "a", "id") + ) + ) + + out <- sqlr_render(schema, test_dialect()) + + expect_length(grep("^CREATE TABLE", out), 2L) + expect_length(grep("^ALTER TABLE", out), 2L) + expect_false(any(grepl("FOREIGN KEY", grep("^CREATE TABLE", out, value = TRUE)))) +}) + +test_that("foreign keys inherit the schema qualifier", { + schema <- sqlr_schema( + "app", + sqlr_table("users", sqlr_column("id", sqlr_int()), sqlr_primary_key("id")), + sqlr_table( + "orders", + sqlr_column("id", sqlr_int()), + sqlr_column("user_id", sqlr_int()), + sqlr_foreign_key("user_id", "users", "id") + ) + ) + + out <- sqlr_render(schema, test_dialect()) + + expect_match(paste(out, collapse = "\n"), "REFERENCES \"app\".\"users\"") +}) + +test_that("defaults and identity render", { + out <- sqlr_render( + sqlr_table( + "t", + sqlr_column("id", sqlr_bigint(), identity = sqlr_identity("always")), + sqlr_column("label", sqlr_text(), default = "none"), + sqlr_column("at", sqlr_text(), default = sqlr_sql("now()")) + ), + test_dialect() + ) + + expect_match(out, "GENERATED ALWAYS AS IDENTITY") + expect_match(out, "DEFAULT 'none'") + expect_match(out, "DEFAULT now\\(\\)") +}) diff --git a/tests/testthat/test-table.R b/tests/testthat/test-table.R new file mode 100644 index 0000000..04c3142 --- /dev/null +++ b/tests/testthat/test-table.R @@ -0,0 +1,37 @@ +test_that("primary key columns are implied NOT NULL", { + tbl <- sqlr_table( + "t", + sqlr_column("id", sqlr_bigint()), + sqlr_column("other", sqlr_int()), + sqlr_primary_key("id") + ) + + expect_false(tbl@columns[[1L]]@null) + expect_true(tbl@columns[[2L]]@null) +}) + +test_that("duplicate column names are rejected", { + expect_error( + sqlr_table("t", sqlr_column("id", sqlr_int()), sqlr_column("id", sqlr_int())), + "must be unique" + ) +}) + +test_that("constraints may not name unknown columns", { + expect_error( + sqlr_table("t", sqlr_column("id", sqlr_int()), sqlr_primary_key("nope")), + "unknown columns" + ) +}) + +test_that("foreign key columns must pair up", { + expect_error( + sqlr_foreign_key(c("a", "b"), "other", "id"), + "same length" + ) +}) + +test_that("referential actions are checked", { + expect_error(sqlr_foreign_key("a", "t", "id", on_delete = "explode"), "must be one of") + expect_equal(sqlr_foreign_key("a", "t", "id", on_delete = "CASCADE")@on_delete, "cascade") +}) diff --git a/tests/testthat/test-type.R b/tests/testthat/test-type.R new file mode 100644 index 0000000..81eaeb3 --- /dev/null +++ b/tests/testthat/test-type.R @@ -0,0 +1,27 @@ +test_that("type shorthand parses standard spellings", { + expect_equal(as_sqlr_type("varchar(255)")@size, 255L) + expect_true(as_sqlr_type("char(3)")@fixed) + expect_equal(as_sqlr_type("numeric(10, 2)")@scale, 2L) + expect_equal(as_sqlr_type("bigint")@bytes, 8L) + expect_equal(as_sqlr_type("int4")@bytes, 4L) + expect_true(as_sqlr_type("timestamptz")@with_timezone) + expect_true(as_sqlr_type("jsonb")@binary) +}) + +test_that("unknown spellings survive as sqlr_other", { + type <- as_sqlr_type("geometry") + + expect_s3_class(type, "sqlr::sqlr_other_type") + expect_equal(type@name, "geometry") + expect_equal(type@raw, "geometry") +}) + +test_that("a type passes through unchanged", { + type <- sqlr_bigint() + + expect_identical(as_sqlr_type(type), type) +}) + +test_that("integer widths are constrained", { + expect_error(sqlr_integer_type(bytes = 3L), "1, 2, 4 or 8") +})