R/stimulus-modifiers.R

In tjpalanca/hotwire.R: Hotwire for R

#' @title Stimulus Modifiers
#'
#' @description
#' These modify existing HTML tags so that Stimulus can act upon them.
#'
#' @param controller (str) name of the controller
#' @param ...        (tag) content for the modified tags
#' @param tag        (fun) if it's a multiple tags, then the container tag
#' @param env        (env) calling environment
#'
#' @family Stimulus
#'
#' @name stimulus_modifiers
NULL

#' @describeIn stimulus_modifiers Attach a controller to a tag
#' @param values  (lst) named list of values for this controller
#' @param classes (lst) named list of classes that will be applied/unapplied
#' @export
ss_control <- function(controller,
                       ...,
                       values = list(),
                       classes = list(),
                       tag = tags$div,
                       env = parent.frame()) {

  assert_list(values, names = "named")
  assert_list(classes, names = "named")
  content <- with_options(
    list(hotwire.R.controller = assert_string(controller)),
    html_tags(..., env = env)
  )

  (if (length(content) == 1) content[[1]] else tag(...)) %>%
    add_data(controller = controller) %>%
    when(length(values) > 0,
         add_data(., .list = set_names(
           values, paste0(controller, "-", names(values), "-value")
         ))) %>%
    when(length(classes) > 0,
         add_data(., .list = set_names(
           classes, paste0(controller, "-", names(classes), "-class")
         ))) %>%
    add_class("ss_controlled")

}

#' @describeIn stimulus_modifiers Attach a target action to a tag
#' @param target (str) name of the target
#' @export
ss_target <- function(target,
                      ...,
                      tag = tags$div,
                      controller = getOption("hotwire.R.controller")) {

  assert_string(target)
  assert_string(controller)

  content <- tagList(...)
  (if (length(content) == 1) content[[1]] else tag(...)) %>%
    add_data(.list = set_names(
      list(target),
      paste0(controller, "-target")
    )) %>%
    add_class("targeted")

}

#' @describeIn stimulus_modifiers Attach a trigger action to a tag
#' @param trigger    (str) the trigger action or event. This may be skipped
#'                         using `NULL` for common elements:
#'                         * `a`, `button`, `input type=submit` - click
#'                         * `form` - submit
#'                         * `input`, `textarea` - input
#'                         * `select` - change
#'                         Use `<event>@<window/document>` to listen for
#'                         global events.
#' @param action     (str) the action to be run when the event fires
#' @param option     (str) DOM event listener option
#'                         * `capture`  - events of this type will be
#'                                        dispatchedbefore to any target
#'                                        beneath it
#'                         * `once`     - listener removed when invoked
#'                         * `passive`  - never call `preventDefault`
#'                         * `!passive` - can call `preventDefault`
#' @param descriptor (str) use this argument to override the descriptor and
#'                         supply it directly.
#' @export
ss_action <- function(trigger = NULL,
                      action,
                      ...,
                      option = c("capture", "once", "passive", "!passive"),
                      tag = tags$div,
                      controller = getOption("hotwire.R.controller"),
                      descriptor = NULL) {

  assert_string(trigger, null.ok = TRUE)
  assert_string(controller)
  assert_string(action)
  assert_string(descriptor, null.ok = TRUE)
  trigger <- if (!is.null(trigger)) paste0(trigger, "->") else NULL
  option <- match_arg(option)
  option <- if (!is.null(option)) paste0(":", option) else NULL

  content <- tagList(...)
  (if (length(content) == 1) content[[1]] else tag(...)) %>%
    add_data(
      action = descriptor %||% paste0(trigger, controller, "#", action, option)
    ) %>%
    add_class("actioned")

}