diff --git a/CMakeLists.txt b/CMakeLists.txt index 0a55794..8c3dd6f 100644 --- a/CMakeLists.txt +++ b/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 diff --git a/environment-dev.yml b/environment-dev.yml index 5b6fb88..74fff75 100644 --- a/environment-dev.yml +++ b/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 diff --git a/include/xeus-r/rtools.hpp b/include/xeus-r/rtools.hpp new file mode 100644 index 0000000..7241957 --- /dev/null +++ b/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 +SEXP r_pairlist(SEXP head, Types... tail) { + PROTECT(head); + head = Rf_cons(head, r_pairlist(tail...)); + UNPROTECT(1); + return head; +} + +template +SEXP r_call(SEXP head, Types... tail) { + PROTECT(head); + head = Rf_lcons(head, r_pairlist(tail...)); + UNPROTECT(1); + return head; +} + +template +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; +} + +} +} \ No newline at end of file diff --git a/include/xeus-r/xinterpreter.hpp b/include/xeus-r/xinterpreter.hpp index b8d1b3c..fa2835b 100644 --- a/include/xeus-r/xinterpreter.hpp +++ b/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__ diff --git a/share/jupyter/kernels/xr/resources/execute.R b/share/jupyter/kernels/xr/resources/execute.R new file mode 100644 index 0000000..560b8ca --- /dev/null +++ b/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 + ) + +} diff --git a/share/jupyter/kernels/xr/resources/hello.R b/share/jupyter/kernels/xr/resources/hello.R deleted file mode 100644 index 047a6cd..0000000 --- a/share/jupyter/kernels/xr/resources/hello.R +++ /dev/null @@ -1,3 +0,0 @@ -.xeus_hello <- function() { - print("hello") -} diff --git a/share/jupyter/kernels/xr/resources/setup.R b/share/jupyter/kernels/xr/resources/setup.R index 1e45661..efa5ce9 100644 --- a/share/jupyter/kernels/xr/resources/setup.R +++ b/share/jupyter/kernels/xr/resources/setup.R @@ -1,11 +1,19 @@ 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" @@ -13,8 +21,12 @@ local({ 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) } }) diff --git a/src/routines.cpp b/src/routines.cpp new file mode 100644 index 0000000..54d22cc --- /dev/null +++ b/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 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); +} + +} diff --git a/src/xinterpreter.cpp b/src/xinterpreter.cpp index f1d6ec2..bbbad75 100644 --- a/src/xinterpreter.cpp +++ b/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*/); }