R/exec.R

In unitizer: Interactive R Unit Tests

# Copyright (C) Brodie Gaslam
#
# This file is part of "unitizer - Interactive R Unit Tests"
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# Go to <https://www.r-project.org/Licenses/GPL-2> for a copy of the license.

#' @include unitizer.R

NULL

setGeneric("exec", function(x, ...) standardGeneric("exec"))

## Functions To Manage Evaluation of Tests
##
## Runs test, captures value, stdout, stderr, conditions, etc.
##
## \code{exec} is designed to run tests, capture output, etc,
## \code{eval_user_exp} does the actual evaluation, \code{eval_with_capture},
## is a wrapper around \code{eval_user_exp} that also captures output,
## \code{user_exp_display} and \code{user_exp_handle} are utility function to
## deal with evaluations that invoke print/show,
## \code{set_trace} and \code{get_trace} are used to set the tracebacks when
## there are failures.
##
## @section \code{eval_user_exp}:
##
## A fair bit of manipulation required to ensure the trace and calls associated
## with conditions are reasonable.  This should be mostly correct except for the
## notable exception of top-level conditions, which will be recorded correctly,
## but for which the \code{std.err()} output will show the
## \code{withVisible(...)} call.  Doesn't seem to be a straightforward way of
## capturing that short of tossing the \code{stderr} and spoofing the message.
##
## @section \code{set_trace}, \code{get_trace}:
##
## Used for cases where the trace isn't generated because the error was run
## within a handling loop, but we still want the trace so we can emulate command
## line behavior.
##
## This will modify the .Traceback system variable (see \code{\link{traceback}}
## documentation).
##
## Assumption right now is that the outer most call to \code{withCallingHandlers}
## is the baseline level from which we want to repor the traceback.
##
## Only intended for use within \code{eval_user_exp}, will clean up the result
## from two different \code{sys.calls} calls to extract the calls that a
## trace would show on error.
##
## How much of the stack is used is affected by the \code{printed}
## argument because if something didn't pass evaluation, it means the error
## occurred within \code{withVisible} which in this setup means we need to
## remove two additional levels.
##
## Relies on calls being evaluated in a very particular environment.
##
## @rdname exec
## @param trace a list of type generated by sys.calls()
## @param trace.base starting point for what we care about in the trace, as
##   produced by \code{sys.calls}
## @param trace.new the trace within the condition handler, as produced by
##   \code{sys.calls}
## @param passsed.eval whether the evaluatation succeeded in the first step (see
##   details)
## @param print.type character(1L) one of "print", "show", or ""
## @param exp the expression to sub in to the print/show statements if we passed
##   eval
## @param test the call to test
## @param test.env the environment to evaluate the \code{test} in
## @param global unitizerGlobal, required by \code{eval_user_exp} to record
##   state every time a user expression is evaluated
## @param with.display whether to print/show output if visible
## @param with.state whether to log state after each evaluation

setMethod("exec", "ANY", valueClass="unitizerItem",
  function(x, test.env, global) {
    if(!is.environment(test.env))
      stop("Argument `test.env` must be an environment.")

    # Check whether we are dealing with a unitizer_sect

    is_unitizer_sect <- FALSE
    if(is.call(x))
      is_unitizer_sect <-
        identical(try(eval(x[[1L]], test.env), silent=TRUE), unitizer_sect)

    # Prep message and std output capture, note this is reset with every test
    # expressionevaluation

    x.comments <- character()

    if(!is_unitizer_sect) {
      x.extracted <- comm_and_call_extract(x)
      # need to recover comments from container since we can't attach comments
      # directly to name

      x.comments <- x.extracted$comments
      x <- x.extracted$call                   # get rid of comment container
    }
    x.to.eval <- `attributes<-`(x, NULL)

    res <- eval_with_capture(
      x.to.eval, test.env, global=global, with.capture=!global$transcript
    )
    global$cons <- res$cons  # Need to recover connections
    if(res$aborted & is_unitizer_sect)  # check to see if `unitizer_sect` failed
      stop(
        "Failed instantiating a unitizer section:\n",
        paste0(res$message, "\n")
      )
    if(!is(res$state, "unitizerGlobalIndices")) {
      stop("Internal Error: failed recording state; contact maintainer.")# nocov
    }
    new(
      "unitizerItem", call=x.to.eval, value=res$value,
      conditions=new("conditionList", .items=res$conditions),
      output=res$output, message=res$message,
      aborted=res$aborted,
      env=test.env, comment=x.comments, trace=res$trace,
      glob.indices=res$state,
      ignore=identical(res$visible, FALSE) && !length(res$conditions)
    )
} )
# ## Three places eval_user_exp is called
#
# ## This is used by unitizer_browse, and also all over the place so a real
# ## problem to isolate!
#
# unitizer_prompt
#   eval_user_exp
#
# ## This is used to evaluate the test expression
# ## and produce unitizerItems
#
# unitize_eval
#   `+`("unitizer", "unitizerTestsOrExpression")
#      exec
#        eval_with_capture
#          eval_user_exp                     <-----
#      `+`("unitizer", "unitizerItem")
#         testItem("unitizer", "unitizerItem")
#           eval_user_exp                    <-----


