X-Git-Url: http://christophe.rhodes.io/gitweb/?p=swankr.git;a=blobdiff_plain;f=swank.R;h=57ead0ac9f803a1d2729f737d739c0d4a10fcb69;hp=8c5bafdccd1d5d198f534d971db0455fba703095;hb=fc149c9eb2e0c2d1645f8ab3bfcd52eaaf823dab;hpb=f362dbb2a366f194cb12a336d99403287e09f8ae diff --git a/swank.R b/swank.R index 8c5bafd..57ead0a 100644 --- a/swank.R +++ b/swank.R @@ -13,18 +13,30 @@ ### latest version of the GNU General Public Licence is available at ### . +### KLUDGE: this assumes that we're being sourced with chdir=TRUE. +### (If not, `swank:swank-require` will work under the circumstances +### that it used to work anyway -- i.e. the working directory is the +### swankr directory) +swankrPath <- getwd() + swank <- function(port=4005) { acceptConnections(port, FALSE) } startSwank <- function(portFile) { - acceptConnections(FALSE, portFile) + acceptConnections(4005, portFile) } acceptConnections <- function(port, portFile) { + if(portFile != FALSE) { + f <- file(portFile, open="w+") + cat(port, file=f) + close(f) + } + ## FIXME: maybe we should support dontClose here? s <- socketConnection(host="localhost", server=TRUE, port=port, open="r+b") on.exit(close(s)) - serve(s) + tryCatch(serve(s), endOfFile=function(c) NULL) } serve <- function(io) { @@ -51,7 +63,7 @@ dispatch <- function(slimeConnection, event, sldbState=NULL) { sendToEmacs <- function(slimeConnection, obj) { io <- slimeConnection$io payload <- writeSexpToString(obj) - writeChar(sprintf("%06x", nchar(payload)), io, eos=NULL) + writeChar(sprintf("%06x", nchar(payload, type="bytes")), io, eos=NULL) writeChar(payload, io, eos=NULL) flush(io) } @@ -134,6 +146,11 @@ readPacket <- function(io) { readChunk <- function(io, len) { buffer <- readChar(io, len) + if(length(buffer) == 0) { + condition <- simpleCondition("End of file on io") + class(condition) <- c("endOfFile", class(condition)) + signalCondition(condition) + } if(nchar(buffer) != len) { stop("short read in readChunk") } @@ -276,6 +293,8 @@ printToString <- function(val) { `swank:connection-info` <- function (slimeConnection, sldbState) { list(quote(`:pid`), Sys.getpid(), quote(`:package`), list(quote(`:name`), "R", quote(`:prompt`), "R> "), + quote(`:version`), "2014-09-13", + quote(`:encoding`), list(quote(`:coding-systems`), list("utf-8-unix")), quote(`:lisp-implementation`), list(quote(`:type`), "R", quote(`:name`), "R", quote(`:version`), paste(R.version$major, R.version$minor, sep="."))) @@ -283,7 +302,7 @@ printToString <- function(val) { `swank:swank-require` <- function (slimeConnection, sldbState, contribs) { for(contrib in contribs) { - filename <- sprintf("%s.R", as.character(contrib)) + filename <- sprintf("%s/%s.R", swankrPath, as.character(contrib)) if(file.exists(filename)) { source(filename) } @@ -295,6 +314,8 @@ printToString <- function(val) { list("R", "R") } +`swank-repl:create-repl` <- `swank:create-repl` + makeReplResult <- function(value) { string <- printToString(value) list(quote(`:write-string`), string, @@ -313,20 +334,74 @@ sendReplResultFunction <- sendReplResult `swank:listener-eval` <- function(slimeConnection, sldbState, string) { ## O how ugly string <- gsub("#\\.\\(swank:lookup-presented-object-or-lose([^)]*)\\)", ".(`swank:lookup-presented-object-or-lose`(slimeConnection, sldbState,\\1))", string) - expr <- parse(text=string)[[1]] - ## O maybe this is even uglier - lookedup <- do.call("bquote", list(expr)) - value <- eval(lookedup, envir = globalenv()) - sendReplResultFunction(slimeConnection, value) + for(expr in parse(text=string)) { + expr <- expr + ## O maybe this is even uglier + lookedup <- do.call("bquote", list(expr)) + tmp <- withVisible(eval(lookedup, envir = globalenv())) + if(tmp$visible) { + sendReplResultFunction(slimeConnection, tmp$value) + } + } + list() +} + +`swank-repl:listener-eval` <- `swank:listener-eval` + +`swank:clear-repl-variables` <- function(slimeConnection, sldbState) { list() } `swank:autodoc` <- function(slimeConnection, sldbState, rawForm, ...) { - "No Arglist Information" + list("No Arglist Information", TRUE) } `swank:operator-arglist` <- function(slimeConnection, sldbState, op, package) { - list() + if(!exists(op, envir = globalenv())) { + return(list()) + } + funoid <- get(op, envir = globalenv()) + if(is.function(funoid)) { + args <- formals(funoid) + paste(sprintf("%s=%s", names(args), args), collapse=", ") + } else { + list() + } +} + +`swank:describe-function` <- function(slimeConnection, sldbState, op, package) { + ## FIXME: maybe not the best match? + `swank:operator-arglist`(slimeConnection, sldbState, op, package) +} + +helpFilesWithTopicString <- function(value) { + output <- capture.output(tools:::Rd2txt(utils:::.getHelpFile(value), + options=list(underline_titles=FALSE))) + paste(output, collapse="\n") +} + +`swank:describe-symbol` <- function(slimeConnection, sldbState, op, package) { + value <- help(op) + helpFilesWithTopicString(value) +} + +`swank:apropos-list-for-emacs` <- function(slimeConnection, sldbState, name, onlyExternal, package, caseSensitive) { + x <- help.search(name, fields="alias", package=.packages())$matches + brieflyDescribe <- function(name, title) { + if (exists(name, globalenv())) { + val <- get(name, globalenv()) + kind <- if("function" %in% class(val)) quote(`:function`) else quote(`:variable`) + list(quote(`:designator`), name, kind, title) + } else { + ## maybe + list(quote(`:designator`), name, quote(`:type`), title) + } + } + mapply(brieflyDescribe, x[,"name"], x[,"title"], SIMPLIFY=FALSE) +} + +`swank:describe-definition-for-emacs` <- function(slimeConnection, sldbState, name, kind) { + `swank:describe-symbol`(slimeConnection, sldbState, name, NULL) } `swank:throw-to-toplevel` <- function(slimeConnection, sldbState) { @@ -408,27 +483,65 @@ computeRestartsForEmacs <- function (sldbState) { `swank:frame-locals-and-catch-tags` <- function(slimeConnection, sldbState, index) { frame <- sldbState$frames[[1+index]] objs <- ls(envir=frame) + if(identical(frame, globalenv())) { + objs <- c() + } list(lapply(objs, function(name) { list(quote(`:name`), name, quote(`:id`), 0, - quote(`:value`), printToString(eval(parse(text=name), envir=frame))) }), + quote(`:value`), + tryCatch({ + printToString(eval(parse(text=name), envir=frame)) + }, error=function(c) { + sprintf("error printing object") + }))}), list()) } -`swank:simple-completions` <- function(slimeConnection, sldbState, prefix, package) { - ## fails multiply if prefix contains regexp metacharacters - matches <- apropos(sprintf("^%s", prefix), ignore.case=FALSE) +symbolFieldsCompletion <- function(object, prefix, rest) { + ## FIXME: this is hacky, ignoring several syntax issues (use of + ## and/or necessity for backquoting identifiers: e.g. fields + ## containing hyphens) + if((dollar <- regexpr("$", rest, fixed=TRUE)) == -1) { + matches <- grep(sprintf("^%s", literal2rx(rest)), names(object), value=TRUE) + matches <- sprintf("%s$%s", gsub("\\$[^$]*$", "", prefix), matches) + returnMatches(matches) + } else { + if(exists(substr(rest, 1, dollar-1), object)) { + symbolFieldsCompletion(get(substr(rest, 1, dollar-1), object), prefix, substr(rest, dollar+1, nchar(rest))) + } else { + returnMatches(character(0)) + } + } +} + +returnMatches <- function(matches) { nmatches <- length(matches) if(nmatches == 0) { list(list(), "") } else { longest <- matches[order(nchar(matches))][1] - while(length(grep(sprintf("^%s", longest), matches)) < nmatches) { + while(length(grep(sprintf("^%s", literal2rx(longest)), matches)) < nmatches) { longest <- substr(longest, 1, nchar(longest)-1) } list(as.list(matches), longest) } } +literal2rx <- function(string) { + ## list of ERE metacharacters from ?regexp + gsub("([.\\|()[{^$*+?])", "\\\\\\1", string) +} + +`swank:simple-completions` <- function(slimeConnection, sldbState, prefix, package) { + matches <- apropos(sprintf("^%s", literal2rx(prefix)), ignore.case=FALSE) + nmatches <- length(matches) + if((nmatches == 0) && ((dollar <- regexpr("$", prefix, fixed=TRUE)) > -1)) { + symbolFieldsCompletion(globalenv(), prefix, prefix) + } else { + returnMatches(matches) + } +} + `swank:compile-string-for-emacs` <- function(slimeConnection, sldbState, string, buffer, position, filename, policy) { lineOffset <- charOffset <- colOffset <- NULL for(pos in position) { @@ -447,6 +560,23 @@ computeRestartsForEmacs <- function (sldbState) { ifelse(x[3]==1, x[6]+colOffset-1, x[6])))) } transformSrcrefs <- function(s) { + ## horrendous KLUDGE: we need to short-circuit here for "name" + ## objects, rather than having a nice uniform behaviour, because + ## for expressions of the form x[y,] there is an empty "name" + ## which ends up becoming a `missing' object when passed through + ## the switch; why, I do not know, but it is then impossible to + ## return it, because returning it attempts to evaluate it and + ## evaluating it is an error. Fortunately it appears that names + ## don't have srcrefs attached. + if(mode(s) == "name") { + return(s) + } + if(is(s, "srcref")) { + ## more monumental KLUDGE: parsing (in 2.14, at least) appears + ## to put srcrefs directly in `length 2' objects, which we need + ## to frob directly. + return(frob(list(s))[[1]]) + } srcrefs <- attr(s, "srcref") attribs <- attributes(s) new <- @@ -458,6 +588,9 @@ computeRestartsForEmacs <- function (sldbState) { if(!is.null(attr(s, "srcref"))) { attr(new, "srcref") <- frob(srcrefs) } + if(!is.null(attr(s, "wholeSrcref"))) { + attr(new, "wholeSrcref") <- frob(list(attr(s, "wholeSrcref")))[[1]] + } new } withRestarts({ @@ -481,23 +614,35 @@ withRetryRestart <- function(description, expr) { `swank:interactive-eval` <- function(slimeConnection, sldbState, string) { withRetryRestart("retry SLIME interactive evaluation request", - value <- eval(parse(text=string), envir=globalenv())) - prin1ToString(value) + tmp <- withVisible(eval(parse(text=string), envir=globalenv()))) + if(tmp$visible) { + prin1ToString(tmp$value) + } else { + "# invisible value" + } } `swank:eval-and-grab-output` <- function(slimeConnection, sldbState, string) { withRetryRestart("retry SLIME interactive evaluation request", { output <- - capture.output(value <- eval(parse(text=string), - envir=globalenv())) }) + capture.output(tmp <- withVisible(eval(parse(text=string), + envir=globalenv()))) }) output <- paste(output, sep="", collapse="\n") - list(output, prin1ToString(value)) + if(tmp$visible) { + list(output, prin1ToString(tmp$value)) + } else { + list(output, "# invisible value") + } } `swank:interactive-eval-region` <- function(slimeConnection, sldbState, string) { withRetryRestart("retry SLIME interactive evaluation request", - value <- eval(parse(text=string), envir=globalenv())) - prin1ToString(value) + tmp <- withVisible(eval(parse(text=string), envir=globalenv()))) + if(tmp$visible) { + prin1ToString(tmp$value) + } else { + "# invisible value" + } } `swank:find-definitions-for-emacs` <- function(slimeConnection, sldbState, string) { @@ -556,12 +701,19 @@ resetInspector <- function(slimeConnection) { } inspectObject <- function(slimeConnection, object) { + vectorify <- function(x) { + if(is.vector(x)) { + x + } else { + list(x) + } + } previous <- slimeConnection$istate slimeConnection$istate <- new.env() slimeConnection$istate$object <- object slimeConnection$istate$previous <- previous slimeConnection$istate$content <- emacsInspect(object) - if(!(object %in% slimeConnection$inspectorHistory)) { + if(!(vectorify(object) %in% slimeConnection$inspectorHistory)) { slimeConnection$inspectorHistory <- c(slimeConnection$inspectorHistory, object) } if(!is.null(slimeConnection$istate$previous)) { @@ -572,7 +724,7 @@ inspectObject <- function(slimeConnection, object) { valuePart <- function(istate, object, string) { list(quote(`:value`), - if(is.null(string)) printToString(object) else string, + if(is.null(string)) prin1ToString(object) else string, assignIndexInParts(object, istate)) } @@ -583,7 +735,7 @@ preparePart <- function(istate, part) { switch(as.character(part[[1]]), `:newline` = list("\n"), `:value` = valuePart(istate, part[[2]], part[[3]]), - `:line` = list(printToString(part[[2]]), ": ", + `:line` = list(prin1ToString(part[[2]]), ": ", valuePart(istate, part[[3]], NULL), "\n")) } }