X-Git-Url: http://christophe.rhodes.io/gitweb/?p=swankr.git;a=blobdiff_plain;f=swank.R;h=57ead0ac9f803a1d2729f737d739c0d4a10fcb69;hp=0b48ed34e1dd29f2e0f5a96bb98594fdeb227db6;hb=fc149c9eb2e0c2d1645f8ab3bfcd52eaaf823dab;hpb=d11a1ea1567dd40eec6d281b6d2836dd4d79b271 diff --git a/swank.R b/swank.R index 0b48ed3..57ead0a 100644 --- a/swank.R +++ b/swank.R @@ -33,9 +33,10 @@ acceptConnections <- function(port, portFile) { 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) { @@ -62,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) } @@ -145,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") } @@ -287,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="."))) @@ -306,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, @@ -336,12 +346,62 @@ sendReplResultFunction <- sendReplResult 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) { @@ -423,6 +483,9 @@ 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`), @@ -434,12 +497,24 @@ computeRestartsForEmacs <- function (sldbState) { list()) } -`swank:simple-completions` <- function(slimeConnection, sldbState, prefix, package) { - literal2rx <- function(string) { - ## list of ERE metacharacters from ?regexp - gsub("([.\\|()[{^$*+?])", "\\\\\\1", string) +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)) + } } - matches <- apropos(sprintf("^%s", literal2rx(prefix)), ignore.case=FALSE) +} + +returnMatches <- function(matches) { nmatches <- length(matches) if(nmatches == 0) { list(list(), "") @@ -452,6 +527,21 @@ computeRestartsForEmacs <- function (sldbState) { } } +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) { @@ -470,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 <- @@ -481,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({ @@ -519,7 +629,7 @@ withRetryRestart <- function(description, expr) { envir=globalenv()))) }) output <- paste(output, sep="", collapse="\n") if(tmp$visible) { - list(output, prin1ToString(value)) + list(output, prin1ToString(tmp$value)) } else { list(output, "# invisible value") } @@ -529,7 +639,7 @@ withRetryRestart <- function(description, expr) { withRetryRestart("retry SLIME interactive evaluation request", tmp <- withVisible(eval(parse(text=string), envir=globalenv()))) if(tmp$visible) { - prin1ToString(value) + prin1ToString(tmp$value) } else { "# invisible value" } @@ -591,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)) { @@ -607,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)) } @@ -618,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")) } }