 #=============================================================================#
 # Copyright (c) 2009, 2017 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 utilities

#' Estimates a value for the parameter max.level of \code{str}
#' for the given R element.
#' 
#' @param x the R element to show
#' @param max.elements maximum elements to show
#' @param max.levels maximum levels to show
#' @returnType integer
#' @return a value for max.level
#' @author Stephan Wahlbrink <sw@wahlbrink.eu>
#' @export
estimateStrDepth <- function(x, max.elements = 2000L, max.levels = 10L) {
	deeplength <- function(x, level = 0L) {
		if (isS4(x)) {
			xslots <- slotNames(class(x))
			xlen <- length(xslots)
			if (level == 0L || xlen == 0L) {
				return (xlen)
			}
			else {
				s <- 0L
				for (xslot in xslots) {
					s <- s + deeplength(slot(x, xslot), level = level-1L)
				}
				return (s)
			}
		}
		if (is.list(x)) {
			xlen <- length(x)
			if (level == 0L || xlen == 0L || is.data.frame(x)) {
				return (xlen)
			}
			else {
				return (sum(sapply(x, deeplength, level = level-1L, USE.NAMES=FALSE)))
			}
		}
		return (0L)
	}
	
	level <- -1L
	s <- 0L
	while (level < max.levels && s < max.elements) {
		level <- level + 1L
		s.level <- deeplength(x, level)
		if (s.level == 0L) {
			return (NA)
		}
		s <- s + s.level
	}
	return (level)
}

#' Captures output of \code{str} for the given R element.
#' The output is limited to the specified number of R elements.
#' 
#' @param x the R element to show
#' @param limit maximum elements to show
#' @returnType character
#' @return output of \code{str}
#' @author Stephan Wahlbrink <sw@wahlbrink.eu>
#' @export
.statet.captureStr <- function(x, limit = 2000L) {
	savedOptions <- options(width = 10000L)
	on.exit(options(savedOptions))
	levels <- estimateStrDepth(x, max.elements = limit)
	if (!is.na(levels) && levels <= 1L && getRversion() >= "2.11.0") {
		output <- capture.output(str(x, max.level = 1L, list.len = limit - 1L))
	}
	else {
		output <- capture.output(str(x, max.level = levels))
	}
	return (output)
}


.statet.prepareSrcfile <- function(filename, path) {
	map <- .rj.tmp$statet.SrcfileMap
	if (is.null(map)) {
		map <- list()
	}
	map[[filename]] <- NULL
	map[[filename]] <- path
	if (length(map) > 20) {
		map[[1]] <- NULL
	}
	.rj.tmp$statet.SrcfileMap <- map
	return (invisible(NULL))
}

.statet.extSrcfile <- function(srcfile) {
	map <- .rj.tmp$statet.SrcfileMap
	path <- NULL
	if (is.null(map) || is.null(srcfile$filename)) {
		return (srcfile)
	}
	idx <- which(names(map) == srcfile$filename)
	if (length(idx) != 1) {
		return (srcfile)
	}
	path <- map[[idx]]
	
	if (idx <= 10) {
		map[[idx]] <- NULL
		map[[srcfile$filename]] <- path
		.rj.tmp$statet.SrcfileMap <- map
	}
	
	srcfile$statet.Path <- path
	return (srcfile)
}

.addElementIds <- function(expr, elementIds) {
	names <- names(elementIds)
	for (i in seq_along(names)) {
		if (!is.na(names[i])) {
			path <- elementIds[[i]]
			tryCatch(attr(expr[[path]], "statet.ElementId") <- names[i],
					error = .rj.errorHandler )
		}
	}
	return (expr)
}

.statet.prepareCommand <- function(lines, filename = "<text>",
		srcfileAttributes, elementIds) {
	# create srcfile object
	srcfile <- srcfilecopy(filename, lines)
	if (!missing(srcfileAttributes)) {
		names <- names(srcfileAttributes)
		for (i in seq_along(names)) {
			if (!is.na(names[i])) {
				assign(names[i], srcfileAttributes[[i]], envir= srcfile)
			}
		}
	}
	
	# parse command
	expr <- parse(text= lines, srcfile= srcfile, encoding= "UTF-8")
	
	# attach element ids
	if (!missing(elementIds)) {
		expr <- .addElementIds(expr, elementIds)
	}
	
	# finish
	.rj.tmp$statet.CommandExpr <- expr
	invisible(expr)
}

.statet.evalCommand <- function() {
	expr <- .rj.tmp$statet.CommandExpr
	if (is.null(expr)) {
		stop("Commands not available.")
	}
	srcrefs <- attr(expr, "srcref", exact= TRUE)
	exi <- call("{", expr[[1]])
	if (1 <= length(srcrefs)) {
		attr(exi, "srcref") <- list(NULL, srcrefs[[1]])
	}
	eval(exi, parent.frame())
}

.statet.prepareSource <- function(info) {
	assign("statet.NextSourceInfo", info, envir= .rj.tmp)
}

