Refactor types

Author: stfnkth

NAMESPACE

@@ -6,7 +6,6 @@ S3method(print,typewriter)
 export(base_model)
 export(check_args)
 export(dtype)
-export(either)
 export(is_any)
 export(is_typewriter_model)
 export(model_dump)

R/errors.R

@@ -23,7 +23,7 @@ create_type_check_error_message <- function(error) {
 
   msg <- c(
     glue::glue("---\nType check failed for '{error$name}'"),
-    paste0("value:", value_text),
+    paste("value:", value_text),
     paste("type:", typeof(value)),
     paste("class:", class_text),
     paste("length:", length(value)),

R/types.R

@@ -19,12 +19,12 @@ is_any <- function(x) TRUE
 
 # ---
 # DEPRECATED
-Any <- function(n = NULL) {
-  if (is.null(x)) {
-    return(is_any)
-  }
-  return(function(x) length(x) == n)
-}
+#Any <- function(n = NULL) {
+#  if (is.null(x)) {
+#    return(is_any)
+#  }
+#  return(function(x) length(x) == n)
+#}
 
 #' Type predicate `typewriter model`
 #' @param model_fn A model factory function created with [base_model()].
@@ -46,7 +46,11 @@ create_model_field <- function(
     n = NULL,
     optional = FALSE) {
   # Body
-  type_str <- match.arg(dtype)
+  dtype <- match.arg(dtype)
+  if (dtype == "any") {
+    return(model_field(fn = is_any))
+  }
+
   base_fn <- function(x) typeof(x) == dtype
   if (dtype == "logical") {
     base_fn <- is_logical
@@ -124,123 +128,27 @@ as_model_field <- function(x) {
   model_field_from_vec(x)
 }
 
-# ---
-#' Create a model field
-#' @param x A type check function or type string.
-#' @param default A default value.
-#' @param optional description
-#' @returns A type check function
-#' @export
-dtype <- function(x, default = NA, optional = FALSE) {
-  field <- as_model_field(x)
-  field$default <- default
-  field$optional <- optional
-  return(field)
-}
-
-# ---
-# Helper
-# DEPRECATED
-as_type_check_func <- function(type_check) {
-  if (is.character(type_check)) {
-    type_check <- type_check_fn_from_str(type_check)
-  }
-
-  rlang::as_function(type_check)
-}
-#### DEPRECATED ####
-
-# ---
 #' Mark a parameter as optional
-#' @param type_check_fn Type check function or type string.
-#' @example examples/api/type-is-optional.R
-#' @returns type check function
+#' @param obj A type definition object.
+#' @returns A [model_field()] with `optional = TRUE`.
 #' @export
-# TODO: Refactor to support model_fields
-optional <- function(type_check_fn) {
-  if (inherits(type_check_fn, CLASS_MODEL_FIELD)) {
-    stop(CLASS_MODEL_FIELD, " objects are not supported.")
+optional <- function(obj) {
+  if (!inherits(obj, CLASS_MODEL_FIELD)) {
+    obj <- as_model_field(obj)
   }
 
-  type_check_fn <- as_type_check_func(type_check_fn)
-  new_type_check_fn <- structure(
-    function(x) type_check_fn(x) | rlang::is_na(x),
-    base_func = type_check_fn
-  )
-  new_type_check_fn
+  obj$optional <- TRUE
+  return(obj)
 }
 
 # ---
-#' Allow multiple types
-#' @param ... Type check functions or type strings
-#' @returns A type check function
-#' @example examples/api/types-union.R
+#' Create a model field/type definition
+#' @param x A type check function or type string.
+#' @param default A default value.
+#' @returns A [model_field()].
 #' @export
-either <- function(...) {
-  fns <- lapply(list(...), as_type_check_func)
-  structure(
-    function(x) {
-      any(unlist(lapply(fns, function(fn) fn(x))))
-    },
-    base_func = fns
-  )
-}
-
-# ---
-# Helper
-base_type <- function(
-    type_str = c("integer", "double", "character", "logical", "list", "raw", "complex", "any"),
-    n = NULL,
-    default = NA) {
-  match.arg(type_str)
-  if (type_str == "any") {
-    return(is_any)
-  }
-
-  body <- substitute(typeof(x) == dtype, list(dtype = type_str))
-
-  if (is_not_null(n)) {
-    body <- substitute(
-      typeof(x) == dtype & length(x) == n,
-      list(dtype = type_str, n = as.integer(n))
-    )
-  }
-
-  fn <- rlang::new_function(alist(x = ), body)
-  if (!is.na(default)) {
-    return(model_field(fn, default))
-  }
-
-  return(fn)
-}
-
-# --- Experimental
-
-# ---
-type_integer <- function(n = NULL, default = NA) {
-  base_type("integer", n, default)
-}
-
-# ---
-type_double <- function(n = NULL, default = NA) {
-  base_type("double", n, default)
-}
-
-# ---
-type_character <- function(n = NULL, default = NA) {
-  base_type("character", n, default)
-}
-
-# ---
-type_logical <- function(n = NULL, default = NA) {
-  base_type("logical", n, default)
-}
-
-# ---
-# DEPRECATED
-dtype_integer <- function(n = NULL) {
-  fn <- function(x) {
-    typeof(x) == "integer" & length(x) == n
-  }
-  structure(fn, dtype = "integer", n = n)
+dtype <- function(x, default = NA) {
+  field <- as_model_field(x)
+  field$default <- default
+  return(field)
 }

_obsolete/types-obs.R

@@ -0,0 +1,106 @@
+# ---
+# Helper
+# DEPRECATED
+as_type_check_func <- function(type_check) {
+  if (is.character(type_check)) {
+    type_check <- type_check_fn_from_str(type_check)
+  }
+
+  rlang::as_function(type_check)
+}
+#### DEPRECATED ####
+
+# ---
+#' Mark a parameter as optional
+#' @param type_check_fn Type check function or type string.
+#' @example examples/api/type-is-optional.R
+#' @returns type check function
+#' @export
+# TODO: Refactor to support model_fields
+optional_obs <- function(type_check_fn) {
+  if (inherits(type_check_fn, CLASS_MODEL_FIELD)) {
+    stop(CLASS_MODEL_FIELD, " objects are not supported.")
+  }
+
+  type_check_fn <- as_type_check_func(type_check_fn)
+  new_type_check_fn <- structure(
+    function(x) type_check_fn(x) | rlang::is_na(x),
+    base_func = type_check_fn
+  )
+  new_type_check_fn
+}
+
+# ---
+#' Allow multiple types
+#' @param ... Type check functions or type strings
+#' @returns A type check function
+#' @example examples/api/types-union.R
+#' @export
+either <- function(...) {
+  fns <- lapply(list(...), as_type_check_func)
+  structure(
+    function(x) {
+      any(unlist(lapply(fns, function(fn) fn(x))))
+    },
+    base_func = fns
+  )
+}
+
+# ---
+# Helper
+base_type <- function(
+    type_str = c("integer", "double", "character", "logical", "list", "raw", "complex", "any"),
+    n = NULL,
+    default = NA) {
+  match.arg(type_str)
+  if (type_str == "any") {
+    return(is_any)
+  }
+
+  body <- substitute(typeof(x) == dtype, list(dtype = type_str))
+
+  if (is_not_null(n)) {
+    body <- substitute(
+      typeof(x) == dtype & length(x) == n,
+      list(dtype = type_str, n = as.integer(n))
+    )
+  }
+
+  fn <- rlang::new_function(alist(x = ), body)
+  if (!is.na(default)) {
+    return(model_field(fn, default))
+  }
+
+  return(fn)
+}
+
+# --- Experimental
+
+# ---
+type_integer <- function(n = NULL, default = NA) {
+  base_type("integer", n, default)
+}
+
+# ---
+type_double <- function(n = NULL, default = NA) {
+  base_type("double", n, default)
+}
+
+# ---
+type_character <- function(n = NULL, default = NA) {
+  base_type("character", n, default)
+}
+
+# ---
+type_logical <- function(n = NULL, default = NA) {
+  base_type("logical", n, default)
+}
+
+# ---
+# DEPRECATED
+dtype_integer <- function(n = NULL) {
+  fn <- function(x) {
+    typeof(x) == "integer" & length(x) == n
+  }
+  structure(fn, dtype = "integer", n = n)
+}

examples/playground-and-experimental.R

@@ -71,7 +71,7 @@ mtcars_model <- base_model(
     cyl = as.integer,
     gear = as.integer
   ),
-  .model_config = model_config(extra = "forbid")
+  .extra = "forbid"
 )
 
 mtcars_model(mtcars)
@@ -170,3 +170,32 @@ mt <- typed_struct(
 )
 
 mt(a = iris$Sepal.Length, b = TRUE)
+
+# ---
+a_cool_type <- typed_struct(
+  a = "integer",
+  b = optional("logical"),
+  x = optional(dtype("character", "1")),
+  y = optional(character(1))
+)
+
+a_cool_type(a = 1L, b = T, y= LETTERS[1:2])
+
+f_test <- function(a = dtype("integer", 10L)) {
+  check_args()
+  a
+}
+
+f_test(a = 1L)
+f_test()
+
+#
+my_struct <- typed_struct(
+  a = \(a) is.integer(a) & a > 2
+)
+
+my_struct(a = 3L)
+
+df <- data.frame(a = 4:9)
+
+my_struct(df)