# @param warn.sticky TRUE or FALSE whether to let the warning option state
#   persist past the call.  If TRUE, then whatever is invoking this function is
#   responsible for resetting it.  At the moment it is when this is invoked via
#   the `unitizer_prompt` in browsing test results.

eval_user_exp <- function(
  unitizerUSEREXP, env, global, with.display=TRUE,
  warn.sticky=FALSE, with.display.unitizer_sect=FALSE
) {
  if(!is(global, "unitizerGlobal") && !is.null(global)) {
    # nocov start
    stop(
      "Internal Error: `global` argument must be a 'unitizerGlobal' object ",
      "or NULL, contact maintainer."
    )
    # nocov end
  }
  if(getOption('warn') < 1L) {
    old.opt <- options(warn=1L)
    if(!warn.sticky) on.exit(options(old.opt))
  }
  exp <- if(is.expression(unitizerUSEREXP)) {
     call("withVisible", call("eval", unitizerUSEREXP))
  } else call("withVisible", unitizerUSEREXP)
  res <- user_exp_handle(exp, env, "", unitizerUSEREXP)
  if(
    !res$aborted && res$value$visible && length(unitizerUSEREXP) &&
    with.display &&
    (
      !is(res$value$value, "unitizerSectionExpression") ||
      with.display.unitizer_sect
    )
  ) {
    res2 <- user_exp_display(res$value$value, env, unitizerUSEREXP)
    res$conditions <- append(res$conditions, res2$conditions)
    if(length(res2$trace)) res$trace <- res2$trace
    res$aborted <- res2$aborted
  }
  # convolution required due to possible NULL value so can't assign directly to
  # elements; also, note that the `state` return value is not used in most
  # `eval_user_exp` uses; the

  c(
    list(
      value=res$value$value, visible=res$value$visible,
      state=if(is(global, "unitizerGlobal")) global$state()
    ),
    res[-1L]
  )
}
# @param with.display output result of evaluation after evaluation
# @param with.capture turns capture on and off for each expression, different
#   from with.display as this will allow display of e.g. segfaults, etc.  Gives
#   more fine grained control than "unitizer.disable.capt" as that does it for
#   every use of this function, whereas we might only want it for test
#   expressions.

