Implement as_api_object() as generic. (#74)

(And rename as_rapid_class to as_api_object) And thus greatly simplify all of the other as_*() functions! Closes #72.
jonthegeek · Oct 23, 2023 · 7c40a2a · 7c40a2a
1 parent 9b09e83
commit 7c40a2a
Show file tree

Hide file tree

Showing 55 changed files with 484 additions and 582 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -2,6 +2,7 @@
 
 export(api_key_security_scheme)
 export(as_api_key_security_scheme)
+export(as_api_object)
 export(as_component_collection)
 export(as_contact)
 export(as_info)
@@ -12,7 +13,6 @@ export(as_oauth2_security_scheme)
 export(as_oauth2_token_flow)
 export(as_origin)
 export(as_rapid)
-export(as_rapid_class)
 export(as_scopes)
 export(as_security_requirements)
 export(as_security_scheme)
@@ -21,6 +21,8 @@ export(as_security_scheme_details)
 export(as_server_variables)
 export(as_servers)
 export(as_string_replacements)
+export(caller_arg)
+export(caller_env)
 export(class_origin)
 export(component_collection)
 export(contact)
@@ -48,6 +50,8 @@ importFrom(S7,class_missing)
 importFrom(S7,prop)
 importFrom(glue,glue)
 importFrom(rlang,"%||%")
+importFrom(rlang,caller_arg)
+importFrom(rlang,caller_env)
 importFrom(rlang,check_dots_empty)
 importFrom(stbl,stabilize_chr_scalar)
 importFrom(stbl,to_chr_scalar)

diff --git a/R/absolute_paths.R b/R/absolute_paths.R
@@ -13,7 +13,7 @@ NULL
 #' @return A `rapid` object as returned by [rapid()], with absolute server
 #'   paths.
 #' @export
-expand_servers <- S7::new_generic("expand_servers", dispatch_args = "x")
+expand_servers <- S7::new_generic("expand_servers", "x")
 
 S7::method(expand_servers, rapid) <- function(x) {
   if (length(x@servers@url)) {
@@ -37,8 +37,8 @@ S7::method(expand_servers, rapid) <- function(x) {
 }
 
 S7::method(expand_servers, class_any) <- function(x,
-                                                  arg = rlang::caller_arg(x),
-                                                  call = rlang::caller_env()) {
+                                                  arg = caller_arg(x),
+                                                  call = caller_env()) {
   cli::cli_abort(
     "{.arg {arg}} {.cls {class(x)}} must be a {.cls rapid}.",
     call = call

diff --git a/R/as.R b/R/as.R
@@ -1,6 +1,6 @@
-#' Convert to a rapid-style class
+#' Convert to a rapid-style object
 #'
-#' Convert a named list into a rapid-style class.
+#' Convert a named list into an object with a rapid-style class.
 #'
 #' @inheritParams rlang::args_dots_empty
 #' @inheritParams rlang::args_error_context
@@ -14,11 +14,34 @@
 #'
 #' @return An object with the specified `target_class`.
 #' @export
-as_rapid_class <- function(x,
-                           target_class,
-                           alternate_names = NULL,
-                           arg = rlang::caller_arg(x),
-                           call = rlang::caller_env()) {
+as_api_object <- S7::new_generic(
+  "as_api_object",
+  "x",
+  function(x,
+           target_class,
+           ...,
+           alternate_names = NULL,
+           arg = caller_arg(x),
+           call = caller_env()) {
+    if (missing(x)) return(target_class())
+    force(arg)
+    rlang::check_dots_empty(call = call)
+    if (S7::S7_inherits(x, target_class)) {
+      return(x)
+    }
+    S7::S7_dispatch()
+  }
+)
+
+S7::method(
+  as_api_object,
+  class_list | class_character
+) <- function(x,
+              target_class,
+              ...,
+              alternate_names = NULL,
+              arg = caller_arg(x),
+              call = caller_env()) {
   force(arg)
   x <- .validate_for_as_class(
     x,
@@ -32,11 +55,37 @@ as_rapid_class <- function(x,
   })
 }
 
+S7::method(
+  as_api_object,
+  NULL | S7::new_S3_class("S7_missing")
+) <- function(x,
+              target_class,
+              ...,
+              alternate_names = NULL,
+              arg = caller_arg(x),
+              call = caller_env()) {
+  target_class()
+}
+
+S7::method(as_api_object, class_any) <- function(x,
+                                                 target_class,
+                                                 ...,
+                                                 alternate_names = NULL,
+                                                 arg = caller_arg(x),
+                                                 call = caller_env()) {
+  target_class_nm <- class(target_class())[[1]]
+  cli::cli_abort(
+    "Can't coerce {.arg {arg}} {.cls {class(x)}} to {.cls {target_class_nm}}.",
+    class = "rapid_error_unknown_coercion",
+    call = call
+  )
+}
+
 .validate_for_as_class <- function(x,
                                    target_class,
                                    alternate_names = NULL,
-                                   x_arg = rlang::caller_arg(x),
-                                   call = rlang::caller_env()) {
+                                   x_arg = caller_arg(x),
+                                   call = caller_env()) {
   if (!length(x)) {
     return(NULL)
   }

diff --git a/R/components-security_scheme-api_key.R b/R/components-security_scheme-api_key.R
@@ -70,38 +70,16 @@ S7::method(length, api_key_security_scheme) <- function(x) {
 #' @return An `api_key_security_scheme` as returned by
 #'   [api_key_security_scheme()].
 #' @export
-as_api_key_security_scheme <- S7::new_generic(
-  "as_api_key_security_scheme",
-  dispatch_args = "x"
-)
-
-S7::method(as_api_key_security_scheme, api_key_security_scheme) <- function(x) {
-  x
-}
-
-S7::method(
-  as_api_key_security_scheme,
-  class_list | class_character
-) <- function(x) {
-  as_rapid_class(
+as_api_key_security_scheme <- function(x,
+                                       ...,
+                                       arg = caller_arg(x),
+                                       call = caller_env()) {
+  as_api_object(
     x,
     api_key_security_scheme,
-    alternate_names = c("in" = "location", "name" = "parameter_name")
-  )
-}
-
-S7::method(
-  as_api_key_security_scheme,
-  class_missing | NULL | S7::new_S3_class("S7_missing")
-) <- function(x) {
-  api_key_security_scheme()
-}
-
-S7::method(
-  as_api_key_security_scheme,
-  class_any
-) <- function(x, ..., arg = rlang::caller_arg(x)) {
-  cli::cli_abort(
-    "Can't coerce {.arg {arg}} {.cls {class(x)}} to {.cls api_key_security_scheme}."
+    ...,
+    alternate_names = c("in" = "location", "name" = "parameter_name"),
+    arg = arg,
+    call = call
   )
 }
diff --git a/R/components-security_scheme-oauth2-authorization_code_flow.R b/R/components-security_scheme-oauth2-authorization_code_flow.R
@@ -77,37 +77,9 @@ S7::method(length, oauth2_authorization_code_flow) <- function(x) {
 #' @return An `oauth2_authorization_code_flow` as returned by
 #'   [oauth2_authorization_code_flow()].
 #' @export
-as_oauth2_authorization_code_flow <- S7::new_generic(
-  "as_oauth2_authorization_code_flow",
-  dispatch_args = "x"
-)
-
-S7::method(
-  as_oauth2_authorization_code_flow,
-  oauth2_authorization_code_flow
-) <- function(x) {
-  x
-}
-
-S7::method(
-  as_oauth2_authorization_code_flow,
-  class_list | class_character
-) <- function(x) {
-  as_rapid_class(x, oauth2_authorization_code_flow)
-}
-
-S7::method(
-  as_oauth2_authorization_code_flow,
-  class_missing | NULL | S7::new_S3_class("S7_missing")
-) <- function(x) {
-  oauth2_authorization_code_flow()
-}
-
-S7::method(
-  as_oauth2_authorization_code_flow,
-  class_any
-) <- function(x, ..., arg = rlang::caller_arg(x)) {
-  cli::cli_abort(
-    "Can't coerce {.arg {arg}} {.cls {class(x)}} to {.cls oauth2_authorization_code_flow}."
-  )
+as_oauth2_authorization_code_flow <- function(x,
+                                              ...,
+                                              arg = caller_arg(x),
+                                              call = caller_env()) {
+  as_api_object(x, oauth2_authorization_code_flow, ..., arg = arg, call = call)
 }
diff --git a/R/components-security_scheme-oauth2-implicit_flow.R b/R/components-security_scheme-oauth2-implicit_flow.R
@@ -66,34 +66,9 @@ S7::method(length, oauth2_implicit_flow) <- function(x) {
 #'
 #' @return An `oauth2_implicit_flow` as returned by [oauth2_implicit_flow()].
 #' @export
-as_oauth2_implicit_flow <- S7::new_generic(
-  "as_oauth2_implicit_flow",
-  dispatch_args = "x"
-)
-
-S7::method(as_oauth2_implicit_flow, oauth2_implicit_flow) <- function(x) {
-  x
-}
-
-S7::method(
-  as_oauth2_implicit_flow,
-  class_list | class_character
-) <- function(x) {
-  as_rapid_class(x, oauth2_implicit_flow)
-}
-
-S7::method(
-  as_oauth2_implicit_flow,
-  class_missing | NULL | S7::new_S3_class("S7_missing")
-) <- function(x) {
-  oauth2_implicit_flow()
-}
-
-S7::method(
-  as_oauth2_implicit_flow,
-  class_any
-) <- function(x, ..., arg = rlang::caller_arg(x)) {
-  cli::cli_abort(
-    "Can't coerce {.arg {arg}} {.cls {class(x)}} to {.cls oauth2_implicit_flow}."
-  )
+as_oauth2_implicit_flow <- function(x,
+                                    ...,
+                                    arg = caller_arg(x),
+                                    call = caller_env()) {
+  as_api_object(x, oauth2_implicit_flow, ..., arg = arg, call = call)
 }
diff --git a/R/components-security_scheme-oauth2-scopes.R b/R/components-security_scheme-oauth2-scopes.R
@@ -69,25 +69,19 @@ S7::method(length, scopes) <- function(x) {
 #'
 #' @return A `scopes` as returned by [scopes()].
 #' @export
-as_scopes <- S7::new_generic(
-  "as_scopes",
-  dispatch_args = "x"
-)
-
-S7::method(as_scopes, scopes) <- function(x) {
-  x
-}
+as_scopes <- S7::new_generic("as_scopes", "x")
 
 S7::method(
   as_scopes,
   class_list | class_character
-) <- function(x, ..., arg = rlang::caller_arg(x)) {
+) <- function(x, ..., arg = caller_arg(x), call = caller_env()) {
   force(arg)
   x <- unlist(x)
   x <- stbl::stabilize_chr(x, x_arg = arg)
   if (!rlang::is_named2(x)) {
     cli::cli_abort(
       "{.arg {arg}} must be a named character vector.",
+      call = call
     )
   }
   scopes(
@@ -96,17 +90,9 @@ S7::method(
   )
 }
 
-S7::method(
-  as_scopes,
-  class_missing | NULL | S7::new_S3_class("S7_missing")
-) <- function(x) {
-  scopes()
-}
-
 S7::method(as_scopes, class_any) <- function(x,
                                              ...,
-                                             arg = rlang::caller_arg(x)) {
-  cli::cli_abort(
-    "Can't coerce {.arg {arg}} {.cls {class(x)}} to {.cls scopes}."
-  )
+                                             arg = caller_arg(x),
+                                             call = caller_env()) {
+  as_api_object(x, scopes, ..., arg = arg, call = call)
 }
diff --git a/R/components-security_scheme-oauth2-token_flow.R b/R/components-security_scheme-oauth2-token_flow.R
@@ -73,31 +73,9 @@ S7::method(length, oauth2_token_flow) <- function(x) {
 #'
 #' @return An `oauth2_token_flow` as returned by [oauth2_token_flow()].
 #' @export
-as_oauth2_token_flow <- S7::new_generic(
-  "as_oauth2_token_flow",
-  dispatch_args = "x"
-)
-
-S7::method(as_oauth2_token_flow, oauth2_token_flow) <- function(x) {
-  x
-}
-
-S7::method(as_oauth2_token_flow, class_list | class_character) <- function(x) {
-  as_rapid_class(x, oauth2_token_flow)
-}
-
-S7::method(
-  as_oauth2_token_flow,
-  class_missing | NULL | S7::new_S3_class("S7_missing")
-) <- function(x) {
-  oauth2_token_flow()
-}
-
-S7::method(
-  as_oauth2_token_flow,
-  class_any
-) <- function(x, ..., arg = rlang::caller_arg(x)) {
-  cli::cli_abort(
-    "Can't coerce {.arg {arg}} {.cls {class(x)}} to {.cls oauth2_token_flow}."
-  )
+as_oauth2_token_flow <- function(x,
+                                 ...,
+                                 arg = caller_arg(x),
+                                 call = caller_env()) {
+  as_api_object(x, oauth2_token_flow, ..., arg = arg, call = call)
 }