From cdbf155b575af91e7d33696726e185ad90436e9a Mon Sep 17 00:00:00 2001 From: Tom Elliott Date: Thu, 16 Jan 2025 12:25:56 +1300 Subject: [PATCH] ts_function method for defining ocaps --- .Rbuildignore | 1 + DESCRIPTION | 3 +- NAMESPACE | 12 ++++ R/function.R | 48 ++++++++++++---- R/types.R | 98 +++++++++++++++++++++++++++++++-- README.Rmd | 30 ++++++---- man/ts_function.Rd | 2 +- man/ts_list.Rd | 5 +- man/{object.Rd => ts_object.Rd} | 30 +++++++++- tests/testthat/test-functions.R | 49 +++++++++++++---- 10 files changed, 232 insertions(+), 46 deletions(-) rename man/{object.Rd => ts_object.Rd} (63%) diff --git a/.Rbuildignore b/.Rbuildignore index 2a2cb83..b0dba58 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -1,2 +1,3 @@ ^LICENSE\.md$ ^README\.Rmd$ +^Makefile$ diff --git a/DESCRIPTION b/DESCRIPTION index b9283ba..05098ce 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -15,4 +15,5 @@ Suggests: Config/testthat/edition: 3 Imports: cli, - js + js, + rlang diff --git a/NAMESPACE b/NAMESPACE index bda2ac1..3eb7ff1 100644 --- a/NAMESPACE +++ b/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) diff --git a/R/function.R b/R/function.R index e328d0b..8dafc57 100644 --- a/R/function.R +++ b/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) } diff --git a/R/types.R b/R/types.R index 3dd65c2..ddf9182 100644 --- a/R/types.R +++ b/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) + } + ) +} diff --git a/README.Rmd b/README.Rmd index 1e69eeb..0d8f6b6 100644 --- a/README.Rmd +++ b/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 ) ) diff --git a/man/ts_function.Rd b/man/ts_function.Rd index d36d22f..2daaba5 100644 --- a/man/ts_function.Rd +++ b/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} diff --git a/man/ts_list.Rd b/man/ts_list.Rd index c8e708d..dd6cb7a 100644 --- a/man/ts_list.Rd +++ b/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. diff --git a/man/object.Rd b/man/ts_object.Rd similarity index 63% rename from man/object.Rd rename to man/ts_object.Rd index dbb74eb..bbb2dca 100644 --- a/man/object.Rd +++ b/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 + +}} diff --git a/tests/testthat/test-functions.R b/tests/testthat/test-functions.R index 7027171..0bde1cd 100644 --- a/tests/testthat/test-functions.R +++ b/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) })