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 class_unions.R
#' @include global.R

NULL

# Return List With Return Call Locations
#
# List is in same format as the \code{at} parameter for trace
#
# NOTE: deprecated by trace_at_end

find_returns <- function(fun) {
  stopifnot(is.function(fun))
  ret.lang <- as.name("return")

  rec_fn <- function(x) {
    if(is.call(x) && is.name(x[[1L]]) && x[[1L]] == ret.lang) {
      list(NULL)
    } else if (is.call(x) && length(x) > 1L) {
      index.res <- list()
      for(i in tail(seq_along(x), -1L)) {
        res <- Recall(x[[i]])
        if(is.list(res))
          index.res <- c(index.res, lapply(res, function(x) c(i, x)))
      }
      index.res
    }
  }
  rec_fn(body(fun))
}
# Given a function and find_returns value, pull out the referenced statements
#
# NOTE: deprecated by trace_at_end

get_returns <- function(fun, ret.loc) {
  bod <- as.list(body(fun))
  lapply(
    ret.loc,
    function(x) {val <- bod; for(i in x) val <- val[[i]]; val}
  )
}
## Add a tracing expression at end of a function
##
## This works generically for all functions, even when they themselves use
## `on.exit`.  Total hack, but it works.
##
## Note that one trade-off on this one is that we squelch any errors produced
## by the original function, and then re-issue them as part of the trace code.
## This is so that the error message itself shows the function name.  The
## drawback of this is that the original trace is overwritten so some
## information is lost there which could be a problem.
##
## The tracing code will be run irrespective of whether the function succeeds
## or not.  The tracing code may not run if the code issues a condition other
## than a 'simpleError' that is handled by an earlier handler than the one
## generated by `trace_at_end` that does not return control.  Make sure that
## if the tracing code uses the result of evaluating the function (available as
## `.res`), it is robust and has its own error handling.
##
## @param fun must be character(1L), name of a function
## @param tracer an expression to insert in fun
## @param print TRUE or FALSE
## @param where a namespace

trace_at_end <- function(fun, tracer, print, where) {
  stopifnot(is.character(fun) && length(fun) == 1L)

  # `trace_editor` returns a modifed version of the `name` input function
  # that calls the `name` function but adds some additional tracing code after
  # evaluating.  Substantial convolution required to make sure that the final
  # tracing code is run (e.g. if a function actually calls `return`), and also
  # that the body of the original function can run transparently (e.g.
  # calls to `missing`, etc).

  trace_editor <- function(name, file, title) {
    # `name` will be a function

    f.copy <- function() NULL
    formals(f.copy) <- formals(name)
    body(f.copy) <- body(name)

    # Now generate the wrapping function

    f.fin <- function() NULL
    formals(f.fin) <- formals(name)
    body(f.fin) <- bquote({
      m.c <- match.call()
      m.c[[1L]] <- .(f.copy)
      .res <- try(withVisible(eval(m.c, parent.frame())), silent=TRUE)
      .doTrace(.(tracer))
      if(inherits(.res, "try-error")) {
        cond <- attr(.res, "condition")
        stop(simpleError(message=conditionMessage(cond), call=sys.call()))
      }
      with(.res, if(visible) value else invisible(value))
    })
    parent.env(environment(f.fin)) <- parent.env(environment(name))
    f.fin
  }
  old.edit <- options(editor=trace_editor)
  on.exit(options(old.edit))
  trace(fun, edit=TRUE, where=where)
  invisible(fun)
}
## Internal wrapper around untrace so that we can test unexpected behavior

untrace_utz <- function(
  what, signature = NULL, where = topenv(parent.frame())
)  base::untrace(what=what, signature=signature, where=where)

# Function for testing tracing stuff

trace_test_fun <- function(x=0) {
  on.exit(NULL)
  x <- x + 1
  x <- 2
}

.unitizer.base.funs <- list(
  library=base::library,
  attach=base::attach,
  detach=base::detach
)
.unitizer.base.funs.to.shim <- c(
  "library", "attach", "detach"
)
.unitizer.tracer <- quote(
  {
    .par.env <- asNamespace("unitizer")$.global$global$par.env
    parent.env(.par.env) <- as.environment(2L)
} )
# Used to have both exit and at slots, but we removed it with the development
# of trace_at_end

