From e35149b43e4da28f542c6bdf2decd802e84dd440 Mon Sep 17 00:00:00 2001
From: Christophe Rhodes <csr21@cantab.net>
Date: Tue, 31 Aug 2010 08:54:54 +0100
Subject: [PATCH] initial implementation of support for REPL presentations

There's a lot here that's ugly, unfinished or just downright horrible.
Most notably, presentation support depends on swank-side read-time
evaluation (indicated with Common Lisp syntax, which hilariously is a
comment in R).  We can't support that in general, but we can
special-case the presentation-specific operator.

But then the next difficulty comes along; actually performing that
read-time evaluation needs to happen in a different environment than
the evaluation of the REPL form.  In order to achieve this, we abuse
bquote() the equivalent of Lisp's backquote facility, by calling what
in CL terms would be its macro-function on the parsed, preprocessed
expression; only after doing that (and hence resolving the `read-time'
evaluations) do we evaluate the call itself.

The implementation of presentation protocol messages is also slightly
ugly; having to implement cl:nth-value is particulraly horrible, but
the lack of weak references / weak tables in R (at least as far as I
can tell at the moment) is a cause of niggling concern.
---
 swank-presentations.R | 47 +++++++++++++++++++++++++++++++++++++++++++
 swank.R               | 18 ++++++++++++++---
 2 files changed, 62 insertions(+), 3 deletions(-)
 create mode 100644 swank-presentations.R

diff --git a/swank-presentations.R b/swank-presentations.R
new file mode 100644
index 0000000..d2ed3f7
--- /dev/null
+++ b/swank-presentations.R
@@ -0,0 +1,47 @@
+presentationCounter <- 0
+
+savePresentedObject <- function(slimeConnection, value) {
+  if(!exists("idToObject", envir=slimeConnection)) {
+    assign("idToObject", new.env(), envir=slimeConnection)
+  }
+  presentationCounter <<- presentationCounter + 1
+  assign(as.character(presentationCounter), value, envir=slimeConnection$idToObject)
+  presentationCounter
+}
+
+presentReplResult <- function(slimeConnection, value) {
+  id <- savePresentedObject(slimeConnection, value)
+  sendToEmacs(slimeConnection,
+              list(quote(`:presentation-start`), id, quote(`:repl-result`)))
+  sendReplResult(slimeConnection, value)
+  sendToEmacs(slimeConnection,
+              list(quote(`:presentation-end`), id, quote(`:repl-result`)))
+  sendToEmacs(slimeConnection,
+              list(quote(`:write-string`), "\n", quote(`:repl-result`)))
+}
+
+sendReplResultFunction <- presentReplResult
+
+`cl:nth-value` <- function(slimeConnection, sldbState, n, values) {
+  values[[n+1]]
+}
+
+`swank:lookup-presented-object` <- function(slimeConnection, sldbState, id) {
+  str(ls(slimeConnection))
+  if(exists(as.character(id), envir=slimeConnection$idToObject)) {
+    value <- get(as.character(id), envir=slimeConnection$idToObject)
+    list(value, TRUE)
+  } else {
+    list(FALSE, FALSE)
+  }
+}
+
+`swank:lookup-presented-object-or-lose` <- function(slimeConnection, sldbState, id) {
+  stuff <- `swank:lookup-presented-object`(slimeConnection, sldbState, id)
+  if(stuff[[2]]) {
+    stuff[[1]]
+  } else {
+    stop(sprintf("attempt to access unrecorded object (id %d)", id))
+  }
+}
+    
diff --git a/swank.R b/swank.R
index e6e78c7..bd7e093 100644
--- a/swank.R
+++ b/swank.R
@@ -272,10 +272,22 @@ printToString <- function(val) {
   list("R", "R")
 }
 
+sendReplResult <- function(slimeConnection, value) {
+  string <- printToString(value)
+  sendToEmacs(slimeConnection,
+              list(quote(`:write-string`),
+                   paste(string, collapse="\n"),
+                   quote(`:repl-result`)))
+}
+
+sendReplResultFunction <- sendReplResult
+
 `swank:listener-eval` <- function(slimeConnection, sldbState, string) {
-  val <- eval(parse(text=string), envir = globalenv())
-  string <- printToString(val)
-  sendToEmacs(slimeConnection, list(quote(`:write-string`), paste(string, collapse="\n"), quote(`:repl-result`)))
+  string <- gsub("#\\.\\(swank:lookup-presented-object-or-lose([^)]*)\\)", ".(`swank:lookup-presented-object-or-lose`(slimeConnection, sldbState,\\1))", string)
+  expr <- parse(text=string)[[1]]
+  lookedup <- do.call("bquote", list(expr))
+  value <- eval(lookedup, envir = globalenv())
+  sendReplResultFunction(slimeConnection, value)
   list()
 }
 
-- 
2.39.5