eval_with_capture <- function(
  x, test.env=new.env(), global, with.display=TRUE, with.state=TRUE,
  with.capture=TRUE
) {
  stopifnot(is(global, "unitizerGlobal"))
  # These used to be parameters, but now that we have `global` we use that
  # instead; note that the options come in as NULL quietly in some tests where
  # we're e.g. directly accessing the unitizers instead of using `unitize`, and
  # those NULLs ar just dropped implicitly by the way we call `set_capture`.
  cons <- global$cons
  disable.capt <- global$unitizer.opts[["unitizer.disable.capt"]]
  max.capt.chars <- global$unitizer.opts[["unitizer.max.capture.chars"]]

  if(!is.null(disable.capt)) disable.capt <- disable.capt | !with.capture

  # Disable error handler; warn gets set to one when we eval the expression

  err.opt <- getOption("error")

  # Setup text capture; a bit messy due to funny way we have to pull in
  # unitize specific options; do.call business is to use default arguments
  # if options are NULL

  came.with.capts <- TRUE
  if(is.null(cons)) {
    capt.cons <- new("unitizerCaptCons")
    came.with.capts <- FALSE
  } else {
    capt.cons <- cons
  }
  # disable.capt and max.capt.chars could be NULL in some cases (see above)
  set_args <- list()
  set_args[["capt.disabled"]] <- disable.capt
  capt.cons <- do.call(set_capture, c(list(capt.cons), set_args))
  get_args <- list(capt.cons)
  get_args[["chrs.max"]] <- max.capt.chars

  # Manage unexpected outcomes

  on.exit({
    options(error=err.opt)
    get.try <- try(capt <- do.call(get_capture, get_args))
    unsink.try <- try(capt.cons <- unsink_cons(capt.cons))
    if(!inherits(get.try, "try-error")) {
      cat(c(capt$message, "\n"), file=stderr(), sep="\n")
      cat(c(capt$output, "\n"), sep="\n")
    }
    if(inherits(unsink.try, "try-error")) failsafe_con(capt.cons)
    if(!came.with.capts) close_and_clear(capt.cons)
    meta_word_msg(
      "Unexpectedly exited evaluation attempt when executing test ",
      "expression:\n> ", paste0(deparse(x), collapse=""), "\nMake sure you ",
      "are not calling `unitize` inside a `tryCatch`/`try` block, invoking a ",
      "restart defined outside `unitize`, evaluating an expression that ",
      "calls `quit()`/`q()`, or quitting from a `browser()`/`debug()`/",
      "`trace()`. If none of these apply yet you are seeing this message ",
      "please contact package maintainer.",
      sep=""
    )
  })
  # Evaluate expression

  options(error=NULL)
  res <- eval_user_exp(
    x, test.env, global=if(with.state) global, with.display=with.display
  )

  # Revert settings, get captured messages, if any and if user isn't capturing
  # already; do.call so we can rely on default get_capture settings if those
  # in `unitizer.opts` are NULL

  capt <- do.call(get_capture, get_args)
  capt.cons <- unsink_cons(capt.cons)
  if(getOption("unitizer.show.output", TRUE)) {
    cat(c(capt$message, "\n"), file=stderr(), sep="\n")
    cat(c(capt$output, "\n"), sep="\n")
  }
  on.exit(NULL)
  options(error=err.opt)

  # Need to make sure we either close the connections or return the updated
  # values since we might be changing connections depending on sink status, etc

  if(!came.with.capts) close_and_clear(capt.cons)

  # Cleanup and

  res[c("output", "message")] <- lapply(
    capt[c("output", "message")], function(x) if(!length(x)) "" else x
  )
  res[["cons"]] <- capt.cons
  clean_message(res)
}
user_exp_display <- function(value, env, expr, default=FALSE) {
  if(isS4(value)) {
    print.type <- "show"
    disp.expr <- call("show", if(is.language(value)) enquote(value) else value)
  } else {
    print.type <- "print"
    disp.expr <- call(
      if(default) "print.default" else "print",
      if(is.language(value)) enquote(value) else value
    )
  }
  user_exp_handle(disp.expr, env, print.mode=print.type, expr.raw=expr)
}
# It used to matter what precise value `print.mode`, but now the only thing
# that matters is whether it is zero char or not

user_exp_handle <- function(expr, env, print.mode, expr.raw) {
  aborted <- FALSE
  conditions <- list()
  trace <- list()
  printed <- nchar(print.mode) > 1
  value <- NULL

  withRestarts(
    withCallingHandlers(
      {
        trace.base <- sys.calls()
        value <- eval(expr, env)
      },
      condition=function(cond) {
        attr(cond, "unitizer.printed") <- printed
        trace.new <- sys.calls()
        trace.net <- get_trace(
          trace.base, trace.new, printed, expr.raw
        )
        if(attr(trace.net, "set.trace")) trace <<- c(trace.net)

        # manipulate call so it looks like it should
        cond.call.noattr <- `attributes<-`(cond$call, NULL)
        if(!printed && identical(cond.call.noattr, trace.net[[1L]])) {
          cond <- modifyList(cond, list(call=NULL), keep.null=TRUE)
        }
        conditions[[length(conditions) + 1L]] <<- cond
      }
    ),
    abort=function() {
      aborted <<- structure(TRUE, printed=printed)
    }
  )
  list(
    value=value,
    aborted=aborted,
    conditions=conditions,
    trace=tail(trace, -1L)
  )
}
## Trace is undeparsed

