tests/testthat/test-045-switch.R

In crowding/generators: Coroutines: Generators / Yield, Async / Await, and Streams

fn <- function() {
  x
}
setCompileLevelFromFn(fn)

test_that("Switch numeric", {

  f <- function(x) {
    g <- gen({
      y <- switch(x,
                  yield("one"),
                  yield("two"),
                  yield("three"))
      yield(strrev(y))
    })
#    debugAsync(g, internal=TRUE)
    paste0(nextOr(g, NA), "!", nextOr(g, NA))
  }

  f(1) %is% "one!eno"
  f(2.01) %is% "two!owt"
  f(3.99999) %is% "three!eerht"
  # Contra R's behavior, you must choose an option.
  expect_error(f(0), "bounds")
  expect_error(f(-1), "bounds")
  expect_error(f(0.99999), "bounds")
  expect_error(f(4), "bounds")
  expect_error(f("character"), "numeric")

})

test_that("Switch string", {

  g <- function(x) {
    g <- gen({
      y <- switch(x,
                  one=yield(1),
                  two=yield(2))
      yield(y + nchar(x))
    })
    c(nextOr(g, NULL), nextOr(g, NULL))
  }

  g("one") %is% c(1, 4)
  g("two") %is% c(2, 5)
  # again contra R's behavior.
  expect_error(g("ONE"), "default")
  expect_error(g(1), "character")

})

test_that("Switch string with default", {

  h <- function(x) {
    g <- gen({
      y <- switch(x,
             one=yield(1),
             two=yield(2),
             yield(as.numeric(3)))
      yield(y + nchar(x))
    })
    c(nextOr(g, NA), nextOr(g, NA))
  }

  h("one") %is% c(1, 4)
  h("two") %is% c(2, 5)
  h("twe") %is% c(3, 6)
  h("default") %is% c(3, 10)
  # again contra R's behavior.
  expect_error(h(4), "numeric")
  expect_error(h(2), "numeric")

})

test_that("switch string with fallthrough", {

  h <- function(x) {
    g <- gen({
      y <- switch(x,
                  un=,
                  uno=,
                  one=yield(1),
                  deux=,
                  dos=,
                  two=yield(2),
                  yield(3))
      yield(x)
    })
    paste0(as.character(nextOr(g, NA)), nextOr(g, NA))
  }

  h("one") %is% "1one"
  h("dos") %is% "2dos"
  h("un") %is% "1un"
  h("vingt") %is% "3vingt"

  # again contra R
  g <- gen(yield(switch("y", x=yield(1), y=, z=)))
  expect_error(nextOr(g, NULL), "missing")
})

test_that("numeric switch with delimited goto()", {

  g <- function(x) {
    g <- gen(switch(x,
                    yield("one"),
                    goto(1),
                    goto(5),
                    yield("four"),
                    goto(4)))
    nextOr(g, NA)
  }

  g(1) %is% "one"
  g(2) %is% "one"
  g(3) %is% "four"
  g(4) %is% "four"

})


test_that("character switch() with delimited goto()", {

  g <- function(x) {
    gg <- gen({
      switch(x,
             one=yield(1),
             two=goto("one"),
             three=goto("five"),
             four=goto("somewhere else"),
             five=yield(5),
             yield("many"))
    })
    nextOr(gg, NA)
  }

  g("one") %is% 1
  g("two") %is% 1
  g("three") %is% 5
  g("four") %is% "many"

})

test_that("Delimited goto with no argument jumps to switch expression", {

  collatz <- function(x) {
    g <- gen({
      yield(x)
      switch(
        if (x == 1) return() else x %% 2 + 1,
        {x <- x / 2;     yield(x); goto()},
        {x <- x * 3 + 1; yield(x); goto()}
      )
    })
    as.numeric(as.list(g))
  }

  length(collatz(31)) %is% 107

})

test_that("Try-finally intercedes with goto", {

  f <- function(x) {force(x); gen({
    switch(x,
           b=yield("four"),
           c=yield(base::stop("nope")),
           a=tryCatch(
           {
             yield("one")
             goto("b")
             yield("nope")
           }, finally={
             yield("three")
           },
           error=yield("nope")
           ))
  })}

  g <- f("a")
  nextOr(g, NULL) %is% "one"
  nextOr(g, NULL) %is% "three"
  nextOr(g, NULL) %is% "four"
  nextOr(g, NULL) %is% NULL

})


test_that( "goto from try/catch/finally unwinds the right amount", {

  f <- function(x) {force(x); gen({
    tryCatch(
      switch(x,
             c=yield(base::stop("catchme")),
             aa=,
             a=tryCatch(
             {
               yield("one")
               if (x != "a")
                 base::stop("oops")
               else goto("c")
             },
             error={
               yield("handling inner")
             },
             finally={
               yield("finally")
               base::stop("boops")
             }
             )),
      error=yield("handling outer")
    )
  })}

  g <- f("a")
  nextOr(g, NULL) %is% "one"
  nextOr(g, NULL) %is% "finally"
  nextOr(g, NULL) %is% "handling outer"
  nextOr(g, NULL) %is% NULL

  g <- f("aa")
  nextOr(g) %is% "one"
  nextOr(g) %is% "handling inner"
  nextOr(g) %is% "finally"
  nextOr(g) %is% "handling outer"
  nextOr(g, NULL) %is% NULL

})

test_that("goto from finally", {
  run({
    switch("foo",
           foo=tryCatch("foo", finally=goto("bar")),
           bar="bar!")
  }) %is% "bar!"
})

test_that("goto from error", {

  run({
    switch("foo",
           baz="baz!",
           foo=tryCatch(stop("bar"), error=goto("baz")),
           bar="bar!")
  }) %is% "baz!"

})

options(async.compileLevel = 0)