Skip to content

Commit

Permalink
Merge pull request #19 from D-Se/abbreviate
Browse files Browse the repository at this point in the history
extensible abbreviations
  • Loading branch information
D-Se committed Nov 28, 2023
2 parents a86dd18 + 09e2c80 commit 68f331a
Show file tree
Hide file tree
Showing 5 changed files with 121 additions and 35 deletions.
14 changes: 7 additions & 7 deletions inst/tinytest/test_isas.R
Original file line number Diff line number Diff line change
Expand Up @@ -19,7 +19,7 @@ unit_names <- strsplit(substring(s, 6, last = nchar(s) - 1), ", ")[[1]]
units <- eval(units)

#### type checking ####
base_is <- vapply(paste0("is.", names), \(fun) {
base_is <- vapply(paste0("is.", names), function(fun) {
vapply(units, function(x) do.call(fun, list(x = x)), TRUE)
}, logical(length(units)))

Expand All @@ -41,21 +41,21 @@ for (i in seq_len(nrow(ask_is))) {

#### Type coercion ####
as_names <- paste0("as.", names)
base_as <- vapply(paste0("as.", names), \(fun) {
vapply(units, \(x) {
base_as <- vapply(paste0("as.", names), function(fun) {
vapply(units, function(x) {
tryCatch(
class(do.call(fun, list(x = x))),
warning = \(w) "warning", error = \(e) "error"
warning = function(w) "warning", error = function(e) "error"
)
}, "")
}, character(length(units)))
rownames(base_as) <- unit_names

ask_as <- vapply(abbs, \(y) {
vapply(units, \(x) {
ask_as <- vapply(abbs, function(y) {
vapply(units, function(x) {
tryCatch(
class(eval(substitute(x ?~ y, list(x = x, y = as.name(y))))),
warning = \(w) "warning", error = \(e) "error"
warning = function(w) "warning", error = function(e) "error"
)
}, "")
}, character(length(units)))
Expand Down
6 changes: 3 additions & 3 deletions man/help.Rd
Original file line number Diff line number Diff line change
Expand Up @@ -31,13 +31,13 @@ For non-logical \code{x}, short \link[methods]{as}; coerce LHS to type RHS.
}
\section{Abbreviations}{

Abbreviated type names. Note: more complex types are yet to be implemented.
Abbreviated type names. Note: coercion to complex types is not yet implemented.

\tabular{llll}{
\strong{Atomic} \tab \strong{Bunch} \tab \strong{Language} \tab \strong{Other} \cr
atm \tab rec \tab lang \tab na \cr
atm \tab rec \tab lng \tab na \cr
lgl \tab lst \tab sym \tab nan \cr
int \tab dfr \tab expr \tab nil \cr
int \tab dfr \tab exp \tab nil \cr
num \tab vec \tab call \tab fin \cr
chr \tab mtx \tab name \tab inf \cr
raw \tab arr \tab fun \tab ord \cr
Expand Down
37 changes: 37 additions & 0 deletions src/abb.h
Original file line number Diff line number Diff line change
@@ -0,0 +1,37 @@
#define ABBS \
/* atomic */ \
X(NILABB, "nil") X(INTABB, "int") X(LGLABB, "lgl") X(DBLABB, "dbl") \
X(STRABB, "str") X(CHRABB, "chr") X(CPLABB, "cpl") X(RAWABB, "raw") \
/* bunch */ \
X(LSTABB, "lst") X(DFRABB, "dfr") X(DFABB, "df") X(ENVABB, "env") \
X(VECABB, "vec") X(MTXABB, "mtx") X(ARRABB, "arr") \
X(TSABB, "ts") X(FCTABB, "fct") X(ORDABB, "ord") X(TABABB, "tab") \
/* language & programming */ \
X(SYMABB, "sym") X(LNGABB, "lng") X(CLOABB, "clo") \
X(FUNABB, "fun") X(EXPABB, "exp") X(FMLABB, "fml") \
/* supertypes */ \
X(NUMABB, "num") \
/* states & values */ \
X(INFABB, "inf") X(FINABB, "fin") \
/* object oriented */ \
X(S3ABB, "s3") X(S4ABB, "s4") X(ANYABB, "any") X(ATMABB, "atm") \
/* third-party */ \
X(TBLABB, "tbl") \

typedef enum {
#define X(a, b) a,
ABBS
#undef X
NUM_ABBS
} ABB;

#define X(a, b) { a, b },
const static struct {
const int abb;
const char *str;
} AbbCheckTable[] = {
ABBS
};
#undef X

_Static_assert(NUM_ABBS == sizeof AbbCheckTable/sizeof *AbbCheckTable, "error");
2 changes: 2 additions & 0 deletions src/ask.h
Original file line number Diff line number Diff line change
Expand Up @@ -23,8 +23,10 @@
#define err(x) Rf_errorcall(R_NilValue, x)
#define warn(x) Rf_warningcall(R_NilValue, x)

// internals
int get_threads(const int n, const bool throttle);
void init_ask_threads(void);
bool isFormula(S);

// API
S isas(S, S);
Expand Down
97 changes: 72 additions & 25 deletions src/isas.c
Original file line number Diff line number Diff line change
@@ -1,52 +1,99 @@
#include "ask.h"
#include "abb.h"

const static struct {
const char * const abb;
const int type;
}
const static struct {const char * const str; const int sexp;}
AbbCoerceTable[] = {
{"num", REALSXP}, {"chr", STRSXP}, {"int", INTSXP}, {"lgl", LGLSXP},
{"nil", NILSXP}, {"smb", SYMSXP}, {"env", ENVSXP}, {"dbl", REALSXP},
{"nil", NILSXP}, {"sym", SYMSXP}, {"env", ENVSXP}, {"dbl", REALSXP},
{"cmp", CPLXSXP}, {"any", ANYSXP}, {"exp", EXPRSXP}, {"lst", VECSXP},
{"lang", LANGSXP}, {"raw", RAWSXP}, {"s4", S4SXP}, {"name", SYMSXP},
{"lng", LANGSXP}, {"raw", RAWSXP}, {"s4", S4SXP}, {"name", SYMSXP},
{(char *)NULL, -1}
};

SEXPTYPE abb2type(S abb) {
const char *s;
s = CHAR(PRINTNAME(abb));
int i;
for (i = 0; AbbCoerceTable[i].abb; i++) {
if (!strcmp(s, AbbCoerceTable[i].abb))
return (SEXPTYPE) AbbCoerceTable[i].type;
SEXPTYPE str2sexp(S abb) {
const char *s = CHAR(PRINTNAME(abb));
for (int i = 0; AbbCoerceTable[i].str; i++) {
if (!strcmp(s, AbbCoerceTable[i].str))
return (SEXPTYPE) AbbCoerceTable[i].sexp;
}
err("Abbreviation not found"); // x ?~ bla
}

S is(S x, S fml, bool negate) {
bool res = TYPEOF(x) == abb2type(fml);
if(negate) res = !res;
return Rf_ScalarLogical(res);
}

S as(S x, S fml) {
S abb = CADR(fml);
SEXPTYPE t = TYPEOF(abb);
switch(t) {
case SYMSXP: return Rf_coerceVector(x, abb2type(abb)); // x ?~ t
case SYMSXP: return Rf_coerceVector(x, str2sexp(abb)); // x ?~ abb
default: return Rf_coerceVector(x, t); // x ?~ ""
}
}

// is

ABB str2abb(S abb) {
const char *s = CHAR(PRINTNAME(abb));
for (int i = 0; AbbCheckTable[i].str; i++) {
if (!strcmp(s, AbbCheckTable[i].str))
return (ABB) AbbCheckTable[i].abb;
}
err("Abbreviation not found"); // x ?~ bla
}
S is(S x, S fml, bool negate) {
bool ans = false;
switch(str2abb(fml)) {
// atomic
case NILABB: ans = isNull(x); break;
case INTABB: ans = isInteger(x); break;
case LGLABB: ans = isLogical(x); break;
case DBLABB: ans = isReal(x); break;
case CHRABB:
case STRABB: ans = isString(x); break;
case CPLABB: ans = isComplex(x); break;
case RAWABB: ans = TYPEOF(x) == RAWSXP; break;
// bunch
case LSTABB: {
ans = (TYPEOF(x) == VECSXP || TYPEOF(x) == LISTSXP);
// isList includes NULL, breaks on empty list()
// ans = TYPEOF(x) == LISTSXP || (LENGTH(x) == 0 && TYPEOF(x) == VECSXP);
}; break;
case DFABB :
case DFRABB: ans = isFrame(x); break;
case ENVABB: ans = isEnvironment(x); break;
case VECABB: ans = isVector(x); break;
case MTXABB: ans = isMatrix(x); break;
case ARRABB: ans = isArray(x); break;
case TSABB: ans = isTs(x); break;
case FCTABB: ans = isFactor(x); break;
case ORDABB: ans = isOrdered(x); break;
case TABABB: ans = Rf_inherits(x, "table"); break;
case NUMABB: ans = isNumber(x); break; // isNumeric omits CPLSXP
case SYMABB: ans = isSymbol(x); break;
case LNGABB: ans = isLanguage(x); break; // only LANGSXP
//case CLOABB: res = ??
case FUNABB: ans = isFunction(x); break;
case EXPABB: ans = isExpression(x); break;
case FMLABB: ans = isFormula(x); break;
case S4ABB: ans = isS4(x); break;
//case ATMABB: ans = isAtomic(x); break;
// third-party
// case TBLABB: Rf_inherits(x, "tbl"); break;
case ANYABB:
default: ans = TYPEOF(x) == str2sexp(fml);
};
if(negate) ans = !ans;
return Rf_ScalarLogical(ans);
}


S isas(S x, S fml) {
switch(TYPEOF(fml)) {
case SYMSXP: return is(x, fml, false); // x ? t
case SYMSXP: return is(x, fml, false); // x ? t
case LANGSXP: {
S fun = CAR(fml); // ?+, ?-
S fun = CAR(fml); // ?+, ?- {free}
return fun == Rf_install("!") ?
is(x, CADR(fml), true) : // x ?! t
as(x, fml); // x ?~ t
is(x, CADR(fml), true) : // x ?! t
as(x, fml); // x ?~ t
}
default: return Rf_ScalarLogical(0); // NULL ? NULL opens help, always false
}
}
}

0 comments on commit 68f331a

Please sign in to comment.