set_trace <- function(trace) {
  if(length(trace)) .global$traceback <- rev(trace)
  TRUE
}
get_trace <- function(trace.base, trace.new, printed, exp) {

  # because withCallingHandlers/withRestarts don't register when calling
  # sys.calls() within them, but do when calling sys.calls() from the handling
  # function, we need to remove at least 4 calls from trace.new, and possibly
  # more if we ended up evaluating within withVisible

  len.new <- length(trace.new)

  if(
    len.new > length(trace.base) &&
    all(
      vapply(
        seq_along(trace.base), FUN.VALUE=logical(1L),
        function(x) identical(trace.base[[x]], trace.new[[x]])
    ) )
  ) {
    # Filter out calls through signalCondition rather than stop and
    # `stop+condition`

    is.stop <- identical(trace.new[[len.new]], quote(h(simpleError(msg, call))))
    is.stop.cond <- length(trace.new) > 1L &&
      identical(trace.new[[len.new - 1L]][[1L]], quote(stop))

    trace.new[seq_along(trace.base)] <- NULL
    # remove srcref attributes
    trace.new.clean <- lapply(trace.new, `attributes<-`, NULL)

    if(
      length(trace.new.clean) >= 7L ||
      (printed && length(trace.new.clean) >= 6L)
    ) {
      # printing removes expression
      trace.new.clean[
        1L:(if(printed) 5L else 6L + is.expression(exp) * 2L)
      ] <- NULL
      if(printed) {
        # Find any calls from the beginning that are length 2 and start with
        # print/show and then replace the part inside the print/show call with
        # the actual call

        exp.rep <- if(is.expression(exp)) exp[[length(exp)]] else exp
        trace.new.clean <- lapply(
          trace.new.clean,
          function(x) eval(call("substitute", x, list(unitizerTESTRES=exp.rep)))
        )
      }
      if(length(trace.new.clean) >= 2L) {
        trace.drop <- if(is.stop) -2L else if (is.stop.cond) -1L else 0L
        trace.trim <- trace.new.clean[1L:(length(trace.new.clean) + trace.drop)]
      } else {
        stop("Internal Error: unexpected trace length")  # nocov
      }
      attr(trace.trim, "set.trace") <- is.stop || is.stop.cond  # only actually set trace on `stop` calls
      return(trace.trim)
  } }
  stop("Internal Error: couldn't extract trace; contact maintainer.") # nocov
}
clean_message <- function(res) {
  # Deal with top level warnings and errors that show up weird in the message
  # output because they are not truly top level within unitizer; top level
  # warnings will have the `call` component set to NULL; we compose a regular
  # expression that contains all the warning / errors and their messages to
  # match against the output stream to give use the location of the
  # "Error in .*: " and such

  stopifnot(
    is.list(res), is.character(res$message), identical(length(res$message), 1L)
  )
  # this all assumes options(warn>=1)

  reg.base <- "(%s in .*? :)((?:\\n|\\s)*%%s)\\n.*"
  if(nchar(res$message)) {
    pats <- lapply(
      res$conditions,
      function(cond) {
        token <- NULL
        if(
          is.null(conditionCall(cond)) &&
          (
            (is.warn <- inherits(cond, "simpleWarning")) ||
            inherits(cond, "simpleError")
          )
        ) {
          type <- if(is.warn) "Warning" else "Error"
          sprintf(
            sprintf(reg.base, type),
            gsub(
              "([-\\\\^$*+?.()|[\\]{}])", "\\\\\\1", conditionMessage(cond),
              perl=TRUE
    ) ) } } )
    if(!all(vapply(pats, is.null, logical(1L)))) {
      # Our pattern has two matching elements per match, and these are going to
      # show up sequentially in our match, so we turn the capture data into
      # a matrix where col 1 is the first match, and col 2 the second match

      pats.fin <- do.call(paste0, c(list("(?s)"), pats))
      m <- regexpr(pats.fin, res$message, perl=T)
      m.st <- t(matrix(attr(m, "capture.start"), nrow=2))
      m.len <- t(matrix(attr(m, "capture.length"), nrow=2))

      # Loop backwards through string so that modifications don't affect character
      # locations for subsequent replacements

      msg <- res$message
      width <- getOption("width")

      for(i in rev(seq.int(nrow(m.st)))) {
        if(m.st[i, 1L] < 1L || m.len[i, 1L] < 1L) next
        pre <- if(m.st[i, 1L] == 1L) "" else substr(msg, 1L, m.st[i, 1L] - 1L)
        obj <- sub(
          "^(\\w+).*", "\\1:",  # replace obj with first word
          substr(msg, m.st[i, 1L], m.st[i, 1L] + m.len[i, 1L] - 1),
          perl=TRUE
        )
        obj2 <- substr(msg, m.st[i, 2L], m.st[i, 2L] + m.len[i, 2L] - 1)
        post <- if(m.st[i, 2L] + m.len[i, 2L] > nchar(msg)) "" else
          substr(msg, m.st[i, 2L] + m.len[i, 2L], nchar(msg))

        # Undo line break if shorter call doesn't warrant it anymore

        obj2.short <- sub("^(?s)\\s*(.*)$", " \\1", obj2, perl=TRUE)
        msg <- if(nchar(paste0(obj, obj2.short)) <= width)
          paste0(pre, obj, obj2.short, post) else
          paste0(pre, obj, obj2, post)
      }
      res$message <- msg
  } }
  res
}