#  File src/library/base/R/stop.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2022 The R Core Team
#
#  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.
#
#  A copy of the GNU General Public License is available at
#  https://www.R-project.org/Licenses/

stop <- function(..., call. = TRUE, domain = NULL)
{
    if (...length() == 1L && inherits(..1, "condition")) {
        cond <- ..1
        if(nargs() > 1L)
            warning("additional arguments ignored in stop()")
        message <- conditionMessage(cond)
        call <- conditionCall(cond)
        .Internal(.signalCondition(cond, message, call))
        .Internal(.dfltStop(message, call))
    } else
        .Internal(stop(call., .makeMessage(..., domain = domain)))
}

stopifnot <- function(..., exprs, exprObject, local = TRUE)
{
    n <- ...length()
    if((has.e <- !missing(exprs)) || !missing(exprObject)) {
	if(n || (has.e && !missing(exprObject)))
	    stop("Only one of 'exprs', 'exprObject' or expressions, not more")
	envir <- if (isTRUE(local)) parent.frame()
		 else if(isFALSE(local)) .GlobalEnv
		 else if (is.environment(local)) local
		 else stop("'local' must be TRUE, FALSE or an environment")
	E1 <- if(has.e && is.call(exprs <- substitute(exprs))) exprs[[1]]
	cl <- if(is.symbol(E1) &&
		 E1 == quote(`{`)) {
		  exprs[[1]] <- quote(stopifnot) ## --> stopifnot(*, *, ..., *) :
		  exprs
	      }
	      else
		  as.call(c(quote(stopifnot),
			    if(!has.e) exprObject else as.expression(exprs))) # or fail ..
        names(cl) <- NULL
	return(eval(cl, envir=envir))
    }
    ## else   use '...' (and not 'exprs') :

    Dparse <- function(call, cutoff = 60L) {
	ch <- deparse(call, width.cutoff = cutoff)
	if(length(ch) > 1L) paste(ch[1L], "....") else ch
    }
    head <- function(x, n = 6L) ## basically utils:::head.default()
	x[seq_len(if(n < 0L) max(length(x) + n, 0L) else min(n, length(x)))]
    abbrev <- function(ae, n = 3L)
	paste(c(head(ae, n), if(length(ae) > n) "...."), collapse="\n  ")
    ##
    for (i in seq_len(n)) {
	r <- ...elt(i)
	if (!(is.logical(r) && !anyNA(r) && all(r))) {
	  dots <- match.call()[-1L]
          if(is.null(msg <- names(dots)) || !nzchar(msg <- msg[i])) {
	    cl.i <- dots[[i]]
	    msg <- ## special case for decently written 'all.equal*(*)':
		if(is.call(cl.i) &&
                   identical(1L, pmatch(quote(all.equal), cl.i[[1]])) &&
		   (is.null(ni <- names(cl.i)) || length(cl.i) == 3L ||
		    length(cl.i <- cl.i[!nzchar(ni)]) == 3L))

		    sprintf(gettext("%s and %s are not equal:\n  %s"),
			    Dparse(cl.i[[2]]),
			    Dparse(cl.i[[3]]), abbrev(r))
		else
		    sprintf(ngettext(length(r),
				     "%s is not TRUE",
				     "%s are not all TRUE"),
			    Dparse(cl.i))
	  }
	    stop(simpleError(msg, call = if(p <- sys.parent(1L)) sys.call(p)))
        }
    }
    invisible()
}

warning <- function(..., call. = TRUE, immediate. = FALSE,
                    noBreaks. = FALSE, domain = NULL)
{
    if (...length() == 1L && inherits(..1, "condition")) {
        cond <- ..1
        if(nargs() > 1L)
            cat(gettext("additional arguments ignored in warning()"),
                "\n", sep = "", file = stderr())
        message <- conditionMessage(cond)
        call <- conditionCall(cond)
        withRestarts({
                .Internal(.signalCondition(cond, message, call))
                .Internal(.dfltWarn(message, call))
            }, muffleWarning = function() NULL) #**** allow simpler form??
        invisible(message)
    } else
        .Internal(warning(call., immediate., noBreaks.,
                          .makeMessage(..., domain = domain)))
}

gettext <- function(..., domain = NULL, trim = TRUE) {
    char <- unlist(lapply(list(...), as.character))
    .Internal(gettext(domain, char, trim))
}

bindtextdomain <- function(domain, dirname = NULL)
    .Internal(bindtextdomain(domain, dirname))

ngettext <- function(n, msg1, msg2, domain = NULL)
    .Internal(ngettext(n, msg1, msg2, domain))

gettextf <- function(fmt, ..., domain = NULL, trim = TRUE)
    sprintf(gettext(fmt, domain=domain, trim=trim), ...)

## Could think of using *several* domains, i.e. domain = vector; but seems complicated;
## the default domain="R"  seems to work for all of base R: {"R", "R-base", "RGui"}
Sys.setLanguage <- function(lang, unset = "en")
{
    stopifnot(is.character(lang), length(lang) == 1L, # e.g., "es" , "fr_CA"
              lang == "C" || grepl("^[a-z][a-z]", lang))
    curLang <- Sys.getenv("LANGUAGE", unset = NA) # so it can be reset
    if(is.na(curLang) || !nzchar(curLang))
        curLang <- unset # "factory" default
    ok <- Sys.setenv(LANGUAGE=lang)
    if(!ok)
        warning(gettextf('Sys.setenv(LANGUAGE="%s") may have failed', lang), domain=NA)
    ok. <- capabilities("NLS") &&
        isTRUE(bindtextdomain(NULL)) # only flush the cache (of already translated strings)
    invisible(structure(curLang, ok = ok && ok.))
}