#!/usr/bin/Rscript

test_eval <- function(c, expr_name, expr_text) {
    expr <- c(charToRaw(expr_text), as.raw(0))
    request <- if (length(expr) <= 251) {
        c(as.raw(c(3, 0, 0, 0, length(expr)+4, 0, 0, 0,
                   0, 0, 0, 0, 0, 0, 0, 0,
                   4, length(expr), 0, 0)), expr)
    } else if (length(expr <= 65531)) {
        len <- length(expr)
        hi_len <- as.integer(len %/% 256)
        lo_len <- as.integer(len %% 256)
        c(as.raw(c(3L, 0, 0, 0, lo_len + 4L, hi_len, 0, 0,
                   0, 0, 0, 0, 0, 0, 0, 0,
                   4L, lo_len, hi_len, 0)), expr)
    } else stop('expression is too long')
    
    writeBin(request, c)

    r <- readBin(c, 'int', 4, 'little')
    stopifnot(r[1] == 65537L)

    d <- readBin(c, 'raw', r[2])

    f <- file(paste0(expr_name, '.qap'), open='wb')
    writeBin(d, con=f)

    close(f)
}

# option(warn=2)                          # exit on warnings
c <- socketConnection('localhost', 6311, open = "a+b", blocking = TRUE)
r <- readBin(c, "raw", 32)
stopifnot(grepl('^Rsrv0103QAP1', rawToChar(r)))

tests <- list(
    `empty_char` = 'character()',
    `empty_int` = 'integer()',
    `empty_num` = 'numeric()',
    `empty_cpx` = 'complex()',
    `empty_lgl` = 'logical()',
    `empty_list` = 'list()',
    `empty_raw` = 'raw()',
    `empty_sym` = 'bquote()',
    `empty_expr` = 'expression()',
    `empty_clos` = 'function() {}',
    `null` = 'NULL',
    `char_na` = 'c("foo", "", NA, 23)',
    `num_na` = 'c(11.3, NaN, -Inf, NA, 0)',
    `int_na` = 'c(11L, 0L, NA, 0L)',
    `cpx_na` = 'c(1, NA_complex_, 3i, 0)',
    `lgl_na` = 'c(TRUE, FALSE, TRUE, NA)',
    `list_na` = 'list(1, 1L, list("b", list(letters[4:7], NA, c(44.1, NA)), list()))',
    `list_null` = 'list(NULL)',
    `pairlist_untagged` = 'as.pairlist(list(1L, 2L, 3L))',
    `pairlist_tagged` = 'as.pairlist(list(foo=1L, 2L, c=3L))',
    `noatt-123l`='1:3',
    `abc-123l`='c(a=1L, b=2L, c=3L)',
    `noatt-123456`='1234.56',
    `foo-123456`='c(foo=1234.56)',
    `f-123456`='c(f=1234.56)',
    `noatt-cpx`='3+2i',
    `foo-cpx`='c(foo=3+2i)',
    `cpx-1i`='1i',
    `cpx-0i`='5+0i',
    `cpx-vector`='complex(real=1:3, imaginary=4:6)',
    `noatt-abc`='letters[1:3]',
    `ABC-abc`='c(A="a", B="b", C="c")',
    `noatt-raw`='as.raw(c(1,2,3,255, 0))',
    `noatt-list`="list(1:3, list('a', 'b', 11), 'foo')",
    `noatt-true`='TRUE',
    `noatt-tfftf`='c(T, F, F, T, F)',
    `ABCDE-tfftf`='c(A=T, B=F, C=F, D=T, E=F)',
    `foobar-list`="list(foo=1:3, list('a', 'b', 11), bar='foo')",
    `noatt-mat`='matrix(-1:4, 2, 3)',
    `ab-mat`="matrix(-1:4, 2, 3, dimnames=list(c('a', 'b')))",
    `cars`='head(cars)',
    `mtcars`='head(mtcars)',
    `iris`='head(iris)',
    `lang-lm-mpgwt`='lm(mpg ~ wt, data = head(mtcars))$call',
    `mtcars-lm-mpgwt`='lm(mpg ~ wt, data = head(mtcars))',
    `expr_null` = 'expression(NULL)',
    `expr_int` = 'expression(42L)',
    `expr_call` = 'expression(1+2)',
    `expr_many` = 'expression(u, v, 1+0:9)',
    `clos_null` = 'function() NULL',
    `clos_int` = 'function() 1L',
    `clos_add` = 'function() 1+2',
    `clos_args` = 'function(a, b) {a - b}',
    `clos_defaults` = 'function(a=3, b) {a + b * pi}',
    `clos_dots` = 'function(x=3, y, ...) {x * log(y) }',
    `baseenv` = 'baseenv()',
    `emptyenv` = 'emptyenv()',
    `globalenv` = 'globalenv()',
    `env_attr` = 'local({ e <- new.env(parent=globalenv()); attributes(e) <- list(foo = "bar", fred = 1:3); e })',
    `df_auto_rownames` = 'data.frame(a=1:3, b=c("x", "y", "z"), stringsAsFactors=FALSE)',
    `df_expl_rownames` = 'data.frame(a=1:3, b=c("x", "y", "z"), stringsAsFactors=FALSE)[1:3,]',
    `s4` = 'local({
         library(methods)
         track <- setClass("track", slots = c(x="numeric", y="numeric"))
         t1 <- track(x = 1:4, y = 2:4 + 0)
         t1
     })',
    `s4_subclass` = 'local({
         library(methods)
         track <- setClass("track", slots = c(x="numeric", y="numeric"))
         t1 <- track(x = 1:4, y = 2:4 + 0)
         trackCurve <- setClass("trackCurve", slots = c(smooth = "numeric"), contains = "track")
         t1s <- trackCurve(t1, smooth = 1:3)
         t1s
     })')

for (i in seq_along(tests)) {
    test_eval(c, names(tests)[i], tests[[i]])
}

close(c)
