property.R

#' Define a new property
#'
#' @description
#' A property defines a named component of an object. Properties are
#' typically used to store (meta) data about an object, and are often
#' limited to a data of a specific `class`.
#'
#' By specifying a `getter` and/or `setter`, you can make the property
#' "dynamic" so that it's computed when accessed or has some non-standard
#' behaviour when modified.
#'
#' @param name Property name, primarily used for error messages.
#' @param class If specified, any values must be one of these classes
#'   (or [class union][new_union]).
#' @param getter An optional function used to get the value. The function
#'   should take `self`  as its sole argument and return the value. If the
#'   property has a `class` the class of the value is validated.
#'
#'   If a property has a getter but doesn't have a setter, it is read only.
#' @param setter An optional function used to set the value. The function
#'   should take `self` and `value` and return a modified object. The value is
#'   _not_ automatically checked.
#' @param default When an object is created and the property is not supplied,
#'   what should it default to? If `NULL`, defaults to the "empty" instance
#'   of `class`.
#' @export
#' @examples
#' # Simple properties store data inside an object
#' pizza <- new_class("pizza", properties = list(
#'   new_property("slices", "numeric", default = 10)
#' ))
#' my_pizza <- pizza(slices = 6)
#' my_pizza@slices
#' my_pizza@slices <- 5
#' my_pizza@slices
#'
#' your_pizza <- pizza()
#' your_pizza@slices
#'
#' # Dynamic properties can compute on demand
#' clock <- new_class("clock", properties = list(
#'   new_property("now", getter = function(self) Sys.time())
#' ))
#' my_clock <- clock()
#' my_clock@now; Sys.sleep(1)
#' my_clock@now
#' # This property is read only
#' try(my_clock@now <- 10)
#'
#' # These can be useful if you want to deprecate a property
#' person <- new_class("person", properties = list(
#'   first_name = "character",
#'   new_property(
#'      "firstName",
#'      getter = function(self) {
#'        warning("@firstName is deprecated; please use @first_name instead", call. = FALSE)
#'        self@first_name
#'      },
#'      setter = function(self, value) {
#'        warning("@firstName is deprecated; please use @first_name instead", call. = FALSE)
#'        self@first_name <- value
#'        self
#'      }
#'    )
#' ))
#' hadley <- person(first_name = "Hadley")
#' hadley@firstName
#' hadley@firstName <- "John"
#' hadley@first_name
new_property <- function(name, class = any_class, getter = NULL, setter = NULL, default = NULL) {
  check_name(name)

  class <- as_class(class)
  if (!is.null(default) && !class_inherits(default, class)) {
    msg <- sprintf("`default` must be an instance of %s, not a %s", class_desc(class), obj_desc(default))
    stop(msg)
  }

  if (!is.null(getter)) {
    check_function(getter, alist(self = ))
  }
  if (!is.null(setter)) {
    check_function(setter, alist(self = , value = ))
  }

  out <- list(
    name = name,
    class = class,
    getter = getter,
    setter = setter,
    default = default
  )
  class(out) <- "R7_property"

  out
}

check_name <- function(name, arg = deparse(substitute(name))) {
  if (length(name) != 1 || !is.character(name)) {
    msg <- sprintf("`%s` must be a single string", arg)
    stop(msg, call. = FALSE)
  }
  if (is.na(name) || name == "") {
    msg <- sprintf("`%s` must not be \"\" or NA", arg)
    stop(msg, call. = FALSE)
  }
}

is_property <- function(x) inherits(x, "R7_property")

#' @export
print.R7_property <- function(x, ...) {
  cat("<R7_property> \n")
  str_nest(x, "$", ...)
}

#' @export
str.R7_property <- function(object, ..., nest.lev = 0) {
  cat(if (nest.lev > 0) " ")
  print(object, ..., nest.lev = nest.lev)
}

prop_default <- function(prop) {
  prop$default %||% class_construct(prop$class)
}

#' Get/set a property
#'
#' - `prop(x, "name")` / `prop@name` get the value of the a property,
#'   erroring if it the property doesn't exist.
#' - `prop(x, "name") <- value` / `prop@name <- value` set the value of
#'   a property.
#'
#' @param object An object from a R7 class
#' @param name The name of the parameter as a character. Partial matching
#'   is not performed.
#' @param value A new value for the property. The object is automatically
#'   checked for validity after the replacement is done.
#' @export
#' @examples
#' horse <- new_class("horse", properties = list(
#'   name = "character",
#'   colour = "character",
#'   height = "numeric"
#' ))
#' lexington <- horse(colour = "bay", height = 15, name = "Lex")
#' lexington@colour
#' prop(lexington, "colour")
#'
#' lexington@height <- 14
#' prop(lexington, "height") <- 15
prop <- function(object, name) {
  check_R7(object)

  if (prop_exists(object, name)) {
    prop_val(object, name)
  } else if (method_exists(object, name)) {
    method_val(object, name)
  } else {
    stop(prop_error_unknown(object, name))
  }
}

