Merge pull request #18 from andrjohns/sexp-to-jsvalue

Tidy functionality and add tests for R to JS conversions

.Rbuildignore

@@ -9,3 +9,4 @@
 ^src/quickjs/\.github$
 ^src/quickjs/\.git$
 semicolon_delimited_script
+Makefile

Makefile

@@ -0,0 +1,2 @@
+clean:
+	$(MAKE) -C src -f Makevars clean

NAMESPACE

@@ -4,6 +4,7 @@ export(JSContext)
 export(cxxflags)
 export(ldflags)
 export(qjs_eval)
+export(qjs_passthrough)
 export(quickjs_version)
 importFrom(jsonlite,fromJSON)
 useDynLib(QuickJSR, .registration = TRUE)

R/qjs.R

@@ -36,6 +36,19 @@ qjs_validate <- function(ctx_ptr, function_name) {
   .Call(`qjs_validate_`, ctx_ptr, function_name)
 }
 
-qjs_passthrough <- function(args) {
-  .Call(`qjs_passthrough_`, args)
+#' qjs_passthrough
+#'
+#' Test function to pass through arguments
+#'
+#' @param args Args to pass through
+#' @param jsonlite Whether to return a JSON string to be parsed by jsonlite
+#' @return The input argument unchanged
+#'
+#' @export
+qjs_passthrough <- function(args, jsonlite = TRUE) {
+  if (isTRUE(jsonlite)) {
+    parse_return(.Call(`qjs_passthrough_`, args, jsonlite))
+  } else {
+    .Call(`qjs_passthrough_`, args, jsonlite)
+  }
 }

inst/include/quickjsr.hpp

@@ -0,0 +1,8 @@
+#ifndef QUICKJSR_HPP
+#define QUICKJSR_HPP
+
+#include <quickjsr/SEXP_to_JSValue.hpp>
+#include <quickjsr/JSValue_to_SEXP.hpp>
+#include <quickjsr/JSValue_to_JSON.hpp>
+
+#endif

inst/include/quickjsr/JSValue_to_JSON.hpp

@@ -0,0 +1,33 @@
+#ifndef QUICKJSR_JSVALUE_TO_JSON_HPP
+#define QUICKJSR_JSVALUE_TO_JSON_HPP
+
+#include <cpp11.hpp>
+#include <quickjs-libc.h>
+
+namespace quickjsr {
+
+std::string JS_ValToJSON(JSContext* ctx, JSValue* val) {
+  JSValue global = JS_GetGlobalObject(ctx);
+  JSValue json = JS_GetPropertyStr(ctx, global, "JSON");
+  JSValue stringify = JS_GetPropertyStr(ctx, json, "stringify");
+
+  JSValue result_js = JS_Call(ctx, stringify, global, 1, val);
+  std::string result;
+  if (JS_IsException(result_js)) {
+    js_std_dump_error(ctx);
+    result = "Error!";
+  } else {
+    result = JS_ToCString(ctx, result_js);
+  }
+
+  JS_FreeValue(ctx, result_js);
+  JS_FreeValue(ctx, stringify);
+  JS_FreeValue(ctx, json);
+  JS_FreeValue(ctx, global);
+
+  return result;
+}
+
+} // namespace quickjsr
+
+#endif

inst/include/quickjsr/JSValue_to_SEXP.hpp

@@ -0,0 +1,31 @@
+#ifndef QUICKJSR_JSVALUE_TO_SEXP_HPP
+#define QUICKJSR_JSVALUE_TO_SEXP_HPP
+
+#include <cpp11.hpp>
+#include <quickjs-libc.h>
+
+namespace quickjsr {
+
+SEXP JSValue_to_SEXP_scalar(JSContext* ctx, JSValue val) {
+  if (JS_IsBool(val)) {
+    return cpp11::as_sexp(static_cast<bool>(JS_ToBool(ctx, val)));
+  }
+  if (JS_IsNumber(val)) {
+    double res;
+    JS_ToFloat64(ctx, &res, val);
+    return cpp11::as_sexp(res);
+  }
+  if (JS_IsString(val)) {
+    return cpp11::as_sexp(JS_ToCString(ctx, val));
+  }
+  return cpp11::as_sexp("Unsupported type");
+}
+
+SEXP JSValue_to_SEXP(JSContext* ctx, JSValue val) {
+  // TODO: Implement array and object conversion
+  return JSValue_to_SEXP_scalar(ctx, val);
+}
+
+} // namespace quickjsr
+
+#endif

inst/include/quickjsr/SEXP_to_JSValue.hpp

@@ -0,0 +1,66 @@
+#ifndef QUICKJSR_SEXP_TO_JSVALUE_HPP
+#define QUICKJSR_SEXP_TO_JSVALUE_HPP
+
+#include <cpp11.hpp>
+#include <quickjs-libc.h>
+
+namespace quickjsr {
+  // Forward declaration to allow for recursive calls
+  JSValue SEXP_to_JSValue(JSContext* ctx, SEXP x, bool auto_unbox);
+
+  JSValue SEXP_to_JSValue_elem(JSContext* ctx, SEXP x, int i, bool auto_unbox) {
+    switch(TYPEOF(x)) {
+      case REALSXP:
+        return JS_NewFloat64(ctx, REAL(x)[i]);
+      case INTSXP:
+        return JS_NewInt32(ctx, INTEGER(x)[i]);
+      case LGLSXP:
+        return JS_NewBool(ctx, LOGICAL(x)[i]);
+      case STRSXP:
+        return JS_NewString(ctx, CHAR(STRING_ELT(x, i)));
+      case VECSXP:
+        return SEXP_to_JSValue(ctx, VECTOR_ELT(x, i), auto_unbox);
+      default:
+        return JS_UNDEFINED;
+    }
+  }
+
+  JSValue SEXP_to_JSValue_array(JSContext* ctx, SEXP x, bool auto_unbox) {
+    JSValue arr = JS_NewArray(ctx);
+    for (int i = 0; i < Rf_length(x); i++) {
+      JSValue val = SEXP_to_JSValue_elem(ctx, x, i, auto_unbox);
+      JS_SetPropertyUint32(ctx, arr, i, val);
+    }
+    return arr;
+  }
+
+  JSValue SEXP_to_JSValue_object(JSContext* ctx, SEXP x, bool auto_unbox) {
+    JSValue obj = JS_NewObject(ctx);
+    for (int i = 0; i < Rf_length(x); i++) {
+      SEXP name = STRING_ELT(Rf_getAttrib(x, R_NamesSymbol), i);
+      JSValue val = SEXP_to_JSValue_elem(ctx, x, i, auto_unbox);
+      JS_SetPropertyStr(ctx, obj, CHAR(name), val);
+    }
+    return obj;
+  }
+
+  JSValue SEXP_to_JSValue(JSContext* ctx, SEXP x, bool auto_unbox = false) {
+    // Following jsonlite conventions:
+    //   - R list with names is an object, otherwise an array
+    if (TYPEOF(x) == VECSXP) {
+      if (Rf_getAttrib(x, R_NamesSymbol) != R_NilValue) {
+        return SEXP_to_JSValue_object(ctx, x, auto_unbox);
+      } else {
+        return SEXP_to_JSValue_array(ctx, x, auto_unbox);
+      }
+    }
+    if (Rf_length(x) == 1 && auto_unbox) {
+      return SEXP_to_JSValue_elem(ctx, x, 0, true);
+    } else {
+      return SEXP_to_JSValue_array(ctx, x, true);
+    }
+  }
+
+} // namespace quickjsr
+
+#endif

inst/tinytest/test_data_conversion.R

@@ -0,0 +1,29 @@
+# Check conversions from R types to JS types are consistent with jsonlite.
+#  - The inputs are directly converted from R to JS types using the QuickJS API.
+#  - The outputs are returned as JSON strings and parsed back to R using jsonlite.
+#  - If the conversion is consistent, the output should be the same as the input.
+expect_eq_jsonlite <- function(x) {
+  expect_equal(qjs_passthrough(x), jsonlite::fromJSON(jsonlite::toJSON(x)))
+}
+expect_eq_jsonlite(1)
+expect_eq_jsonlite(1:3)
+expect_eq_jsonlite(c(1.5, 2.5))
+
+expect_eq_jsonlite("a")
+expect_eq_jsonlite(c("a", "b", "c"))
+
+expect_eq_jsonlite(TRUE)
+expect_eq_jsonlite(FALSE)
+expect_eq_jsonlite(c(TRUE, FALSE))
+
+expect_eq_jsonlite(list(1, 2, 3))
+expect_eq_jsonlite(list(a = 1, b = 2, c = 3))
+expect_eq_jsonlite(list(a = "d", b = "e", c = "f"))
+
+expect_eq_jsonlite(list(c(1, 2), c(3, 4)))
+expect_eq_jsonlite(list(list(1, 2), list(3, 4)))
+expect_eq_jsonlite(list(list(a = 1, b = 2), list(c = 3, d = 4)))
+
+expect_eq_jsonlite(list(c("e", "f"), c("g", "h")))
+expect_eq_jsonlite(list(list("e", "f"), list("g", "h")))
+expect_eq_jsonlite(list(list(a = "e", b = "f"), list(c = "g", d = "h")))

src/Makevars

@@ -3,6 +3,12 @@ PKG_CPPFLAGS += -D_GNU_SOURCE -DCONFIG_BIGNUM
 PKG_CPPFLAGS += -DCONFIG_VERSION=\"$(shell cat quickjs/VERSION)\"
 PKG_LIBS = ../inst/lib/$(R_ARCH)/libquickjs.a
 
+ifeq ($(OS),Windows_NT)
+  DLL := .dll
+else
+	DLL := .so
+endif
+
 CC_VERSION :=  $(shell $(CC) -dumpfullversion -dumpversion 2>&1)
 CC_MAJOR := $(word 1,$(subst ., ,$(CC_VERSION)))
 
@@ -54,5 +60,5 @@ $(QUICKJS_OBJECTS): quickjs/%.o : quickjs/%.c
 	$(CC) $(ALL_CPPFLAGS) $(ALL_CFLAGS) -DSTRICT_R_HEADERS -funsigned-char -fwrapv -std=c11 -c $< -o $@
 
 clean:
-	$(RM) $(QUICKJS_OBJECTS) $(OBJECTS) ../inst/VERSION
+	$(RM) $(QUICKJS_OBJECTS) $(OBJECTS) ../inst/VERSION QuickJSR$(DLL)
 	$(RM) -r ../inst/lib ../inst/include/quickjs

src/init.cpp

@@ -10,7 +10,7 @@ extern "C" {
   SEXP qjs_validate_(SEXP ctx_ptr_, SEXP code_string_);
   SEXP qjs_call_(SEXP ctx_ptr_, SEXP function_name_, SEXP args_json_);
   SEXP qjs_eval_(SEXP eval_string_);
-  SEXP qjs_passthrough_(SEXP args_);
+  SEXP qjs_passthrough_(SEXP args_, SEXP jsonlite_rtn_);
 
 
   static const R_CallMethodDef CallEntries[] = {
@@ -19,7 +19,7 @@ extern "C" {
     {"qjs_eval_",     (DL_FUNC) &qjs_eval_,     1},
     {"qjs_source_",   (DL_FUNC) &qjs_source_,   2},
     {"qjs_validate_", (DL_FUNC) &qjs_validate_, 2},
-    {"qjs_passthrough_", (DL_FUNC) &qjs_passthrough_, 1},
+    {"qjs_passthrough_", (DL_FUNC) &qjs_passthrough_, 2},
     {NULL, NULL, 0}
   };
 

src/quickjsr.cpp

@@ -1,6 +1,7 @@
 #include <cpp11.hpp>
 #include <cpp11/declarations.hpp>
 #include <quickjs-libc.h>
+#include <quickjsr.hpp>
 
 // Register the cpp11 external pointer types with the correct cleanup/finaliser functions
 using ContextXPtr = cpp11::external_pointer<JSContext, JS_FreeContext>;
@@ -141,64 +142,7 @@ extern "C" SEXP qjs_eval_(SEXP eval_string_) {
   END_CPP11
 }
 
-JSValue SEXP_to_JSValue_scalar(JSContext* ctx, SEXP x, int i = 0) {
-  switch(TYPEOF(x)) {
-    case REALSXP:
-      return JS_NewFloat64(ctx, REAL(x)[i]);
-    case INTSXP:
-      return JS_NewInt32(ctx, INTEGER(x)[i]);
-    case LGLSXP:
-      return JS_NewBool(ctx, LOGICAL(x)[i]);
-    case STRSXP:
-      return JS_NewString(ctx, CHAR(STRING_ELT(x, i)));
-    default:
-      return JS_UNDEFINED;
-  }
-}
-
-JSValue SEXP_to_JSValue(JSContext* ctx, SEXP x) {
-  if (TYPEOF(x) == VECSXP) {
-    JSValue obj = JS_NewObject(ctx);
-    for (int i = 0; i < Rf_length(x); i++) {
-      SEXP name = STRING_ELT(Rf_getAttrib(x, R_NamesSymbol), i);
-      JSValue val = SEXP_to_JSValue(ctx, VECTOR_ELT(x, i));
-      JS_SetPropertyStr(ctx, obj, CHAR(name), val);
-    }
-    return obj;
-  }
-  if (Rf_length(x) == 1) {
-    return SEXP_to_JSValue_scalar(ctx, x);
-  } else {
-    JSValue arr = JS_NewArray(ctx);
-    for (int i = 0; i < Rf_length(x); i++) {
-      JSValue val = SEXP_to_JSValue_scalar(ctx, x, i);
-      JS_SetPropertyUint32(ctx, arr, i, val);
-    }
-    return arr;
-  }
-}
-
-SEXP JSValue_to_SEXP_scalar(JSContext* ctx, JSValue val) {
-  if (JS_IsBool(val)) {
-    return cpp11::as_sexp(static_cast<bool>(JS_ToBool(ctx, val)));
-  }
-  if (JS_IsNumber(val)) {
-    double res;
-    JS_ToFloat64(ctx, &res, val);
-    return cpp11::as_sexp(res);
-  }
-  if (JS_IsString(val)) {
-    return cpp11::as_sexp(JS_ToCString(ctx, val));
-  }
-  return cpp11::as_sexp("Unsupported type");
-}
-
-SEXP JSValue_to_SEXP(JSContext* ctx, JSValue val) {
-  // TODO: Implement array and object conversion
-  return JSValue_to_SEXP_scalar(ctx, val);
-}
-
-extern "C" SEXP qjs_passthrough_(SEXP args_) {
+extern "C" SEXP qjs_passthrough_(SEXP args_, SEXP jsonlite_rtn_) {
   BEGIN_CPP11
   JSRuntime* rt = JS_NewRuntime();
   JSContext* ctx = JS_NewContext(rt);
@@ -214,15 +158,19 @@ extern "C" SEXP qjs_passthrough_(SEXP args_) {
   std::string wrapped_name = "passthrough";
   JSValue global = JS_GetGlobalObject(ctx);
   JSValue function_wrapper = JS_GetPropertyStr(ctx, global, wrapped_name.c_str());
-  JSValue args[] = { SEXP_to_JSValue(ctx, args_) };
+  JSValue args[] = { quickjsr::SEXP_to_JSValue(ctx, args_) };
   JSValue result_js = JS_Call(ctx, function_wrapper, global, 1, args);
 
   SEXP result;
   if (JS_IsException(result_js)) {
     js_std_dump_error(ctx);
     result = cpp11::as_sexp("Error!");
   } else {
-    result = JSValue_to_SEXP(ctx, result_js);
+    if (cpp11::as_cpp<bool>(jsonlite_rtn_)) {
+      result = cpp11::as_sexp(JS_ValToJSON(ctx, &result_js));
+    } else {
+      result = quickjsr::JSValue_to_SEXP(ctx, result_js);
+    }
   }
 
   JS_FreeValue(ctx, result_js);