Accept only SQL-standard type names in as_sqlr_type()

DESCRIPTION

@@ -12,8 +12,7 @@ Description:
 Depends:
     R (>= 4.1)
 Imports:
-    S7,
-    utils
+    S7
 Suggests:
     testthat (>= 3.0.0)
 URL: https://github.com/nbenn/sqlr

NAMESPACE

@@ -31,7 +31,6 @@ 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)

R/compare.R

@@ -87,8 +87,8 @@ 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(constructor_call(x@type), constructor_call(y@type))) {
+      paste0(where, "type ", format(x@type), " vs ", format(y@type))
     },
     if (!identical(x@null, y@null)) {
       paste0(where, "null ", x@null, " vs ", y@null)
@@ -105,19 +105,6 @@ diff_column <- function(x, y, prefix) {
   )
 }
 
-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)
 }

R/generics.R

@@ -21,26 +21,23 @@
 #' @export
 sqlr_render <- new_generic("sqlr_render", c("x", "dialect"))
 
-#' Map between sqlr types and dialect spellings
+#' Render a type in a dialect
 #'
-#' 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.
+#' Spells a [sqlr_type] the way `dialect` writes it in data definition
+#' language. Every dialect owes the reverse direction too, inside its
+#' [sqlr_reflect_schema()] method: 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.
+#' @param ... Passed to methods.
 #'
-#' @return `sqlr_render_type()` a string; `sqlr_parse_type()` a [sqlr_type].
+#' @return A string.
 #'
 #' @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].

R/sqlr-package.R

@@ -1,3 +1,7 @@
 #' @import S7
 #' @keywords internal
 "_PACKAGE"
+
+.onLoad <- function(libname, pkgname) {
+  S7::methods_register()
+}

R/type_shorthand.R

@@ -1,16 +1,40 @@
 #' 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.
+#' Accepts a [sqlr_type] unchanged, or parses one of the SQL-standard type
+#' spellings below, in any case and spacing. Anything else is an error,
+#' including engine aliases such as `int4`, `timestamptz` and `bytea`, so that
+#' the accepted set changes only when the types sqlr models do.
+#'
+#' | Type | Spellings |
+#' |---|---|
+#' | [sqlr_integer_type] | `smallint`, `integer` or `int`, `bigint` |
+#' | [sqlr_float_type] | `real`, `double precision`, `float(p)`: 4 bytes for `p` from 1 to 24, 8 bytes from 25 to 53 |
+#' | [sqlr_decimal_type] | `numeric(p, s)` or `decimal(p, s)`, both arguments optional |
+#' | [sqlr_string_type] | `char(n)` or `character(n)`, where `n` defaults to 1; `varchar(n)` or `character varying(n)`; `text` |
+#' | [sqlr_binary_type] | `binary(n)`, which is fixed-length; `varbinary(n)`; `blob` |
+#' | [sqlr_boolean_type] | `boolean` |
+#' | [sqlr_time_type] | `date`; `time` and `timestamp`, each with an optional `(p)` and an optional `with time zone` or `without time zone` |
+#' | [sqlr_json_type] | `json` |
+#' | [sqlr_uuid_type] | `uuid` |
+#'
+#' A bare `float` is refused, being 8 bytes in some engines and 4 in others.
+#' Unsigned and 1-byte integers and binary JSON have no standard spelling, so
+#' build them with their constructors, and use [sqlr_other()] to carry any
+#' other type verbatim.
+#'
+#' The `format()` method runs the table in reverse. It gives the standard
+#' spelling of a type, or its constructor call if it has none.
 #'
 #' @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")