# Internal helper that assumes the property exists
prop_val <- function(object, name) {
  val <- attr(object, name, exact = TRUE)
  if (is.null(val)) {
    prop <- prop_obj(object, name)
    if (!is.null(prop$getter)) {
      val <- prop$getter(object)
    }
  }
  val
}

# Get underlying property object from class
prop_obj <- function(object, name) {
  class <- R7_class(object)
  attr(class, "properties")[[name]]
}

#' @rdname prop
#' @param check If `TRUE`, check that `value` is of the correct type and run
#'   [validate()] on the object before returning.
#' @export
`prop<-` <- local({
  # This flag is used to avoid infinate loops if you are assigning a property from a setter function
  setter_property <- NULL

  function(object, name, check = TRUE, value) {
    check_R7(object)

    prop <- prop_obj(object, name)
    if (is.null(prop)) {
      stop(prop_error_unknown(object, name), call. = FALSE)
    }

    if (!is.null(prop$getter) && is.null(prop$setter)) {
      msg <- sprintf("Can't set read-only property %s@%s", obj_desc(object), name)
      stop(msg, call. = FALSE)
    }

    if (!is.null(prop$setter) && !identical(setter_property, name)) {
      setter_property <<- name
      on.exit(setter_property <<- NULL, add = TRUE)
      object <- prop$setter(object, value)
    } else {
      if (isTRUE(check) && !class_inherits(value, prop$class)) {
        stop(prop_error_type(object, name, prop$class, value), call. = FALSE)
      }
      attr(object, name) <- value
    }

    if (isTRUE(check)) {
      validate(object, properties = FALSE)
    }

    invisible(object)
  }
})

prop_error_unknown <- function(object, prop_name) {
  sprintf("Can't find property %s@%s", obj_desc(object), prop_name)
}

prop_error_type <- function(object, prop_name, expected, actual, show_type = TRUE) {
  sprintf("%s@%s must be %s, not %s",
    if (show_type) obj_desc(object) else "",
    prop_name,
    class_desc(expected),
    obj_desc(actual)
  )
}

#' @rdname prop
#' @usage object@name
#' @export
`@` <- function(object, name) {
  if (inherits(object, "R7_object")) {
    name <- as.character(substitute(name))
    prop(object, name)
  } else {
    name <- substitute(name)
    do.call(base::`@`, list(object, name))
  }
}

#' @rawNamespace S3method("@<-",R7_object)
`@<-.R7_object` <- function(object, name, value) {
  nme <- as.character(substitute(name))
  prop(object, nme) <- value

  invisible(object)
}


#' Property introspection
#'
#' - `prop_names(x)` returns the names of the properties
#' - `prop_exists(x, "prop")` returns `TRUE` iif `x` has property `prop`.
#'
#' @inheritParams prop
#' @export
prop_names <- function(object) {
  check_R7(object)

  if (inherits(object, "R7_class")) {
    # R7_class isn't a R7_class (somewhat obviously) so we fake the property names
    c("name", "parent", "package", "properties", "methods", "constructor", "validator")
  } else {
    class <- R7_class(object)
    props <- attr(class, "properties", exact = TRUE)
    if (length(props) == 0) {
      character()
    } else {
      names(props)
    }
  }
}

#' @rdname prop_names
#' @export
prop_exists <- function(object, name) {
  check_R7(object)
  name %in% prop_names(object)
}

#' Get/set multiple properties
#'
#' - `props(x)` returns all properties.
#' - `props(x) <- list(name1 = val1, name2 = val2)` sets multiple properties.
#'
#' @importFrom stats setNames
#' @inheritParams prop
#' @export
#' @examples
#' horse <- new_class("horse", properties = list(
#'   name = "character",
#'   colour = "character",
#'   height = "numeric"
#' ))
#' lexington <- horse(colour = "bay", height = 15, name = "Lex")
#'
#' props(lexington)
#' props(lexington) <- list(height = 14, name = "Lexigonton")
#' lexington
props <- function(object) {
  check_R7(object)
  prop_names <- prop_names(object)
  if (length(prop_names) == 0) {
    list()
  } else {
    setNames(lapply(prop_names, prop, object = object), prop_names)
  }
}
#' @rdname props
#' @export
#' @param value A named list of values. The object is checked for validity
#'   only after all replacements are performed.
`props<-` <- function(object, value) {
  check_R7(object)
  stopifnot(is.list(value))

  for (name in names(value)) {
    prop(object, name, check = FALSE) <- value[[name]]
  }
  validate(object)

  object
}

as_properties <- function(x) {
  if (length(x) == 0) {
    return(list())
  }

  if (!is.list(x)) {
    stop("`properties` must be a list", call. = FALSE)
  }

  out <- Map(as_property, x, names2(x), seq_along(x))
  names(out) <- vcapply(out, function(x) x[["name"]])

  if (anyDuplicated(names(out))) {
    stop("`properties` names must be unique", call. = FALSE)
  }

  out
}

as_property <- function(x, name, i) {
  if (is_property(x)) {
    x
  } else {
    if (name == "") {
      msg <- sprintf("`property[[%i]]` is missing a name", i)
      stop(msg, call. = FALSE)
    }
    class <- as_class(x, arg = sprintf("property$%s", name))
    new_property(name, class = x)
  }
}