.statet.extSource <- function(expr) {
	info <- .rj.tmp$statet.NextSourceInfo
	if (is.null(info)) {
		return (expr)
	}
	on.exit(rm("statet.NextSourceInfo", envir= .rj.tmp))
	if (is.null(expr)) {
		return (expr)
	}
	srcfile <- attr(expr, "srcfile", exact= TRUE)
	if (is.null(srcfile)
			|| is.null(srcfile$statet.Path) || is.null(srcfile$timestamp)
			|| srcfile$statet.Path != info$path
			|| (unclass(srcfile$timestamp) != info$timestamp
				&& abs(unclass(srcfile$timestamp) - info$timestamp) != 3600 )
			|| length(expr) != info$exprsLength ) {
		return (expr)
	}
	expr <- .addElementIds(expr, info$elementIds)
	return (expr)
}


.searchExpr <- function(expr, cond, max.depth= 5, depth= 1) {
	if (expr[[1]] == "{") {
		for (i in seq_along(expr)) {
			if (cond(expr[[i]])) {
				return (i);
			}
		}
	}
	for (i in seq_along(expr)) {
		if (depth < max.depth && length(expr[[i]]) > 1) {
			idx <- .searchExpr(expr= expr[[i]], cond= cond,
					max.depth= max.depth, depth= depth + 1)
			if (!is.null(idx)) {
				return (c(i, idx))
			}
		}
	}
	return (NULL)
}


#### R env / R lib path (R pkg manager)

renv.checkLibs <- function() {
	libs <- .libPaths()
	result <- file.info(libs)$mtime
	names(result) <- libs
	
	result
}

renv.getBioCVersion <- function() {
	v <- tools:::.BioC_version_associated_with_R_version
	if (is.function(v)) {
		v <- v()
	}
	return (v)
}

renv.getAvailPkgs <- function(repo) {
	fields= c('Package', 'Version', 'Priority', 'License',
			'Depends', 'Imports', 'LinkingTo', 'Suggests', 'Enhances')
	result <- available.packages(contriburl= contrib.url(repo), fields= fields,
			filter= c('R_version', 'OS_type', 'subarch') )
	result[, fields, drop= FALSE]
}

renv.getInstPkgs <- function(lib) {
	names <- list.files(lib)
	fields <- c('Package', 'Version', 'Title', 'Built')
	result <- matrix(NA_character_, nrow= length(names), ncol= length(fields))
	num <- 0L
	for (name in names) {
		pkgpath <- file.path(lib, name)
		if (file.access(pkgpath, 5L)) {
			next
		}
		if (file.exists(file <- file.path(pkgpath, 'Meta', 'package.rds'))) {
			md <- try(readRDS(file))
			if (inherits(md, 'try-error')) {
				next
			}
			descr <- md$DESCRIPTION[fields]
			if (is.null(descr)) {
				next
			}
			enc <- md$DESCRIPTION['Encoding']
			if (!is.na(enc)) {
				txt <- try(iconv(descr[3L], from= enc, to= "UTF-8"))
				if (!inherits(txt, "try-error")) {
					descr[3L] <- txt
				}
			}
			descr[1L] <- name
			result[num <- num + 1, ] <- descr
		}
	}
	result[seq.int(from= 1L, length.out= num), , drop= FALSE]
}

renv.getInstPkgDetail <- function(lib, name) {
	fields <- c('Priority', 'License',
			'Depends', 'Imports', 'LinkingTo', 'Suggests', 'Enhances' )
	file <- file.path(lib, name, 'Meta', 'package.rds')
	md <- readRDS(file)
	md$DESCRIPTION[fields]
}

renv.isValidLibLoc <- function(path) {
	# path <- normalizePath(path)
	current <- path
	repeat {
		if (file.access(current, 0L) == 0L) { # exists
			result <-  file.access(current, 3L) # writable
			names(result) <- path
			return (result)
		}
		parent <- dirname(current)
		if (nchar(parent) <= 1L || parent == current) {
			return (-1L)
		}
		current <- parent
	}
}


#### R help

#' Returns the package description for the specified package
#' 
#' @param lib the library location
#' @param name the package name
rhelp.loadPkgDescr <- function(lib, name) {
	fields <- c('Version', 'Title', 'Description', 'Author', 'Maintainer', 'URL', 'Built')
	file <- file.path(lib, name, 'Meta', 'package.rds')
	md <- readRDS(file)
	descr <- md$DESCRIPTION[fields]
	if (is.null(descr)) {
		return (NULL)
	}
	enc <- md$DESCRIPTION['Encoding']
	if (!is.na(enc)) {
		txt <- try(iconv(descr[2L:5L], from= enc, to= "UTF-8"))
		if (!inherits(txt, "try-error")) {
			descr[2L:5L] <- txt
		}
	}
	return (descr)
}

#' Returns the help files for the specified package
#' 
#' @param lib the library location
#' @param name the package name
rhelp.loadPkgRd <- function(lib, name) {
	error("Operation not supported")
}