ts_function method for defining ocaps

.Rbuildignore

@@ -1,2 +1,3 @@
 ^LICENSE\.md$
 ^README\.Rmd$
+^Makefile$

DESCRIPTION

@@ -15,4 +15,5 @@ Suggests:
 Config/testthat/edition: 3
 Imports:
     cli,
-    js
+    js,
+    rlang

NAMESPACE

@@ -1,9 +1,19 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(check_type,default)
+S3method(check_type,ts_function)
+S3method(check_type,ts_object)
+S3method(get_type,default)
+S3method(get_type,ts_function)
+S3method(get_type,ts_object)
+S3method(print,ts_function)
 S3method(print,ts_object)
 S3method(ts_compile,character)
 S3method(ts_compile,default)
 S3method(ts_compile,ts_function)
+export(check_type)
+export(get_type)
+export(is_ts_object)
 export(ts_character)
 export(ts_compile)
 export(ts_dataframe)
@@ -12,4 +22,6 @@ export(ts_function)
 export(ts_integer)
 export(ts_list)
 export(ts_logical)
+export(ts_null)
 export(ts_numeric)
+export(ts_void)

R/function.R

@@ -1,6 +1,5 @@
 parse_args <- function(x, mc) {
     fmls <- lapply(x, eval)
-    mc <- mc[-1]
     if (!all(names(mc) %in% names(fmls))) {
         stop(
             "Invalid argument(s): ",
@@ -49,7 +48,7 @@ ts_result <- function(type, value) {
 #' @param ... argument definitions (only required if f does not specify these in its formals)
 #' @param result return type (ignored if overloads are provided)
 #' @export
-ts_function <- function(f, ..., result = NULL) {
+ts_function <- function(f, ..., result = ts_void()) {
     args <- list(...)
     if (!is.null(result) && !is_ts_object(result)) {
         stop("Invalid return type")
@@ -59,13 +58,42 @@ ts_function <- function(f, ..., result = NULL) {
         args <- lapply(formals(f), eval)
     }
 
-    fn <- function(...) {
-        mc <- match.call(f)
-        x <- parse_args(args, mc)
-        result$check(do.call(f, x))
+    e <- new.env()
+    e$f <- f
+    # e$env <- env
+    e$args <- args
+    e$result <- result
+
+    e$call <- function(...) {
+        mc <- match.call(e$f)
+        .args <- parse_args(args, mc[-1])
+        .res <- do.call(e$f, .args)
+        check_type(result, .res)
     }
-    attr(fn, "args") <- args
-    attr(fn, "result") <- result
-    class(fn) <- c("ts_function", class(f))
-    fn
+
+    e$copy <- function(env = parent.frame()) {
+        e2 <- e
+        environment(e2$f) <- rlang::env_clone(environment(e$f), env)
+        e2
+    }
+
+    class(e) <- "ts_function"
+    e
+}
+
+
+
+#' @export
+print.ts_function <- function(x, ...) {
+    cli::cli_h3("Ocap function")
+
+    cli::cli_text("Arguments:")
+    args <- lapply(x$args, \(z) z$input_type)
+    lapply(names(args), \(n) {
+        cat("- ", n, ": ", args[[n]], "\n", sep = "")
+    })
+    cli::cli_text("\n\n")
+
+    cli::cli_text("Return type:")
+    cat(x$result$return_type)
 }

R/types.R

@@ -36,6 +36,7 @@ print.ts_object <- function(x, ...) {
     }
     cli::cli_h3("Return type: ")
     if (nchar(x$return_type) > 50) {
+        print(x$return_type)
         cat(js::uglify_reformat(x$return_type, beautify = TRUE), "\n")
     } else {
         cat(x$return_type, "\n")
@@ -43,12 +44,74 @@ print.ts_object <- function(x, ...) {
     cli::cli_end()
 }
 
-#' @describeIn object Check if an object is a ts object
+#' @describeIn ts_object Check if an object is a ts object
 #' @export
 is_ts_object <- function(x) {
     inherits(x, "ts_object")
 }
 
+#' @describeIn ts_object Get the input type of a ts object
+#' @param x A ts object
+#' @param which Which type to get, either "input" or "return"
+#' @export
+get_type <- function(x, which = c("input", "return")) {
+    UseMethod("get_type")
+}
+
+#' @export
+get_type.ts_object <- function(x, which = c("input", "return")) {
+    which <- match.arg(which)
+    if (which == "input") {
+        return(x$input_type)
+    }
+    x$return_type
+}
+
+#' @export
+get_type.ts_function <- function(x, which = c("input", "return")) {
+    which <- match.arg(which)
+    if (which == "input") {
+        return("z.function()")
+    }
+    "Robj.ocap()"
+}
+
+#' @export
+get_type.default <- function(x, which) {
+    stop("Invalid object")
+}
+
+#' @describeIn ts_object Check if an object has the correct type
+#' @param type A ts object
+#' @param x An object
+#' @export
+check_type <- function(type, x) UseMethod("check_type")
+
+#' @export
+check_type.default <- function(type, x) {
+    stop("Invalid object")
+}
+
+#' @export
+check_type.ts_object <- function(type, x) {
+    type$check(x)
+}
+
+#' @export
+check_type.ts_function <- function(type, x) {
+    if ("ts_function" %in% class(x)) {
+        return(x)
+    }
+    if (!is.function(x)) stop("Expected a function")
+    do.call(
+        ts_function,
+        c(
+            list(x), attr(type, "args"),
+            list(result = attr(type, "result"))
+        )
+    )
+}
+
 ts_union <- function(...) sprintf("z.union([%s])", paste(..., sep = ", "))
 ts_array <- function(type = c("z.number()", "z.boolean()", "z.string()")) {
     if (type == "z.number()") {
@@ -182,8 +245,8 @@ ts_list <- function(...) {
     type <- "z.union([z.object({}), z.array(z.any())])"
     type_fn <- ""
     if (length(values)) {
-        types <- sapply(values, function(x) x$input_type)
-        type_funs <- sapply(values, function(x) x$return_type)
+        types <- sapply(values, get_type, which = "input")
+        type_funs <- sapply(values, get_type, which = "return")
         if (!is.null(names(values))) {
             type <- sprintf(
                 "{ %s }",
@@ -216,7 +279,7 @@ ts_list <- function(...) {
                     }
                 }
                 for (i in seq_along(values)) {
-                    values[[i]]$check(x[[i]])
+                    x[[i]] <- check_type(values[[i]], x[[i]])
                 }
             }
             x
@@ -236,8 +299,8 @@ ts_dataframe <- function(...) {
     type <- "z.record(z.string(), z.any())"
     type_fn <- ""
     if (length(values)) {
-        types <- sapply(values, function(x) x$input_type)
-        type_funs <- sapply(values, function(x) x$return_type)
+        types <- sapply(values, get_type, which = "input")
+        type_funs <- sapply(values, get_type, which = "return")
         if (is.null(names(values))) stop("Expected named elements")
 
         type <- sprintf(
@@ -259,3 +322,26 @@ ts_dataframe <- function(...) {
         }
     )
 }
+
+#' @export
+ts_null <- function() {
+    ts_object(
+        "z.null()",
+        "Robj.null()",
+        check = function(x) {
+            if (!is.null(x)) stop("Expected NULL")
+            x
+        }
+    )
+}
+
+#' @export
+ts_void <- function() {
+    ts_object(
+        "z.void()",
+        "null",
+        check = function(x) {
+            return(NULL)
+        }
+    )
+}

README.Rmd

@@ -36,18 +36,24 @@ Writing functions is easy, just use the `ts_*()` functions to define formals and
 
 ```r
 library(ts)
-app <- ts_list(
-  add = ts_fun(
-    function(x = ts_number(1), y = ts_number(1)) a + b,
-    ts_numeric(1)
-  ),
-  sample = ts_fun(
-    function(x, n) {
-      sample(x, n)
-    },
-    x = ts_string(),
-    n = ts_number(1),
-    result = r_character()
+addFn <- ts_function(
+  function(a = ts_numeric(1), b = ts_numeric(1)) a + b,
+  result = ts_numeric(1)
+)
+sampleFn <- ts_function(
+  function(x = ts_character(), n = ts_integer(1)) sample(x, n),
+  result = ts_character()
+)
+app <- ts_function(
+  function() {
+    list(
+      add = addFn,
+      sample = sampleFn
+    )
+  },
+  result = ts_list(
+    add = appFn,
+    sample = sampleFn
   )
 )
 

man/ts_function.Rd

@@ -4,7 +4,7 @@
 \alias{ts_function}
 \title{TS function definition}
 \usage{
-ts_function(f, ..., result = NULL)
+ts_function(f, ..., result = ts_void())
 }
 \arguments{
 \item{f}{an R function}

man/ts_list.Rd

@@ -4,7 +4,10 @@
 \alias{ts_list}
 \title{Typed list}
 \usage{
-ts_list(values = NULL)
+ts_list(...)
+}
+\arguments{
+\item{...}{A list of types, named or unnamed.}
 }
 \description{
 A list is a vector of other robjects, which may or may not be named.

man/ts_object.Rd

@@ -1,16 +1,25 @@
 % Generated by roxygen2: do not edit by hand
 % Please edit documentation in R/types.R
-\name{object}
-\alias{object}
+\name{ts_object}
+\alias{ts_object}
+\alias{is_ts_object}
+\alias{get_type}
+\alias{check_type}
 \title{Typed object}
 \usage{
-object(
+ts_object(
   input_type = "any",
   return_type = "any",
   default = NULL,
   check = function() stop("Not implemented"),
   generic = FALSE
 )
+
+is_ts_object(x)
+
+get_type(x, which = c("input", "return"))
+
+check_type(type, x)
 }
 \arguments{
 \item{input_type}{The type of the object that Typescript expect to send to R.}
@@ -22,7 +31,22 @@ object(
 \item{check}{A function that checks the object and returns it if it is valid. This operates on the R side and is mostly for development and debugging purposes. It is up to the developer to ensure that all functions return the correct type of object always.}
 
 \item{generic}{logical, if \code{TRUE} then the object is a generic type.}
+
+\item{x}{An object}
+
+\item{which}{Which type to get, either "input" or "return"}
+
+\item{type}{A ts object}
 }
 \description{
 This is the base type for all typed objects. It is not meant to be used directly.
 }
+\section{Functions}{
+\itemize{
+\item \code{is_ts_object()}: Check if an object is a ts object
+
+\item \code{get_type()}: Get the input type of a ts object
+
+\item \code{check_type()}: Check if an object has the correct type
+
+}}

tests/testthat/test-functions.R

@@ -7,8 +7,8 @@ test_that("anonomous function definitions", {
         result = ts_numeric(1)
     )
 
-    expect_equal(add(1, 2), 3)
-    expect_error(add("a", 2))
+    expect_equal(add$call(1, 2), 3)
+    expect_error(add$call("a", 2))
 })
 
 test_that("named function definitions", {
@@ -18,26 +18,51 @@ test_that("named function definitions", {
         result = ts_numeric()
     )
 
-    x <- sample_num(1:10)
+    x <- sample_num$call(1:10)
     expect_true(all(x %in% 1:10))
     expect_error(sample_num("a"))
 })
 
-test_that("function with complex return types", {
-    sampler <- ts_function(
+test_that("void return types", {
+    print_x <- ts_function(
         function(x = ts_numeric()) {
+            print(x)
+            return(NULL)
+        }
+    )
+
+    expect_output(z <- print_x$call(1:10))
+    expect_null(z)
+})
+
+test_that("function with complex return types", {
+    get_sample <- ts_function(
+        function(n = ts_numeric(1)) {
+            sample(values, n)
+        },
+        result = ts_numeric()
+    )
+
+    sampler <- ts_function(
+        function(values = ts_numeric()) {
             list(
-                get = function(n) sample(x, n)
+                get = get_sample$copy(),
+                set = ts_function(
+                    function(value = ts_numeric()) {
+                        values <<- value
+                    }
+                )
             )
         },
         result = ts_list(
-            get = ts_function(
-                NULL,
-                n = ts_integer(1),
-                result = ts_numeric(1)
-            )
+            get = get_sample,
+            set = ts_function(NULL, value = ts_numeric())
         )
     )
 
-    s <- sampler(1:10)
+    s <- sampler$call(1:10)
+    expect_type(s$get$call(2), "integer")
+
+    expect_silent(s$set$call(100:200))
+    expect_gte(s$get$call(1), 100)
 })