Christophe Weblog Wiki Code Publications Music
less debugging output cruft in `swank:frame-locals-and-catch-tags`
[swankr.git] / swank.R
1 ### This program is free software; you can redistribute it and/or
2 ### modify it under the terms of the GNU General Public Licence as
3 ### published by the Free Software Foundation; either version 2 of the
4 ### Licence, or (at your option) any later version.
5 ###
6 ### This program is distributed in the hope that it will be useful,
7 ### but WITHOUT ANY WARRANTY; without even the implied warranty of
8 ### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
9 ### GNU General Public Licence for more details.
10 ###
11 ### A copy of version 2 of the GNU General Public Licence is available
12 ### at <http://www.gnu.org/licenses/old-licenses/gpl-2.0.txt>; the
13 ### latest version of the GNU General Public Licence is available at
14 ### <http://www.gnu.org/licenses/gpl.txt>.
15
16 swank <- function(port=4005) {
17   acceptConnections(port, FALSE)
18 }
19
20 startSwank <- function(portFile) {
21   acceptConnections(FALSE, portFile)
22 }
23
24 acceptConnections <- function(port, portFile) {
25   s <- socketConnection(host="localhost", server=TRUE, port=port, open="r+b")
26   on.exit(close(s))
27   serve(s)
28 }
29
30 serve <- function(io) {
31   mainLoop(io)
32 }
33
34 mainLoop <- function(io) {
35   slimeConnection <- new.env()
36   slimeConnection$io <- io
37   while(TRUE) {
38     withRestarts(tryCatch(dispatch(slimeConnection, readPacket(io)),
39                           swankTopLevel=function(c) NULL),
40                  abort="return to SLIME's toplevel")
41   }
42 }
43
44 dispatch <- function(slimeConnection, event, sldbState=NULL) {
45   str(event)
46   kind <- event[[1]]
47   if(kind == quote(`:emacs-rex`)) {
48     do.call("emacsRex", c(list(slimeConnection), list(sldbState), event[-1]))
49   }
50 }
51
52 sendToEmacs <- function(slimeConnection, obj) {
53   io <- slimeConnection$io
54   str(obj)
55   payload <- writeSexpToString(obj)
56   writeChar(sprintf("%06x", nchar(payload)), io, eos=NULL)
57   writeChar(payload, io, eos=NULL)
58   flush(io)
59   cat(sprintf("%06x", nchar(payload)), payload, sep="")
60 }
61
62 callify <- function(form) {
63   ## we implement here the conversion from Lisp S-expression (or list)
64   ## expressions of code into our own, swankr, calling convention,
65   ## with slimeConnection and sldbState as first and second arguments.
66   ## as.call() gets us part of the way, but we need to walk the list
67   ## recursively to mimic CL:EVAL; we need to avoid converting R
68   ## special operators which we are punning (only `quote`, for now)
69   ## into this calling convention.
70   if(is.list(form)) {
71     if(form[[1]] == quote(quote)) {
72       as.call(form)
73     } else {
74       as.call(c(list(form[[1]], quote(slimeConnection), quote(sldbState)), lapply(form[-1], callify)))
75     }
76   } else {
77     form
78   }
79 }
80
81 emacsRex <- function(slimeConnection, sldbState, form, pkg, thread, id, level=0) {
82   ok <- FALSE
83   value <- NULL
84   tryCatch({
85     withCallingHandlers({
86       call <- callify(form)
87       value <- eval(call)
88       ok <- TRUE
89     }, error=function(c) {
90       newSldbState <- makeSldbState(c, if(is.null(sldbState)) 0 else sldbState$level+1, id)
91       withRestarts(sldbLoop(slimeConnection, newSldbState, id), abort=paste("return to sldb level", newSldbState$level)) })},
92     finally=sendToEmacs(slimeConnection, list(quote(`:return`), if(ok) list(quote(`:ok`), value) else list(quote(`:abort`)), id)))
93 }
94
95 makeSldbState <- function(condition, level, id) {
96   calls <- rev(sys.calls())[-1]
97   frames <- rev(sys.frames())[-1]
98   restarts <- rev(computeRestarts(condition))[-1]
99   ret <- list(condition=condition, level=level, id=id, restarts=restarts, calls=calls, frames=frames)
100   class(ret) <- c("sldbState", class(ret))
101   ret
102 }
103
104 sldbLoop <- function(slimeConnection, sldbState, id) {
105   tryCatch({
106     io <- slimeConnection$io
107     sendToEmacs(slimeConnection, c(list(quote(`:debug`), id, sldbState$level), `swank:debugger-info-for-emacs`(slimeConnection, sldbState)))
108     sendToEmacs(slimeConnection, list(quote(`:debug-activate`), id, sldbState$level, FALSE))
109     while(TRUE) {
110       dispatch(slimeConnection, readPacket(io), sldbState)
111     }
112   }, finally=sendToEmacs(slimeConnection, c(list(quote(`:debug-return`), id, sldbState$level, FALSE))))
113 }
114
115 readPacket <- function(io) {
116   socketSelect(list(io))
117   header <- readChunk(io, 6)
118   len <- strtoi(header, base=16)
119   payload <- readChunk(io, len)
120   readSexpFromString(payload)
121 }
122
123 readChunk <- function(io, len) {
124   buffer <- readChar(io, len)
125   if(nchar(buffer) != len) {
126     stop("short read in readChunk")
127   }
128   buffer
129 }
130
131 readSexpFromString <- function(string) {
132   pos <- 1
133   read <- function() {
134     skipWhitespace()
135     char <- substr(string, pos, pos)
136     switch(char,
137            "("=readList(),
138            "\""=readString(),
139            "'"=readQuote(),
140            {
141              if(pos > nchar(string))
142                stop("EOF during read")
143              obj <- readNumberOrSymbol()
144              if(obj == quote(`.`)) {
145                stop("Consing dot not implemented")
146              }
147              obj
148            })
149   }
150   skipWhitespace <- function() {
151     while(substr(string, pos, pos) %in% c(" ", "\t", "\n")) {
152       pos <<- pos + 1
153     }
154   }
155   readList <- function() {
156     ret <- list()
157     pos <<- pos + 1
158     while(TRUE) {
159       skipWhitespace()
160       char <- substr(string, pos, pos)
161       if(char == ")") {
162         pos <<- pos + 1
163         break
164       } else {
165         obj <- read()
166         if(length(obj) == 1 && obj == quote(`.`)) {
167           stop("Consing dot not implemented")
168         }
169         ret <- c(ret, list(obj))
170       }
171     }
172     ret
173   }
174   readString <- function() {
175     ret <- ""
176     addChar <- function(c) { ret <<- paste(ret, c, sep="") }
177     while(TRUE) {
178       pos <<- pos + 1
179       char <- substr(string, pos, pos)
180       switch(char,
181              "\""={ pos <<- pos + 1; break },
182              "\\"={ pos <<- pos + 1
183                     char2 <- substr(string, pos, pos)
184                     switch(char2,
185                            "\""=addChar(char2),
186                            "\\"=addChar(char2),
187                            stop("Unrecognized escape character")) },
188              addChar(char))
189     }
190     ret
191   }
192   readNumberOrSymbol <- function() {
193     token <- readToken()
194     if(nchar(token)==0) {
195       stop("End of file reading token")
196     } else if(grepl("^[0-9]+$", token)) {
197       strtoi(token)
198     } else if(grepl("^[0-9]+\\.[0-9]+$", token)) {
199       as.double(token)
200     } else {
201       as.name(token)
202     }
203   }
204   readToken <- function() {
205     token <- ""
206     while(TRUE) {
207       char <- substr(string, pos, pos)
208       if(char == "") {
209         break;
210       } else if(char %in% c(" ", "\n", "\t", "(", ")", "\"", "'")) {
211         break;
212       } else {
213         token <- paste(token, char, sep="")
214         pos <<- pos + 1
215       }
216     }
217     token
218   }
219   read()
220 }
221
222 writeSexpToString <- function(obj) {
223   writeSexpToStringLoop <- function(obj) {
224     switch(typeof(obj),
225            "character"={ string <- paste(string, "\"", gsub("([\"\\])", "\\\\\\1", obj), "\"", sep="") },
226            "list"={ string <- paste(string, "(", sep="")
227                     max <- length(obj)
228                     if(max > 0) {
229                       for(i in 1:max) {
230                         string <- paste(string, writeSexpToString(obj[[i]]), sep="")
231                         if(i != max) {
232                           string <- paste(string, " ", sep="")
233                         }
234                       }
235                     }
236                     string <- paste(string, ")", sep="") },
237            "symbol"={ string <- paste(string, as.character(obj), sep="") },
238            "logical"={ string <- if(obj) { paste(string, "t", sep="") } else { paste(string, "nil", sep="") }},
239            "double"={ string <- paste(string, as.character(obj), sep="") },
240            "integer"={ string <- paste(string, as.character(obj), sep="") },
241            stop(paste("can't write object ", obj, sep="")))
242     string
243   }
244   string <- ""
245   writeSexpToStringLoop(obj)
246 }
247
248 prin1ToString <- function(val) {
249   paste(deparse(val, backtick=TRUE, control=c("delayPromises", "keepNA")),
250         sep="", collapse="\n")
251 }
252
253 printToString <- function(val) {
254   paste(capture.output(print(val)), sep="", collapse="\n")
255 }
256
257 `swank:connection-info` <- function (slimeConnection, sldbState) {
258   list(quote(`:pid`), Sys.getpid(),
259        quote(`:package`), list(quote(`:name`), "R", quote(`:prompt`), "R> "),
260        quote(`:lisp-implementation`), list(quote(`:type`), "R",
261                                            quote(`:name`), "R",
262                                            quote(`:version`), paste(R.version$major, R.version$minor, sep=".")))
263 }
264
265 `swank:swank-require` <- function (slimeConnection, sldbState, contribs) {
266   for(contrib in contribs) {
267     filename <- sprintf("%s.R", as.character(contrib))
268     if(file.exists(filename)) {
269       source(filename, verbose=TRUE)
270     }
271   }
272   list()
273 }
274
275 `swank:create-repl` <- function(slimeConnection, sldbState, env, ...) {
276   list("R", "R")
277 }
278
279 makeReplResult <- function(value) {
280   string <- printToString(value)
281   list(quote(`:write-string`), string,
282        quote(`:repl-result`))
283 }
284
285 makeReplResultFunction <- makeReplResult
286
287 sendReplResult <- function(slimeConnection, value) {
288   result <- makeReplResultFunction(value)
289   sendToEmacs(slimeConnection, result)
290 }
291
292 sendReplResultFunction <- sendReplResult
293
294 `swank:listener-eval` <- function(slimeConnection, sldbState, string) {
295   string <- gsub("#\\.\\(swank:lookup-presented-object-or-lose([^)]*)\\)", ".(`swank:lookup-presented-object-or-lose`(slimeConnection, sldbState,\\1))", string)
296   expr <- parse(text=string)[[1]]
297   lookedup <- do.call("bquote", list(expr))
298   value <- eval(lookedup, envir = globalenv())
299   sendReplResultFunction(slimeConnection, value)
300   list()
301 }
302
303 `swank:autodoc` <- function(slimeConnection, sldbState, rawForm, ...) {
304   "No Arglist Information"
305 }
306
307 `swank:operator-arglist` <- function(slimeConnection, sldbState, op, package) {
308   list()
309 }
310
311 `swank:throw-to-toplevel` <- function(slimeConnection, sldbState) {
312   condition <- simpleCondition("Throw to toplevel")
313   class(condition) <- c("swankTopLevel", class(condition))
314   signalCondition(condition)
315 }
316
317 `swank:backtrace` <- function(slimeConnection, sldbState, from=0, to=NULL) {
318   calls <- sldbState$calls
319   if(is.null(to)) to <- length(calls)
320   from <- from+1
321   calls <- lapply(calls[from:to],
322                   { frameNumber <- from-1;
323                     function (x) {
324                       ret <- list(frameNumber, paste(format(x), sep="", collapse=" "))
325                       frameNumber <<- 1+frameNumber
326                       ret
327                     }
328                   })
329 }
330
331 computeRestartsForEmacs <- function (sldbState) {
332   lapply(sldbState$restarts,
333          function(x) {
334            ## this is all a little bit internalsy
335            restartName <- x[[1]][[1]]
336            description <- restartDescription(x)
337            list(restartName, if(is.null(description)) restartName else description)
338          })
339 }
340
341 `swank:debugger-info-for-emacs` <- function(slimeConnection, sldbState, from=0, to=NULL) {
342   list(list(as.character(sldbState$condition), sprintf("  [%s]", class(sldbState$condition)[[1]]), FALSE),
343        computeRestartsForEmacs(sldbState),
344        `swank:backtrace`(slimeConnection, sldbState, from, to),
345        list(sldbState$id))
346 }
347
348 `swank:invoke-nth-restart-for-emacs` <- function(slimeConnection, sldbState, level, n) {
349   if(sldbState$level == level) {
350     invokeRestart(sldbState$restarts[[n+1]])
351   }
352 }
353
354 `swank:frame-source-location` <- function(slimeConnection, sldbState, n) {
355   call <- sldbState$calls[[n+1]]
356   srcref <- attr(call, "srcref")
357   srcfile <- attr(srcref, "srcfile")
358   if(is.null(srcfile)) {
359     list(quote(`:error`), "no srcfile")
360   } else {
361     list(quote(`:location`),
362          list(quote(`:file`), sprintf("%s/%s", srcfile$wd, srcfile$filename)),
363          list(quote(`:line`), srcref[[1]], srcref[[2]]-1),
364          FALSE)
365   }
366 }
367
368 `swank:buffer-first-change` <- function(slimeConnection, sldbState, filename) {
369   FALSE
370 }
371
372 `swank:eval-string-in-frame` <- function(slimeConnection, sldbState, string, index) {
373   frame <- sldbState$frames[[1+index]]
374   withRetryRestart("retry SLIME interactive evaluation request",
375                    value <- eval(parse(text=string), envir=frame))
376   printToString(value)
377 }
378
379 `swank:frame-locals-and-catch-tags` <- function(slimeConnection, sldbState, index) {
380   frame <- sldbState$frames[[1+index]]
381   objs <- ls(envir=frame)
382   list(lapply(objs, function(name) { list(quote(`:name`), name,
383                                           quote(`:id`), 0,
384                                           quote(`:value`), printToString(eval(parse(text=name), envir=frame))) }),
385        list())
386 }
387
388 `swank:simple-completions` <- function(slimeConnection, sldbState, prefix, package) {
389   ## fails multiply if prefix contains regexp metacharacters
390   matches <- apropos(sprintf("^%s", prefix), ignore.case=FALSE)
391   nmatches <- length(matches)
392   if(nmatches == 0) {
393     list(list(), "")
394   } else {
395     longest <- matches[order(nchar(matches))][1]
396     while(length(grep(sprintf("^%s", longest), matches)) < nmatches) {
397       longest <- substr(longest, 1, nchar(longest)-1)
398     }
399     list(as.list(matches), longest)
400   }
401 }
402
403 `swank:compile-string-for-emacs` <- function(slimeConnection, sldbState, string, buffer, position, filename, policy) {
404   # FIXME: I think in parse() here we can use srcref to associate
405   # buffer/filename/position to the objects.  Or something.
406   withRestarts({ times <- system.time(eval(parse(text=string), envir = globalenv())) },
407                abort="abort compilation")
408   list(quote(`:compilation-result`), list(), TRUE, times[3])
409 }
410
411 withRetryRestart <- function(description, expr) {
412   call <- substitute(expr)
413   retry <- TRUE
414   while(retry) {
415     retry <- FALSE
416     withRestarts(eval.parent(call),
417                  retry=list(description=description,
418                    handler=function() retry <<- TRUE))
419   }
420 }
421
422 `swank:interactive-eval` <-  function(slimeConnection, sldbState, string) {
423   withRetryRestart("retry SLIME interactive evaluation request",
424                    value <- eval(parse(text=string), envir=globalenv()))
425   prin1ToString(value)
426 }
427
428 `swank:eval-and-grab-output` <- function(slimeConnection, sldbState, string) {
429   withRetryRestart("retry SLIME interactive evaluation request",
430                    { output <-
431                        capture.output(value <- eval(parse(text=string),
432                                                     envir=globalenv())) })
433   output <- paste(output, sep="", collapse="\n")
434   list(output, prin1ToString(value))
435 }
436
437 `swank:find-definitions-for-emacs` <- function(slimeConnection, sldbState, string) {
438   if(exists(string, envir = globalenv())) {
439     thing <- get(string, envir = globalenv())
440     if(inherits(thing, "function")) {
441       body <- body(thing)
442       srcref <- attr(body, "srcref")
443       srcfile <- attr(body, "srcfile")
444       if(is.null(srcfile)) {
445         list()
446       } else {
447         filename <- get("filename", srcfile)
448         list(list(sprintf("function %s", string),
449                   list(quote(`:location`),
450                        list(quote(`:file`), sprintf("%s/%s", srcfile$wd, srcfile$filename)),
451                        list(quote(`:line`), srcref[[2]][[1]], srcref[[2]][[2]]-1),
452                        list())))
453       }
454     } else {
455       list()
456     }
457   } else {
458     list()
459   }
460 }
461
462 `swank:value-for-editing` <- function(slimeConnection, sldbState, string) {
463   paste(deparse(eval(parse(text=string), envir = globalenv()), control="all"),
464         collapse="\n", sep="")
465 }
466
467 `swank:commit-edited-value` <- function(slimeConnection, sldbState, string, value) {
468   eval(parse(text=sprintf("%s <- %s", string, value)), envir = globalenv())
469   TRUE
470 }
471
472 resetInspector <- function(slimeConnection) {
473   assign("istate", list(), envir=slimeConnection)
474   assign("inspectorHistory", NULL, envir=slimeConnection)
475 }
476
477 `swank:init-inspector` <- function(slimeConnection, sldbState, string) {
478   withRetryRestart("retry SLIME inspection request",
479                    { resetInspector(slimeConnection)
480                      value <- inspectObject(slimeConnection, eval(parse(text=string), envir=globalenv()))
481                    })
482   value
483 }
484
485 inspectObject <- function(slimeConnection, object) {
486   previous <- slimeConnection$istate
487   slimeConnection$istate <- new.env()
488   slimeConnection$istate$object <- object
489   slimeConnection$istate$previous <- previous
490   slimeConnection$istate$content <- emacsInspect(object)
491   if(!(object %in% slimeConnection$inspectorHistory)) {
492     slimeConnection$inspectorHistory <- c(slimeConnection$inspectorHistory, object)
493   }
494   if(!is.null(slimeConnection$istate$previous)) {
495     slimeConnection$istate$previous$`next` <- slimeConnection$istate
496   }
497   istateToElisp(slimeConnection$istate)
498 }
499
500 valuePart <- function(istate, object, string) {
501   list(quote(`:value`),
502        if(is.null(string)) printToString(object) else string,
503        assignIndexInParts(object, istate))
504 }
505
506 preparePart <- function(istate, part) {
507   if(is.character(part)) {
508     list(part)
509   } else {
510     switch(as.character(part[[1]]),
511            `:newline` = list("\n"),
512            `:value` = valuePart(istate, part[[2]], part[[3]]),
513            `:line` = list(printToString(part[[2]]), ": ",
514              valuePart(istate, part[[3]], NULL), "\n"))
515   }
516 }
517
518 prepareRange <- function(istate, start, end) {
519   range <- istate$content[start+1:min(end+1, length(istate$content))]
520   ps <- NULL
521   for(part in range) {
522     ps <- c(ps, preparePart(istate, part))
523   }
524   list(ps, if(length(ps)<end-start) { start+length(ps) } else { end+1000 },
525        start, end)
526 }
527
528 assignIndexInParts <- function(object, istate) {
529   ret <- 1+length(istate$parts)
530   istate$parts <- c(istate$parts, list(object))
531   ret
532 }
533
534 istateToElisp <- function(istate) {
535   list(quote(`:title`), deparse(istate$object, control="all", nlines=1),
536        quote(`:id`), assignIndexInParts(istate$object, istate),
537        quote(`:content`), prepareRange(istate, 0, 500))
538 }
539
540 emacsInspect <- function(object) {
541   UseMethod("emacsInspect")
542 }
543
544 emacsInspect.default <- function(thing) {
545   c(list(paste("a ", class(thing)[[1]], sep=""), list(quote(`:newline`))))
546 }
547
548 emacsInspect.list <- function(list) {
549   c(list("a list", list(quote(`:newline`))),
550     mapply(function(name, value) { list(list(quote(`:line`), name, value)) },
551            names(list), list))
552 }
553
554 emacsInspect.numeric <- function(numeric) {
555   c(list("a numeric", list(quote(`:newline`))),
556     mapply(function(name, value) { list(list(quote(`:line`), name, value)) },
557            (1:length(numeric)), numeric))
558 }
559
560 `swank:quit-inspector` <- function(slimeConnection, sldbState) {
561   resetInspector(slimeConnection)
562   FALSE
563 }
564
565 `swank:inspector-nth-part` <- function(slimeConnection, sldbState, index) {
566   slimeConnection$istate$parts[[index]]
567 }
568
569 `swank:inspect-nth-part` <- function(slimeConnection, sldbState, index) {
570   object <- `swank:inspector-nth-part`(slimeConnection, sldbState, index)
571   inspectObject(slimeConnection, object)
572 }
573
574 `swank:inspector-pop` <- function(slimeConnection, sldbState) {
575   if(!is.null(slimeConnection$istate$previous)) {
576     slimeConnection$istate <- slimeConnection$istate$previous
577     istateToElisp(slimeConnection$istate)
578   } else {
579     FALSE
580   }
581 }
582
583 `swank:inspector-next` <- function(slimeConnection, sldbState) {
584   if(!is.null(slimeConnection$istate$`next`)) {
585     slimeConnection$istate <- slimeConnection$istate$`next`
586     istateToElisp(slimeConnection$istate)
587   } else {
588     FALSE
589   }
590 }
591
592 `swank:inspector-eval` <- function(slimeConnection, sldbState, string) {
593   expr <- parse(text=string)[[1]]
594   object <- slimeConnection$istate$object
595   if(inherits(object, "list")|inherits(object, "environment")) {
596     substituted <- substituteDirect(expr, object)
597     eval(substituted, envir=globalenv())
598   } else {
599     eval(expr, envir=globalenv())
600   }
601 }
602
603 `swank:inspect-current-condition` <- function(slimeConnection, sldbState) {
604   resetInspector(slimeConnection)
605   inspectObject(slimeConnection, sldbState$condition)
606 }
607
608 `swank:inspect-frame-var` <- function(slimeConnection, sldbState, frame, var) {
609   resetInspector(slimeConnection)
610   frame <- sldbState$frames[[1+frame]]
611   name <- ls(envir=frame)[[1+var]]
612   object <- get(name, envir=frame)
613   inspectObject(slimeConnection, object)
614 }
615
616 `swank:default-directory` <- function(slimeConnection, sldbState) {
617   getwd()
618 }
619
620 `swank:set-default-directory` <- function(slimeConnection, sldbState, directory) {
621   setwd(directory)
622   `swank:default-directory`(slimeConnection, sldbState)
623 }
624
625 `swank:load-file` <- function(slimeConnection, sldbState, filename) {
626   source(filename, local=FALSE)
627   TRUE
628 }
629
630 `swank:compile-file-for-emacs` <- function(slimeConnection, sldbState, filename, loadp, ...) {
631   times <- system.time(parse(filename))
632   list(quote(`:compilation-result`), list(), TRUE, times[3], substitute(loadp), filename)
633 }