setClass(
  "unitizerShimDat",
  slots=c(
    at="integer",
    tracer="languageOrNULL"
  ),
  prototype=list(at=0L)
)
.unitizer.shim.dat <- list(
  library=new("unitizerShimDat", tracer=.unitizer.tracer),
  attach=new("unitizerShimDat", tracer=.unitizer.tracer),
  detach=new("unitizerShimDat", tracer=.unitizer.tracer)
)
unitizerGlobal$methods(
  shimFuns=function(funs=.unitizer.base.funs.to.shim) {
    '
    Shimming is solely to ensure that the parent environment tracks position 2
    in the search path
    '
    parent.env(par.env) <<- as.environment(2L)
    err.base <- paste(
      "Unable to shim required functions to run with `par.env=NULL` because",
      "%s. Setting `par.env=.GlobalEnv`."
    )
    stopifnot(is.character(funs), all(!is.na(funs)))
    funs.to.shim <- mget(
      funs, ifnotfound=vector("list", length(funs)), mode="function",
      envir=.BaseNamespaceEnv
    )
    err.extra <- ""  # 0 char means no error

    if(!tracingState()) {
      err.extra <- "tracing state is FALSE"
    } else if(!all(vapply(funs.to.shim, is.function, logical(1L)))) {
      err.extra <- "some cannot be found"
    } else if(
      any(vapply(funs.to.shim, inherits, logical(1L), "functionWithTrace"))
    ) {
      err.extra <- "they are already traced"
    }
    if(nchar(err.extra)) {
      warning(sprintf(err.base, err.extra), immediate.=TRUE)
      parent.env(par.env) <<- .GlobalEnv
      return(FALSE)
    }
    # apply shims

    if(shim.fail <- !all(vapply(funs, .self$shimFun, logical(1L)))) {
      unshimFuns()  # This also resets par.env parent
      return(FALSE)
    }
    return(TRUE)
  },
  shimFun=function(name) {
    fun <- getFun(name)
    stopifnot(is.function(fun))
    if(is(fun, "functionWithTrace"))
      stop("Function `", name, "` already traced; cannot proceed.")

    # Now shim

    if(!is(.unitizer.shim.dat[[name]], "unitizerShimDat"))
      stop("Internal Error: missing shim data")

    shimmed <- try(
      # Use to have the option to use the @at portion of the shim data so
      # not forced to do a trace_at_end, see commit c3b8676ef903409a60e0b

      withCallingHandlers(
        trace_at_end(
          name, tracer=.unitizer.shim.dat[[name]]@tracer,
          where=.BaseNamespaceEnv, print=FALSE
        ),
        # Re-emit any unexpected messages
        message=function(e) {
          if(
            !identical(
              sprintf(
                "Tracing function \"%s\" in package \"namespace:base\" ", name
              ),
              gsub("\n", " ", conditionMessage(e))
            )
          ) {
            signalCondition(e)
          } else {
            invokeRestart("muffleMessage")
          }
    } ) )

    if(inherits(shimmed, "try-error")) {
      warning("Failed attempting to trace `", name, "`; see prior errors")
      return(FALSE)
    }
    if(!is(getFun(name), "functionWithTrace")) {
      # Shouldn't be possible to get to this branch so can't test
      # nocov start
      warning(
        "Function `", name, "` was not traced even though tracing attempt did ",
        "not produce errors."
      )
      return(FALSE)
      # nocov end
    }
    # Store shimmed functions so we can check whether they have been
    # un/reshimmed

    shim.funs[[name]] <<- getFun(name)
    TRUE
  },
  unshimFuns=function() {
    parent.env(par.env) <<- .GlobalEnv
    msg.extra <- cc(
      "you should consider manually untracing the function, or restarting ",
      "your R session to restore function to original value."
    )
    untraced <- not.equal <- character()
    shimmed.funs <- length(shim.funs)
    shim.funs.names <- names(shim.funs)

    for(i in shim.funs.names) {
      # if not identical, then someone else shimmed / unshimmed
      if(identical(getFun(i), shim.funs[[i]])) {
        withCallingHandlers(
          untrace_utz(i, where=.BaseNamespaceEnv),
          # suppress the expected unshimming message, but not others
          message=function(e) {
            if(
              !identical(
                sprintf(
                  "Untracing function \"%s\" in package \"namespace:base\" ", i
                ),
                gsub("\n", " ", conditionMessage(e))
              )
            ) {
              signalCondition(e)
            } else {
              invokeRestart("muffleMessage")
        } } )
        untraced <- c(untraced, i)
      } else if(is(getFun(i), "functionWithTrace")) {
        not.equal <- c(not.equal, i)
      }
      # Note we remove shim funs from list even if we did not untrace them since
      # from this point forward we basically declare we have nothing to do with
      # the tracing

      shim.funs[[i]] <<- NULL
    }
    # Get list of functions that were not unshimmed

    still.traced <- vapply(
      shim.funs.names, function(x) is(getFun(x), "functionWithTrace"),
      logical(1L)
    )
    if(any(still.traced)) {
      err.1 <- err.2 <- ""
      if(length(not.equal)) {
        err.1 <- cc(
          char_to_eng(sprintf("`%s`", not.equal)),
          " not untraced because they were modified by something other ",
          "than unitizer.\n"
      ) }
      if(any(still.traced.other <- !still.traced %in% not.equal)) {
        err.2 <- cc(
          char_to_eng(sprintf("`%s`", still.traced[still.traced.other])),
          " not untraced for unknown reasons; please report to ",
          "maintainer.\n"
      ) }
      warning(err.1, err.2, "\n", msg.extra)
    }
    TRUE
  },
  checkShims=function() {
    fail <- FALSE
    if(!tracingState()) {
      warning(
        "Tracing state off, so disabling clean parent env", immediate.=TRUE
      )
      fail <- TRUE
    }
    shim.status <- vapply(
      names(shim.funs),
      function(i) identical(getFun(i), shim.funs[[i]]),
      logical(1L)
    )
    if(!all(shim.status)) {
      warning(
        "Traced functions unexpectedly changed, disabling clean parent env",
        immediate.=TRUE
      )
      fail <- TRUE
    }
    if(fail) {
      unshimFuns()
      FALSE
    } else TRUE
  }
)
#' Utility Function
#'
#' @keywords internal

getFun <- function(name) {
  fun <- try(
    get(name, envir=.BaseNamespaceEnv, inherits=FALSE, mode="function"),
    silent=TRUE
  )
  if(inherits(fun, "try-error")) NULL else fun
}