Implement rapid class

NAMESPACE

@@ -1,11 +1,18 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(length,"rapid::api_contact")
+S3method(length,"rapid::api_info")
+S3method(length,"rapid::api_license")
+S3method(length,"rapid::rapid")
+S3method(length,"rapid::server_variable")
+S3method(length,"rapid::servers")
 export(api_contact)
 export(api_info)
 export(api_license)
-export(server)
+export(rapid)
 export(server_variable)
 export(server_variable_list)
+export(servers)
 if (getRversion() < "4.3.0") importFrom("S7", "@")
 importFrom(glue,glue)
 importFrom(rlang,"%||%")

R/00-properties.R

@@ -1,6 +1,6 @@
 # These should probably be defined in a separate package.
 
-character_scalar_property <- function(x_arg, regex = NULL) {
+character_scalar_property <- function(x_arg, ...) {
   S7::new_property(
     class = S7::class_character,
     setter = function(self, value) {
@@ -9,17 +9,17 @@ character_scalar_property <- function(x_arg, regex = NULL) {
       value <- stbl::stabilize_chr_scalar(
         value,
         allow_null = FALSE,
-        regex = regex,
         x_arg = x_arg,
-        call = call
+        call = call,
+        ...
       )
       S7::prop(self, x_arg, check = FALSE) <- value
       self
     }
   )
 }
 
-character_property <- function(x_arg, regex = NULL) {
+character_property <- function(x_arg, ...) {
   S7::new_property(
     class = S7::class_character,
     setter = function(self, value) {
@@ -28,9 +28,9 @@ character_property <- function(x_arg, regex = NULL) {
       value <- stbl::stabilize_chr(
         value,
         allow_null = FALSE,
-        regex = regex,
         x_arg = x_arg,
-        call = call
+        call = call,
+        ...
       )
       S7::prop(self, x_arg, check = FALSE) <- value
       self

R/01-info_contact.R

@@ -29,3 +29,8 @@ api_contact <- S7::new_class(
     url = url_scalar_property("url")
   )
 )
+
+#' @export
+`length.rapid::api_contact` <- function(x) {
+  .prop_length_max(x)
+}

R/01-info_license.R

@@ -43,7 +43,13 @@ api_license <- S7::new_class(
   },
   validator = function(self) {
     if (length(self@identifier) && length(self@url)) {
-      "At most one of @identifier and @url must be supplied."
+      return("At most one of @identifier and @url must be supplied.")
     }
+    validate_parallel(self, key = "name", optional = c("identifier", "url"))
   }
 )
+
+#' @export
+`length.rapid::api_license` <- function(x) {
+  length(x@name)
+}

R/01-server_variable.R

@@ -65,3 +65,8 @@ server_variable <- S7::new_class(
     )
   }
 )
+
+#' @export
+`length.rapid::server_variable` <- function(x) {
+  length(x@name)
+}

R/02-info.R

@@ -45,3 +45,8 @@ api_info <- S7::new_class(
     version = character_scalar_property("version")
   )
 )
+
+#' @export
+`length.rapid::api_info` <- function(x) {
+  .prop_length_max(x)
+}

R/03-server.R → R/03-servers.R

@@ -6,12 +6,12 @@
 #' @param description A list of [server_variable()] objects.
 #' @param variables [server_variable_list()] object.
 #'
-#' @return A `server` S7 object, with properties `url`, `description`, and
+#' @return A `servers` S7 object, with properties `url`, `description`, and
 #'   `variables`.
 #' @export
 #'
 #' @examples
-#' server(
+#' servers(
 #'   url = c(
 #'     "https://development.gigantic-server.com/v1",
 #'     "https://staging.gigantic-server.com/v1",
@@ -23,7 +23,7 @@
 #'     "Production server"
 #'   )
 #' )
-#' server(
+#' servers(
 #'   url = "https://{username}.gigantic-server.com:{port}/{basePath}",
 #'   description = "The production API server",
 #'   variables = server_variable_list(server_variable(
@@ -40,8 +40,8 @@
 #'     )
 #'   ))
 #' )
-server <- S7::new_class(
-  "server",
+servers <- S7::new_class(
+  "servers",
   package = "rapid",
   properties = list(
     url = url_property("url"),
@@ -56,3 +56,8 @@ server <- S7::new_class(
     )
   }
 )
+
+#' @export
+`length.rapid::servers` <- function(x) {
+  length(x@url)
+}

R/99-rapid.R

@@ -0,0 +1,56 @@
+#' R API definition object
+#'
+#' An object that represents an API.
+#'
+#' @param info An `api_info` object defined by [api_info()].
+#' @param servers A `servers` object defined by [servers()].
+#'
+#' @return A `rapid` S7 object, with properties `info` and `servers`.
+#' @export
+#'
+#' @examples
+#' rapid()
+#' rapid(
+#'   info = api_info(title = "A", version = "1"),
+#'   servers(
+#'     url = "https://development.gigantic-server.com/v1"
+#'   )
+#' )
+#' rapid(
+#'   info = api_info(title = "A", version = "1"),
+#'   servers(
+#'     url = c(
+#'       "https://development.gigantic-server.com/v1",
+#'       "https://staging.gigantic-server.com/v1",
+#'       "https://api.gigantic-server.com/v1"
+#'     ),
+#'     description = c(
+#'       "Development server",
+#'       "Staging server",
+#'       "Production server"
+#'     )
+#'   )
+#' )
+rapid <- S7::new_class(
+  "rapid",
+  package = "rapid",
+  properties = list(
+    info = api_info,
+    servers = servers
+  ),
+  validator = function(self) {
+    validate_lengths(
+      self,
+      key = "info",
+      # In this case the max length is redundant, since api_info can only have
+      # length 0 or 1.
+      key_max_length = 1,
+      optional_any = "servers"
+    )
+  }
+)
+
+#' @export
+`length.rapid::rapid` <- function(x) {
+  length(x@info)
+}

R/length.R

@@ -0,0 +1,5 @@
+.prop_length_max <- function(obj) {
+  max(
+    .prop_lengths(obj, S7::prop_names(obj))
+  )
+}

R/rapid-package.R

@@ -1,6 +1,3 @@
-#' @keywords internal
-"_PACKAGE"
-
 ## usethis namespace: start
 #' @importFrom glue glue
 #' @importFrom rlang %||%

R/utils.R

@@ -0,0 +1,8 @@
+.prop_lengths <- function(obj, prop_names) {
+  purrr::map_int(
+    prop_names,
+    \(prop_name) {
+      length(S7::prop(obj, prop_name))
+    }
+  )
+}

R/validate_lengths.R

@@ -0,0 +1,121 @@
+validate_lengths <- function(obj,
+                             key,
+                             key_max_length = NULL,
+                             required_same = NULL,
+                             required_any = NULL,
+                             optional_same = NULL,
+                             optional_any = NULL) {
+  key_len <- .prop_lengths(obj, key)
+
+  if (!is.null(key_max_length) && key_len > key_max_length) {
+    return(
+      c(
+        cli::format_inline(
+          "{.arg {key}} must have at most {key_max_length) value{?s}."
+        ),
+        .msg_sizes(key, key_len)
+      )
+    )
+  }
+
+  if (!key_len) {
+    return(.msg_empty(
+      key,
+      c(required_same, required_any, optional_same, optional_any),
+      .prop_lengths(
+        obj,
+        c(required_same, required_any, optional_same, optional_any)
+      )
+    ))
+  }
+
+  if (!is.null(required_same)) {
+    required_same_lens <- .prop_lengths(obj, required_same)
+    if (!all(required_same_lens == key_len)) {
+      return(.msg_same(key, key_len, required_same, required_same_lens))
+    }
+  }
+
+  if (!is.null(required_any)) {
+    required_any_lens <- .prop_lengths(obj, required_any)
+    if (!all(required_any_lens)) {
+      return(.msg_non_empty(key, required_any, required_any_lens))
+    }
+  }
+
+  if (!is.null(optional_same)) {
+    optional_same_lens <- .prop_lengths(obj, optional_same)
+    if (any(optional_same_lens & optional_same_lens != key_len)) {
+      return(
+        .msg_same_or_empty(key, key_len, optional_same, optional_same_lens)
+      )
+    }
+  }
+}
+
+.msg_same <- function(key_name, key_length, prop_names, prop_lengths) {
+  bad_lengths <- prop_lengths != key_length
+  not_same <- prop_names[bad_lengths]
+  return(
+    c(
+      cli::format_inline(
+        "{.arg {not_same}} must have the same length as {.arg {key_name}}"
+      ),
+      .msg_sizes(key_name, key_length),
+      .msg_sizes(not_same, prop_lengths[bad_lengths])
+    )
+  )
+}
+
+.msg_non_empty <- function(key_name, prop_names, prop_lengths) {
+  bad_lengths <- !prop_lengths
+  if (any(bad_lengths)) {
+    empty <- prop_names[bad_lengths]
+    return(cli::format_inline(
+      "When {.arg {key_name}} is defined, {.arg {empty}} must not be empty."
+    ))
+  }
+}
+
+.msg_same_or_empty <- function(key_name, key_length, prop_names, prop_lengths) {
+  bad_lengths <- prop_lengths & prop_lengths != key_length
+  if (any(bad_lengths)) {
+    bad_size <- prop_names[bad_lengths]
+    return(
+      c(
+        cli::format_inline(
+          "{.arg {bad_size}} must be empty or have the same length as {.arg {key_name}}"
+        ),
+        .msg_sizes(key_name, key_length),
+        .msg_sizes(bad_size, prop_lengths[bad_lengths])
+      )
+    )
+  }
+}
+
+.msg_empty <- function(key_name, prop_names, prop_lengths = NULL) {
+  bad_lengths <- prop_lengths > 0
+  if (any(bad_lengths)) {
+    not_empty <- prop_names[bad_lengths]
+    return(
+      c(
+        cli::format_inline(
+          "When {.arg {key_name}} is not defined, {.arg {not_empty}} must be empty."
+        ),
+        .msg_sizes(not_empty, prop_lengths[bad_lengths])
+      )
+    )
+  }
+}
+
+.msg_sizes <- function(prop_names, prop_lengths) {
+  purrr::map2_chr(
+    prop_names,
+    prop_lengths,
+    \(prop_name, prop_length) {
+      cli::format_inline(
+        "{.arg {prop_name}} has {cli::no(prop_length)} value{?s}."
+      )
+    }
+  )
+}