Use evaluate::evaluate() (#15)

* + routines.cpp

* move R functions to a private environment so don't have to fake-namespce them

* basic handle_error

* initial execute()

* rtools.hpp

* using evaluate::evaluate

* Do more in R execute()

CMakeLists.txt

@@ -100,10 +100,12 @@ endif ()
 set(XEUS_R_HEADERS
     include/xeus-r/xeus_r_config.hpp
     include/xeus-r/xinterpreter.hpp
+    include/xeus-r/rtools.hpp
 )
 
 set(XEUS_R_SRC
     src/xinterpreter.cpp
+    src/routines.cpp
 )
 
 set(XEUS_R_MAIN_SRC

environment-dev.yml

@@ -12,6 +12,10 @@ dependencies:
   - cppzmq
   - xtl
   - r-base
+  - r-evaluate
+  - r-jsonlite
+  - r-glue
+  - r-cli
   # Test dependencies
   - pytest
   - jupyter_kernel_test>=0.4.3

include/xeus-r/rtools.hpp

@@ -0,0 +1,45 @@
+#define R_NO_REMAP
+
+#include "R.h"
+#include "Rinternals.h"
+
+namespace xeus_r {
+namespace r {
+
+SEXP r_pairlist(SEXP head) {
+    return Rf_cons(head, R_NilValue);
+}
+
+SEXP r_call(SEXP head) {
+    return Rf_lcons(head, R_NilValue);
+}
+
+template<class... Types>
+SEXP r_pairlist(SEXP head, Types... tail) {
+    PROTECT(head);
+    head = Rf_cons(head, r_pairlist(tail...));
+    UNPROTECT(1);
+    return head;
+}
+
+template<class... Types>
+SEXP r_call(SEXP head, Types... tail) {
+    PROTECT(head);
+    head = Rf_lcons(head, r_pairlist(tail...));
+    UNPROTECT(1);
+    return head;
+}
+
+template<class... Types>
+SEXP invoke_xeusr_fn(const char* f, Types... args) {
+    SEXP sym_xeus_call = Rf_install(".xeus_call");
+
+    SEXP call = PROTECT(r_call(sym_xeus_call, Rf_mkString(f), args...));
+    SEXP result = Rf_eval(call, R_GlobalEnv);
+
+    UNPROTECT(1);
+    return result;
+}
+
+}
+}

include/xeus-r/xinterpreter.hpp

@@ -61,6 +61,9 @@ namespace xeus_r
         void shutdown_request_impl() override;
 
     };
+
+    interpreter* get_interpreter();
+    void register_r_routines();
 }
 
 #ifdef __GNUC__

share/jupyter/kernels/xr/resources/execute.R

@@ -0,0 +1,82 @@
+publish_stream <- function(name, text) {
+  invisible(.Call("xeusr_publish_stream", name, text, PACKAGE = "(embedding)"))
+}
+
+handle_message <- function(msg) {
+  publish_stream("stderr", conditionMessage(msg))
+}
+
+handle_warning <- function(w) {
+  call <- conditionCall(w)
+  call <- if (is.null(call)) '' else sprintf(' in %s', deparse(call)[[1]])
+  msg <- sprintf('Warning message%s:\n%s\n', call, dQuote(conditionMessage(w)))
+
+  publish_stream("stderr", msg)
+}
+
+handle_error <- function(e) {
+  sys_calls <- sys.calls()
+  stack <- capture.output(traceback(sys_calls, max.lines = 1L))
+
+  evalue <- paste(conditionMessage(e), collapse = "\n")
+  trace_back <- c(
+    cli::col_red("--- Error"),
+    evalue, 
+    "",
+    cli::col_red("--- Traceback (most recent call last)"), 
+    stack
+  )
+  publish_execution_error(ename = "ERROR", evalue = evalue, trace_back)
+}
+
+handle_value <- function(execution_counter) function(obj, visible) {
+  if (!visible) return()
+
+  # only doing text-plain for now
+  data <- list(
+    "text/plain" = capture.output(print(obj))
+  )
+
+  publish_execution_result(execution_counter, data)
+}
+
+handle_graphics <- function(plotobj) {
+
+}
+
+publish_execution_error <- function(ename, evalue, trace_back = character()) {
+  invisible(.Call("xeusr_publish_execution_error", ename, evalue, trace_back))
+}
+
+publish_execution_result <- function(execution_count, data, metadata = NULL) {
+  invisible(.Call("xeusr_publish_execution_result", as.integer(execution_count), jsonlite::toJSON(data), jsonlite::toJSON(metadata)))
+}
+
+execute <- function(code, execution_counter) {
+  parsed <- tryCatch(
+    parse(text = code, srcfile = glue::glue("[{execution_counter}]")), 
+    error = function(e) {
+      msg <- paste(conditionMessage(e), collapse = "\n")
+      publish_execution_error("PARSE ERROR", msg)
+      e
+    }
+  )
+  if (inherits(parsed, "error")) return()
+
+  output_handler <- evaluate::new_output_handler(
+    text = function(txt) publish_stream("stdout", txt), 
+    graphics = handle_graphics,
+    message = handle_message, 
+    warning = handle_warning, 
+    error = handle_error, 
+    value = handle_value(execution_counter)
+  )
+
+  evaluate::evaluate(
+    code,
+    envir = globalenv(),
+    output_handler = output_handler,
+    stop_on_error = 1L
+  )
+
+}

