core/org.eclipse.statet.rj.server.rpkg/pkg/R/help.R

 #=============================================================================#
 # Copyright (c) 2009, 2021 Stephan Wahlbrink and others.
 # 
 # This program and the accompanying materials are made available under the
 # terms of the Eclipse Public License 2.0 which is available at
 # https://www.eclipse.org/legal/epl-2.0, or the Apache License, Version 2.0
 # which is available at https://www.apache.org/licenses/LICENSE-2.0.
 # 
 # SPDX-License-Identifier: EPL-2.0 OR Apache-2.0
 # 
 # Contributors:
 #     Stephan Wahlbrink <sw@wahlbrink.eu> - initial API and implementation
 #=============================================================================#


## StatET help

getHelpFile <- function(file) {
	stop("Unsupported operation: getHelpFile");
}

#' Creates rhelp url, mostly compatible to \code{help}
#' 
#' @param topic 
#' @param package 
#' @param ... for compatibility
#' @returnType character
#' @return URL in rhelp schema
getRHelpUrl <- function(helpObj) {
	if (inherits(helpObj, "packageInfo")) {
		return (paste("rhelp:///page", helpObj$name, "", sep= "/"));
	}
	if (inherits(helpObj, "help_files_with_topic")) {
		topic <- attr(helpObj, "topic", exact= TRUE);
		if (is.null(topic)) {
			topic <- "help";
			package <- "utils";
		}
		else {
			package <- attr(helpObj, "call", exact= TRUE)[["package"]];
		}
		if (is.name(y <- substitute(package))) {
			package <- as.character(y);
		}
		if (is.character(package)
				&& length(package) == 1 && !is.na(package)) {
			return (paste("rhelp:///page", package, topic, sep= "/"));
		}
		else {
			return (paste("rhelp:///topic", topic, sep= "/"));
		}
	}
	stop("Unexpected help information.");
}

#' Creates HTML help page for the given help page(s).
#' 
#' @param x vector of help pages (as returns by original \code{help}
#' @return HTML page for a single page, otherwise \code{NULL}
#' @returnType character
getLiveHelp <- function(x) {
	stop("Unsupported operation: getLiveHelp");
}

showHelp <- function(url) {
	if (missing(url) || !is.character(url) || length(url) != 1) {
		stop("Illegal argument: url")
	}
	.client.execCommand("r/showHelp", list(
					url= url ), wait= FALSE)
}


#' Shows R help in StatET. This is a console command for R help in StatET
#' mainly compatible to the original \code{help}.
#' 
#' @seealso help
#' @export
statet.help <- function(topic, package= NULL, lib.loc= NULL,
		verbose= getOption("verbose"),
		try.all.packages= getOption("help.try.all.packages"), ...,
		live= FALSE ) {
	nextCall <- match.call(expand.dots= TRUE)
	callName <- nextCall[[1]]
	
	if (is.null(nextCall$topic) && !is.null(nextCall$package)) {
		packageInfo <- list(name= nextCall$package)
		class(packageInfo) <- "packageInfo"
		
		result <- list(value= packageInfo, visible= TRUE)
	}
	else {
		nextCall[[1]] <- substitute(utils::help)
		nextCall$live <- NULL
		nextCall$help_type <- "html"
		
		result <- withVisible(eval(nextCall, envir= parent.frame()))
		
		result.call <- attr(result$value, "call", exact= TRUE)
		if (!is.null(result.call)) {
			result.call[[1]] <- callName
			attr(result$value, "call") <- result.call
		}
		
	}
	
	if (live) {
		help.statet <- .getLiveHelp(result$value)
		if (!is.null(help.statet)) {
			help.statet <- paste(help.statet, collapse= "\n")
			help.statet <- paste("html:///", help.statet, sep= "")
		}
	}
	else if (is.null(.rj.config$help)
			|| inherits(result$value, "packageInfo") ) {
		help.statet <- getRHelpUrl(result$value)
	}
	else {
		return (resolveVisible(result))
	}
	if (is.character(help.statet) && !is.na(help.statet)) {
		showHelp(help.statet)
	}
	return (invisible())
}

#' Shows the R help start page in StatET. This is a console command for R help in StatET
#' mainly compatible to the original \code{help.start}.
#' 
#' At moment no argument functionality is supported.
#' 
#' @param ... for compatibility
#' @seealso help.start
#' @export
statet.help.start <- function(...) {
	showHelp("rhelp:///");
	return (invisible());
}


statet.print.help <- function(x, ...) {
	type <- attr(x, "type", exact= TRUE);
	if (length(x) == 0
			|| (!is.null(type) && type != "html")
			|| is.null(.rj.config$help) ) {
		# NextMethod ?
		return (utils:::print.help_files_with_topic(x, ...));
	}
	help.statet <- getRHelpUrl(x);
	if (is.character(help.statet)
			&& length(help.statet) == 1 && !is.na(help.statet)) {
		showHelp(help.statet);
	}
	return (invisible(x));
}