+#' as_sqlr_type("TIMESTAMP(3) WITH TIME ZONE")
+#'
+#' format(sqlr_numeric(10, 2))
+#' format(sqlr_int(unsigned = TRUE))
 #'
 #' @export
 as_sqlr_type <- function(x) {
@@ -22,71 +46,180 @@ as_sqlr_type <- function(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)
+  type <- standard_type(x)
 
-  if (open == -1L) {
-    return(list(name = tolower(trimmed), args = integer()))
+  if (is.null(type)) {
+    quoted <- encodeString(x, quote = "\"")
+    stop(
+      "unrecognised type ", quoted, ".\n",
+      "Use a spelling listed in ?as_sqlr_type, or sqlr_other(", quoted,
+      ") to carry it verbatim.",
+      call. = FALSE
+    )
   }
 
-  close <- utils::tail(gregexpr(")", trimmed, fixed = TRUE)[[1L]], 1L)
-  if (close < open) {
-    stop("unbalanced parentheses in type `", x, "`", call. = FALSE)
-  }
+  type
+}
 
-  inner <- substr(trimmed, open + 1L, close - 1L)
-  args <- suppressWarnings(
-    as.integer(trimws(strsplit(inner, ",", fixed = TRUE)[[1L]]))
+standard_type <- function(x) {
+  normalised <- gsub(
+    " ?([(),]) ?", "\\1",
+    gsub("\\s+", " ", trimws(tolower(x)))
   )
+  normalised <- gsub("([),])(?=.)", "\\1 ", normalised, perl = TRUE)
 
-  list(name = tolower(trimws(substr(trimmed, 1L, open - 1L))), args = args)
-}
+  args <- suppressWarnings(
+    as.integer(regmatches(normalised, gregexpr("[0-9]+", normalised))[[1L]])
+  )
+  if (anyNA(args)) {
+    return(NULL)
+  }
 
-build_type_from_spelling <- function(name, args, raw) {
-  arg <- function(i) if (length(args) >= i) args[[i]] else NA_integer_
+  arg <- function(i, default = NA_integer_) {
+    if (length(args) >= i) args[[i]] else default
+  }
 
   switch(
-    gsub("[[:space:]]+", " ", name),
-    "smallint" = ,
-    "int2" = sqlr_smallint(raw = raw),
+    gsub("[0-9]+", "#", normalised),
+    "smallint" = sqlr_smallint(),
     "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),
+    "integer" = sqlr_int(),
+    "bigint" = sqlr_bigint(),
+    "real" = sqlr_real(),
+    "double precision" = sqlr_double(),
+    "float(#)" = float_of_precision(arg(1L)),
     "numeric" = ,
-    "decimal" = sqlr_numeric(arg(1L), arg(2L), raw = raw),
-    "varchar" = ,
-    "character varying" = sqlr_varchar(arg(1L), raw = raw),
+    "numeric(#)" = ,
+    "numeric(#, #)" = ,
+    "decimal" = ,
+    "decimal(#)" = ,
+    "decimal(#, #)" = sqlr_numeric(arg(1L), arg(2L)),
     "char" = ,
+    "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)
+    "character(#)" = sqlr_char(arg(1L, default = 1L)),
+    "varchar(#)" = ,
+    "character varying(#)" = sqlr_varchar(arg(1L)),
+    "text" = sqlr_text(),
+    "binary(#)" = sqlr_binary_type(size = arg(1L), fixed = TRUE),
+    "varbinary(#)" = sqlr_blob(arg(1L)),
+    "blob" = sqlr_blob(),
+    "boolean" = sqlr_boolean(),
+    "date" = sqlr_date(),
+    "time" = ,
+    "time(#)" = ,
+    "time without time zone" = ,
+    "time(#) without time zone" = sqlr_time(FALSE, arg(1L)),
+    "time with time zone" = ,
+    "time(#) with time zone" = sqlr_time(TRUE, arg(1L)),
+    "timestamp" = ,
+    "timestamp(#)" = ,
+    "timestamp without time zone" = ,
+    "timestamp(#) without time zone" = sqlr_timestamp(FALSE, arg(1L)),
+    "timestamp with time zone" = ,
+    "timestamp(#) with time zone" = sqlr_timestamp(TRUE, arg(1L)),
+    "json" = sqlr_json(),
+    "uuid" = sqlr_uuid()
   )
 }
+
+float_of_precision <- function(precision) {
+  if (precision %in% 1:24) {
+    sqlr_real()
+  } else if (precision %in% 25:53) {
+    sqlr_double()
+  }
+}
+
+method(format, sqlr_type) <- function(x, ...) constructor_call(x)
+
+method(format, sqlr_integer_type) <- function(x, ...) {
+  if (x@unsigned || x@bytes == 1L) {
+    return(constructor_call(x))
+  }
+
+  switch(
+    as.character(x@bytes),
+    "2" = "smallint",
+    "4" = "integer",
+    "8" = "bigint"
+  )
+}
+
+method(format, sqlr_float_type) <- function(x, ...) {
+  if (x@bytes == 4L) "real" else "double precision"
+}
+
+method(format, sqlr_decimal_type) <- function(x, ...) {
+  if (!is.na(x@precision)) {
+    spelling("numeric", x@precision, x@scale)
+  } else if (is.na(x@scale)) {
+    "numeric"
+  } else {
+    constructor_call(x)
+  }
+}
+
+method(format, sqlr_string_type) <- function(x, ...) {
+  if (!is.na(x@size)) {
+    spelling(if (x@fixed) "char" else "varchar", x@size)
+  } else if (!x@fixed) {
+    "text"
+  } else {
+    constructor_call(x)
+  }
+}
+
+method(format, sqlr_binary_type) <- function(x, ...) {
+  if (!is.na(x@size)) {
+    spelling(if (x@fixed) "binary" else "varbinary", x@size)
+  } else if (!x@fixed) {
+    "blob"
+  } else {
+    constructor_call(x)
+  }
+}
+
+method(format, sqlr_boolean_type) <- function(x, ...) "boolean"
+
+method(format, sqlr_time_type) <- function(x, ...) {
+  if (x@kind != "date") {
+    paste0(
+      spelling(x@kind, x@precision),
+      if (x@with_timezone) " with time zone"
+    )
+  } else if (!x@with_timezone && is.na(x@precision)) {
+    "date"
+  } else {
+    constructor_call(x)
+  }
+}
+
+method(format, sqlr_json_type) <- function(x, ...) {
+  if (x@binary) constructor_call(x) else "json"
+}
+
+method(format, sqlr_uuid_type) <- function(x, ...) "uuid"
+
+spelling <- function(name, ...) {
+  args <- c(...)
+  args <- args[!is.na(args)]
+
+  if (!length(args)) {
+    return(name)
+  }
+
+  paste0(name, "(", paste(args, collapse = ", "), ")")
+}
+
+constructor_call <- function(x) {
+  cls <- S7_class(x)
+  props <- setdiff(names(cls@properties), "raw")
+  set <- Filter(
+    function(p) !identical(prop(x, p), cls@properties[[p]]$default),
+    props
+  )
+  values <- vapply(set, function(p) deparse(prop(x, p)), character(1L))
+
+  paste0(cls@name, "(", paste(set, values, sep = " = ", collapse = ", "), ")")
+}

README.Rmd

@@ -75,9 +75,9 @@ schema <- sqlr_schema(
 )
 ```
 
-Types are given either as objects or as the string spelling you would write
-in SQL, so `sqlr_varchar(255)` and `"varchar(255)"` mean the same thing.
-Check constraints go in the same way, via `sqlr_check("total > 0")`.
+Types are given either as objects or as their SQL-standard spelling, so
+`sqlr_varchar(255)` and `"varchar(255)"` mean the same thing. Check
+constraints go in the same way, via `sqlr_check("total > 0")`.
 
 ## Rendering
 

README.md

@@ -65,10 +65,9 @@ schema <- sqlr_schema(
 )
 ```
 
-Types are given either as objects or as the string spelling you would
-write in SQL, so `sqlr_varchar(255)` and `"varchar(255)"` mean the same
-thing. Check constraints go in the same way, via
-`sqlr_check("total > 0")`.
+Types are given either as objects or as their SQL-standard spelling, so
+`sqlr_varchar(255)` and `"varchar(255)"` mean the same thing. Check
+constraints go in the same way, via `sqlr_check("total > 0")`.
 
 ## Rendering