share/jupyter/kernels/xr/resources/setup.R

@@ -1,20 +1,32 @@
 local({
 
+  options("cli.num_colors" = 256L)
+
   xeus_env <- if ("tools:xeusr" %in% search()) {
     asEnvironment("tools:xeusr")
   } else {
-    attach(new.env(), "tools:xeusr", pos = 2L)
+    public_env <- new.env()
+    private_env <- new.env(parent = public_env)
+    assign(".xeusr_private_env", private_env, envir = public_env)
+
+    attach(public_env, "tools:xeusr", pos = 2L)
   }
 
+  xeus_private_env <- get(".xeusr_private_env", envir = xeus_env)
+
   here <- file.path(
     dirname(Sys.which("xr")),
     "..", "share", "jupyter", "kernels", "xr", "resources"
   )
 
   files <- setdiff(list.files(here), "setup.R")
 
+  xeus_env$.xeus_call <- function(fn, ...) {
+    get(fn, envir = xeus_private_env)(...)
+  }
+
   for (f in files) {
-    sys.source(file.path(here, f), envir = xeus_env)
+    sys.source(file.path(here, f), envir = xeus_private_env)
   }
 
 })

src/routines.cpp

@@ -0,0 +1,63 @@
+#define R_NO_REMAP
+
+#include "R.h"
+#include "Rinternals.h"
+#include "R_ext/Rdynload.h"
+
+#include "xeus-r/xinterpreter.hpp"
+#include "nlohmann/json.hpp"
+
+namespace xeus_r {
+namespace routines {
+
+SEXP publish_stream(SEXP name_, SEXP text_) {
+    auto name = CHAR(STRING_ELT(name_, 0));
+    auto text = CHAR(STRING_ELT(text_, 0));
+    xeus_r::get_interpreter()->publish_stream(name, text);
+
+    return R_NilValue;
+}
+
+SEXP publish_execution_error(SEXP ename_, SEXP evalue_, SEXP trace_back_) {
+    auto ename = CHAR(STRING_ELT(ename_, 0));
+    auto evalue = CHAR(STRING_ELT(evalue_, 0));
+
+    auto n = XLENGTH(trace_back_);
+    std::vector<std::string> trace_back(n);
+    for (decltype(n) i = 0; i < n; i++) {
+        trace_back[i] = CHAR(STRING_ELT(trace_back_, i));
+    }
+
+    xeus_r::get_interpreter()->publish_execution_error(ename, evalue, std::move(trace_back));
+
+    return R_NilValue;
+}
+
+SEXP publish_execution_result(SEXP execution_count_, SEXP data_, SEXP metadata_) {
+    int execution_count = INTEGER_ELT(execution_count_, 0);
+    auto data = nl::json::parse(CHAR(STRING_ELT(data_, 0)));
+    auto metadata = nl::json::parse(CHAR(STRING_ELT(metadata_, 0)));
+
+    xeus_r::get_interpreter()->publish_execution_result(
+        execution_count, std::move(data), std::move(metadata)
+    );
+
+    return R_NilValue;
+}
+
+}
+
+void register_r_routines() {
+    DllInfo *info = R_getEmbeddingDllInfo();
+
+    static const R_CallMethodDef callMethods[]  = {
+        {"xeusr_publish_stream"          , (DL_FUNC) &routines::publish_stream          , 2},
+        {"xeusr_publish_execution_error" , (DL_FUNC) &routines::publish_execution_error , 3},
+        {"xeusr_publish_execution_result", (DL_FUNC) &routines::publish_execution_result, 3},
+        {NULL, NULL, 0}
+    };
+
+    R_registerRoutines(info, NULL, callMethods, NULL, NULL);
+}
+
+}

src/xinterpreter.cpp

@@ -26,11 +26,16 @@
 #include "Rembedded.h"
 #include "R_ext/Parse.h"
 #include "Rinterface.h"
