Initial commit

.Rbuildignore

@@ -0,0 +1,2 @@
+^.*\.Rproj$
+^\.Rproj\.user$

.gitignore

@@ -0,0 +1,4 @@
+.Rproj.user
+.Rhistory
+.RData
+.Ruserdata

DESCRIPTION

@@ -0,0 +1,17 @@
+Package: promise
+Type: Package
+Title: What the Package Does (Title Case)
+Version: 0.1.0
+Authors@R: c(
+      person("Joe", "Cheng", email = "joe@rstudio.com", role = c("aut", "cre")),
+      person("RStudio", role = c("cph"))
+    )
+Description: More about what it does (maybe more than one line)
+    Use four spaces when indenting paragraphs within the Description.
+License: MIT + file LICENSE
+Imports: R6, later
+Suggests: testthat
+Roxygen: list(markdown = TRUE)
+RoxygenNote: 6.0.1
+Encoding: UTF-8
+LazyData: true

LICENSE

@@ -0,0 +1,3 @@
+YEAR: 2016-2017
+COPYRIGHT HOLDER: RStudio, Inc.
+

NAMESPACE

@@ -0,0 +1,18 @@
+# Generated by roxygen2: do not edit by hand
+
+S3method(format,promise)
+S3method(print,promise)
+export(catch)
+export(finally)
+export(fmap.promise)
+export(new_promise)
+export(new_promise_domain)
+export(promise_all)
+export(promise_race)
+export(reject)
+export(rejected)
+export(resolve)
+export(resolved)
+export(then)
+export(with_promise_domain)
+import(R6)

R/domains.R

@@ -0,0 +1,76 @@
+promiseDomain <- list(
+  onThen = function(onFulfilled, onRejected) {
+    domain <- current_promise_domain()
+
+    if (is.null(domain))
+      return()
+    if (is.null(onFulfilled) && is.null(onRejected))
+      return()
+
+    results <- list()
+    if (!is.null(onFulfilled)) {
+      newOnFulfilled <- domain$wrapOnFulfilled(onFulfilled)
+      results$onFulfilled <- function(value) {
+        with_promise_domain(domain, newOnFulfilled(value))
+      }
+    }
+    if (!is.null(onRejected)) {
+      newOnRejected <- domain$wrapOnRejected(onRejected)
+      results$onRejected <- function(reason) {
+        with_promise_domain(domain, newOnRejected(reason))
+      }
+    }
+    results
+  }
+)
+
+globals <- new.env(parent = emptyenv())
+
+current_promise_domain <- function() {
+  globals$domain
+}
+
+#' @export
+with_promise_domain <- function(domain, expr, replace = FALSE) {
+  oldval <- current_promise_domain()
+  if (replace)
+    globals$domain <- domain
+  else
+    globals$domain <- compose_domains(oldval, domain)
+  on.exit(globals$domain <- oldval)
+
+  force(expr)
+}
+
+#' @export
+new_promise_domain <- function(
+  wrapOnFulfilled = identity,
+  wrapOnRejected = identity,
+  ...
+) {
+  list2env(list(
+    wrapOnFulfilled = wrapOnFulfilled,
+    wrapOnRejected = wrapOnRejected,
+    ...
+  ), parent = emptyenv())
+}
+
+
+compose_domains <- function(base, new) {
+  if (is.null(base)) {
+    return(new)
+  }
+
+  list(
+    wrapOnFulfilled = function(onFulfilled) {
+      new$wrapOnFulfilled(
+        base$wrapOnFulfilled(onFulfilled)
+      )
+    },
+    wrapOnRejected = function(onRejected) {
+      new$wrapOnRejected(
+        base$wrapOnRejected(onRejected)
+      )
+    }
+  )
+}

R/methods.R

@@ -0,0 +1,17 @@
+#' @export
+fmap.promise <- function(.m, .f, ...) {
+  .m$then(function(val) {
+    .f(val, ...)
+  })
+}
+
+#' @export
+format.promise <- function(x, ...) {
+  p <- attr(x, "promise_impl", exact = TRUE)
+  p$format()
+}
+
+#' @export
+print.promise <- function(x, ...) {
+  cat(paste(format(x), collapse = "\n"), "\n", sep = "")
+}