+#include "xeus-r/rtools.hpp"
 
 namespace xeus_r {
 
 static interpreter* p_interpreter = nullptr;
 
+interpreter* get_interpreter() {
+    return p_interpreter;
+}
+
 void WriteConsoleEx(const char *buf, int buflen, int otype) {
     std::string output(buf, buflen);
     if (otype == 1) {
@@ -90,6 +95,7 @@ SEXP try_parse(const std::string& code, int execution_counter) {
     interpreter::interpreter(int argc, char* argv[])
     {
         Rf_initEmbeddedR(argc, argv);
+        register_r_routines();
 
         R_Outputfile = NULL;
         R_Consolefile = NULL;
@@ -108,98 +114,13 @@ SEXP try_parse(const std::string& code, int execution_counter) {
                                                nl::json /*user_expressions*/,
                                                bool /*allow_stdin*/)
     {
-        // First we need to parse the code
-        SEXP parsed = PROTECT(try_parse(code, execution_counter));
-        if (Rf_inherits(parsed, "error")) {
-            auto err_msg = CHAR(STRING_ELT(VECTOR_ELT(parsed, 0),0));
-            publish_execution_error("ParseError", err_msg, {err_msg});
-
-            UNPROTECT(1); // parsed
-            return xeus::create_error_reply();
-        }
-
-        R_xlen_t i = 0;
-        R_xlen_t n = XLENGTH(parsed);
-
-        // first evaluate all expressions but the last
-        for (; i < n - 1; i++) {
-            SEXP expr = VECTOR_ELT(parsed, i);
-
-            int ErrorOccurred;
-            SEXP result = PROTECT(R_tryEval(expr, R_GlobalEnv, &ErrorOccurred));
-
-            if (ErrorOccurred) {
-                // the error has been printed as part of stderr, at least until we
-                // figure out a way to handle it and propagate it with publish_execution_error()
-                // so there is nothing further to do
+        SEXP code_ = PROTECT(Rf_mkString(code.c_str()));
+        SEXP execution_counter_ = PROTECT(Rf_ScalarInteger(execution_counter));
 
-                UNPROTECT(2); // result, expr
+        SEXP result = r::invoke_xeusr_fn("execute", code_, execution_counter_);
 
-                // TODO: replace with some sort of traceback with publish_execution_error()
-                UNPROTECT(2); // out, parsed
-                return xeus::create_successful_reply(/*payload, user_expressions*/);
-            }
+        UNPROTECT(2);
 
-        }
-
-        // for the last expression, we *might* need to print the result
-        // so we wrap the call in a `withVisible()` so that we can figure out 
-        // its visibility. It seems we cannot use the internal R way of 
-        // doing this with the R_Visible extern variable :shrug:
-        // 
-        // The downside of this is that this injects a `withVisible()` call
-        // in the call stack (#10). So we need to deal with it later, e.g.
-        // when dealing with the traceback 
-        SEXP smb_withVisible = Rf_install("withVisible");
-        SEXP expr = PROTECT(Rf_lang2(smb_withVisible, VECTOR_ELT(parsed, i)));
-
-        int ErrorOccurred;
-        SEXP result = PROTECT(R_tryEval(expr, R_GlobalEnv, &ErrorOccurred));
-
-        if (ErrorOccurred) {
-            // the error has been printed as part of stderr, at least until we
-            // figure out a way to handle it and propagate it with publish_execution_error()
-            // so there is nothing further to do
-
-            UNPROTECT(2); // result, expr
-        } else {
-            // there was no error - so print the result if it is visible
-            // We get a list of two things: 
-            // 1) the result: can be any R object
-            SEXP value = PROTECT(VECTOR_ELT(result, 0));
-
-            // 2) whether it is visible: a scalar LGLSXP
-            bool visible = LOGICAL(VECTOR_ELT(result, 1))[0];
-
-            if (visible) {
-                // the code did not generate an uncaught error and 
-                // the result is visible, so we need to display it
-                //
-                // For now, this means print() it which we do by 
-                // calling the internal print() function Rf_PrintValue
-                // and intercept what would be printed in the console
-                // using capture_WriteConsoleEx instead of the regular 
-                // WriteConsoleEx
-                capture_stream.str("");
-                ptr_R_WriteConsoleEx = capture_WriteConsoleEx;
-                R_ToplevelExec([](void* value) {
-                    Rf_PrintValue((SEXP)value);
-                }, (void*)value);
-
-                // restore the normal printing to the console
-                ptr_R_WriteConsoleEx = WriteConsoleEx;
-
-                nl::json pub_data;
-                pub_data["text/plain"] = capture_stream.str();
-                publish_execution_result(execution_counter, std::move(pub_data), nl::json::object());
-            }
-
-            UNPROTECT(3); // value, result, expr
-        }
-
-
-        UNPROTECT(2); // parsed, out
-
         return xeus::create_successful_reply(/*payload, user_expressions*/);
     }