[
  {
    "path": ".Rbuildignore",
    "content": "^.*\\.Rproj$\n^\\.Rproj\\.user$\n^rename$\n^\\.gitignore$\n^README.md$\n^LICENSE$\n^tools$\n^.travis.yml$\n"
  },
  {
    "path": ".gitignore",
    "content": ".RData\n\n# History files\n.Rhistory\n\n# Example code in package build process\n*-Ex.R\n"
  },
  {
    "path": ".travis.yml",
    "content": "language: r\ncache: packages\n\nr:\n  - oldrel\n  - release\n  - devel\n\n"
  },
  {
    "path": "DESCRIPTION",
    "content": "Package: lambda.r\nType: Package\nTitle: Modeling Data with Functional Programming\nVersion: 1.2.4\nDate: 2019-09-15\nDepends: R (>= 3.0.0)\nImports: formatR\nSuggests: testit\nAuthor: Brian Lee Yung Rowe\nMaintainer: Brian Lee Yung Rowe <r@zatonovo.com>\nDescription: A language extension to efficiently write functional programs in R. Syntax extensions include multi-part function definitions, pattern matching, guard statements, built-in (optional) type safety.\nLicense: LGPL-3\nLazyLoad: yes\nURL: https://github.com/zatonovo/lambda.r\nBugReports: https://github.com/zatonovo/lambda.r/issues\n"
  },
  {
    "path": "NAMESPACE",
    "content": "importFrom(\"utils\", \"capture.output\", \"getParseData\", \"str\", \"tail\")\nimportFrom(\"formatR\", \"tidy_source\")\nexport(\"%as%\")\nexport(\"%:=%\")\nexport(\"%::%\")\nexport(\"UseFunction\")\nexport(\"NewObject\")\nexport(\"describe\")\nexport(\"EMPTY\")\nS3method(print, lambdar.fun)\nS3method(print, lambdar.type)\nexport(\"debug.lr\")\nexport(\"undebug.lr\")\nexport(\"undebug.all\")\nexport(\"is.debug\")\nexport(\"which.debug\")\nexport(\"seal\")\nexport(\"%isa%\")\nexport(\"%hasa%\")\nexport(\"%hasall%\")\n\n"
  },
  {
    "path": "R/duck.R",
    "content": "'%isa%' <- function(argument, type)\n{\n  type <- gsub('[\\'\"]','',deparse(substitute(type)))\n  type %in% class(argument)\n}\n\n# Note this will produce a vector of results\n'%hasa%' <- function(argument, property)\n{\n  property <- gsub('[\\'\"]','',deparse(substitute(property)))\n  property <- gsub(' ','', property, fixed=TRUE)\n  property <- sub('c(','', property, fixed=TRUE)\n  property <- sub(')','', property, fixed=TRUE)\n  props <- strsplit(property, ',', fixed=TRUE)[[1]]\n  props %in% names(argument)\n}\n\n'%hasall%' <- function(argument, property)\n{\n  property <- gsub('[\\'\"]','',deparse(substitute(property)))\n  property <- gsub(' ','', property, fixed=TRUE)\n  property <- sub('c(','', property, fixed=TRUE)\n  property <- sub(')','', property, fixed=TRUE)\n  props <- strsplit(property, ',', fixed=TRUE)[[1]]\n  all(props %in% names(argument))\n}\n\n\n"
  },
  {
    "path": "R/framework.R",
    "content": "EMPTY <- 'EMPTY'\n\n#' Check if name is bound to a non-lambda.r object\nis.bound <- function(name) {\n  if (! exists(name, inherits=TRUE)) return(FALSE)\n\n  o <- get(name, inherits=TRUE)\n  ! any(c('lambdar.fun','lambdar.type') %in% class(o))\n}\n\n# f(a,b) %::% A : B : C\n'%::%' <- function(signature, types) {\n  os <- options(keep.source=TRUE, keep.parse.data=TRUE)\n  s.expr <- paste(deparse(substitute(signature)), collapse=\"\\n\")\n  t.expr <- paste(deparse(substitute(types)), collapse=\"\\n\")\n  text <- paste(s.expr,t.expr, sep=\" %::% \")\n  raw <- getParseData(parse(text=text))\n  # SPECIAL tokens now appear with a leading white space\n  raw$text <- sub(\"^ \",\"\", raw$text)\n\n  it <- iterator(raw)\n  tree <- list(args=NULL)\n  args_expr <- parse_infix(raw)\n  if (is.null(args_expr)) {\n    args_expr <- parse_fun(it)\n  } else {\n    fast_forward(it, '%::%')\n  }\n  name <- args_expr$token[1]\n  if (is.bound(name))\n    stop(\"Function name is already bound to non lambda.r object\")\n\n  if (nrow(args_expr) > 1)\n    tree$args <- args_expr[2:nrow(args_expr),]\n  tree$types <- parse_types(it, tree$args, text)\n  tree$signature <- paste(s.expr,\"%::%\",t.expr, sep=' ')\n\n  add_type(name, tree)\n  options(keep.source=os$keep.source, keep.parse.data=os$keep.parse.data)\n  invisible()\n}\n\n\n# f(a,0) %when% { a < 5; a > 0 } %as% { z <- a + 2; z * 2 }\n# f(a,b) %when% { a < 0 } %as% { abs(a) + b }\n# f(a,b) %as% { a + b }\n'%as%' <- function(signature, body) {\n  os <- options(keep.source=TRUE, keep.parse.data=TRUE)\n  s.expr <- paste(deparse(substitute(signature)), collapse=\"\\n\")\n  b.expr <- paste(deparse(substitute(body)), collapse=\"\\n\")\n  text <- paste(s.expr,b.expr, sep=\" %as% \")\n  raw <- getParseData(parse(text=text))\n  # SPECIAL tokens now appear with a leading white space\n  raw$text <- sub(\"^ \",\"\", raw$text)\n  raw$text <- sub(\"%:=%\",\"%as%\", raw$text, fixed=TRUE)\n  it <- iterator(raw)\n  tree <- list(args=NULL)\n\n  args_expr <- parse_infix(raw)\n  if (is.null(args_expr)) {\n    args_expr <- parse_fun(it)\n  } else {\n    fast_forward(it, c('%as%','%when%'))\n  }\n  name <- args_expr$token[1]\n  if (is.bound(name))\n    stop(\"Function name is already bound to non lambda.r object\")\n\n  where <- get_function_env()\n  #cat(sprintf(\"Function env for %s is\\n\", name))\n  #print(where)\n  #cat(\"\\n\")\n\n  if (nrow(args_expr) > 1)\n    tree$args <- args_expr[2:nrow(args_expr),]\n  guard_expr <- parse_guard(it)\n  guard_expr <- transform_attrs(guard_expr)\n  if (!is.null(tree$args))\n    tree$guard <- guard_fn(tree$args, guard_expr, where)\n\n  body_expr <- parse_body(it)\n  body_expr <- transform_attrs(body_expr)\n  tree$def <- body_fn(tree$args, body_expr, where)\n  tree$signature <- s.expr\n  tree$body <- b.expr\n  tree$ellipsis <- idx_ellipsis(tree)\n  tree$fill.tokens <- clean_tokens(tree)\n  tree$fill.defaults <- clean_defaults(tree)\n\n  add_variant(name, tree, where)\n  options(keep.source=os$keep.source, keep.parse.data=TRUE)\n  invisible()\n}\n\n'%:=%' <- `%as%`\n\n################################## RUN TIME ###################################\n.ERR_NO_MATCH <- \"No match for function\"\n.ERR_USE_FUNCTION <- \"No valid function for\"\n.ERR_ENSURE_FAILED <- \"Assertion '%s' failed for args = %s and result = %s\"\n#NewObject <- function(type.name, ...)\nNewObject <- function(type.fn,type.name, ...)\n{\n  result <- UseFunction(type.fn,type.name, ...)\n\n  type <- gsub('\"','', type.name)\n  if (!type %in% class(result))\n    class(result) <- c(type, class(result))\n  result\n}\n\n# Some timings\n# Baseline:\n# g <- function(x) x\n# system.time(for (i in 1:10000) g(i) )\n#  user  system elapsed\n# 0.004   0.000   0.003\n#\n# S3:\n# h <- function(x, ...) UseMethod(\"h\")\n# h.default <- function(x, ...) x\n# system.time(for (i in 1:10000) h(i) )\n#  user  system elapsed\n# 0.035   0.001   0.035\n#\n# Lambda.r:\n# f(x) %as% x\n# system.time(for (i in 1:10000) { fn <- get('f', inherits=TRUE) })\n#  user  system elapsed\n# 0.017   0.000   0.018\n#\n# system.time(for (i in 1:10000) f(i) )\n#  user  system elapsed\n# 1.580   0.005   1.590\n# 0.622   0.005   0.628\n# 0.443   0.003   0.447\n# 0.407   0.000   0.408\n# 0.391   0.001   0.392\n# 0.384   0.001   0.386\n# 0.372   0.003   0.376\n# 0.347   0.001   0.347\n# 0.305   0.000   0.305\n# 0.238   0.000   0.238\nUseFunction <- function(fn,fn.name, ...)\n{\n  # If user has added more definitions, attempt to access it\n  fn <- tryCatch(get_lr(fn.name), error=function(e) fn)\n  result <- NULL\n  # u:0.007 s:0.002\n  raw.args <- list(...)\n  # u:0.305 s:0.010\n  # u:0.096 s:0.002\n  # u:0.088 s:0.004\n  # u:0.082 s:0.000\n  vs <- get_variant(fn,length(raw.args))\n  if (is.null(vs) || length(vs) < 1)\n    stop(use_error(.ERR_NO_MATCH,fn.name,raw.args))\n\n  matched.fn <- NULL\n  for (v in vs)\n  {\n    # u:1.007 s:0.006\n    # u:0.106 s:0.001\n    # u:0.068 s:0.001\n    full.args <- fill_args(raw.args, v$fill.tokens, v$fill.defaults, v$ellipsis)\n    if (is.null(full.args)) next\n    # u:0.019 s:0.003\n    full.type <- get_type(fn,v$type.index)\n    if (!check_types(full.type, full.args)) next\n    if (is.null(v$guard)) { matched.fn <- v$def; break }\n    gout <- do.call(v$guard, full.args)\n    if (!is.na(gout) && length(gout) > 0 && gout) { matched.fn <- v$def; break }\n  }\n  if (is.null(matched.fn))\n    stop(use_error(.ERR_USE_FUNCTION,fn.name,raw.args))\n\n  result <- do.call(matched.fn, full.args)\n\n  if (!is.null(full.type))\n  {\n    result.class <- class(result)\n    return.type <- return_type(full.type, full.args, result.class)[1]\n    if ('integer' %in% result.class) result.class <- c(result.class, 'numeric')\n\n    if (return.type == '.') {\n      NULL\n    } else if (return.type == '.lambda.r_UNIQUE') {\n      act <- paste(result.class, collapse=', ')\n      first <- result.class[1]\n      if (first %in% sapply(raw.args, class)) {\n        msg <- sprintf(\"Expected unique return type but found '%s' for\",first)\n        stop(use_error(msg,fn.name,raw.args))\n      }\n    } else if (!return.type %in% result.class) {\n      exp <- return.type\n      act <- paste(result.class, collapse=', ')\n      msg <- sprintf(\"Expected '%s' as return type but found '%s' for\",exp,act)\n      stop(use_error(msg,fn.name,raw.args))\n    }\n  }\n\n  result\n}\n\n\nidx_ellipsis <- function(tree) {\n  which(tree$args$token == '...')\n}\n\nclean_tokens <- function(tree) {\n  if (length(tree$ellipsis) == 0)\n    tree$args$token\n  else\n    tree$args$token[-tree$ellipsis]\n}\n\nclean_defaults <- function(tree) {\n  if (length(tree$ellipsis) == 0)\n    tree$args$default\n  else\n    tree$args$default[-tree$ellipsis]\n}\n\n# rm(list=ls()); detach('package:lambda.r', unload=TRUE); library(lambda.r)\nfill_args <- function(params, tokens, defaults, idx.ellipsis)\n{\n  args <- list()\n  if (is.null(params) && all(is.na(defaults))) return(args)\n\n  # Skip parameters that don't coincide with the expected tokens\n  param.names <- names(params)\n  if (!is.null(param.names) &&\n      !all(param.names[nchar(param.names) > 0] %in% tokens) && \n      length(idx.ellipsis) == 0) return(NULL)\n\n  # Initialize arguments with NA\n  arg.length <- max(length(tokens), length(defaults)) + length(idx.ellipsis)\n  if (arg.length == 0) return(args)\n\n  idx.concrete <- idx.args <- 1:arg.length\n  if (length(idx.ellipsis) > 0)\n    idx.concrete <- idx.args[-idx.ellipsis]\n  names(idx.concrete) <- tokens\n  args[idx.args] <- NA\n  names(args)[idx.concrete] <- tokens\n\n  # Populate named arguments\n  named.params <- param.names[param.names %in% tokens]\n  args[named.params] <- params[named.params]\n\n  # Catalog named and unnamed arguments\n  if (length(params) > 0) {\n    idx.params <- 1:length(params)\n    names(idx.params) <- names(params)\n    if (is.null(named.params) || length(named.params) < 1) {\n      idx.p.named <- integer()\n      idx.p.unnamed <- idx.params\n      idx.a.named <- integer()\n      idx.a.unnamed <- idx.concrete\n    } else {\n      idx.p.named <- idx.params[named.params]\n      idx.p.unnamed <- idx.params[-idx.p.named]\n      idx.a.named <- idx.concrete[named.params]\n      idx.a.unnamed <- idx.concrete[-idx.a.named]\n    }\n\n    if (length(idx.ellipsis) > 0) {\n      # Choose only required arguments\n      idx.required <- idx.concrete[is.na(defaults)]\n      idx.required <- idx.required[!idx.required %in% idx.a.named]\n\n      # Set arguments before ellipsis\n      idx.left <- idx.required[idx.required < idx.ellipsis]\n      args[idx.left] <- params[idx.p.unnamed[1:length(idx.left)]]\n\n      idx.right <- idx.required[idx.required > idx.ellipsis]\n      args[idx.right] <- params[tail(idx.p.unnamed, length(idx.right))]\n\n      # Fill the ellipsis with the remainder\n      orphans <- c(idx.p.named, idx.left, idx.right)\n      if (length(orphans) == 0) {\n        args[[idx.ellipsis]] <- params\n      } else {\n        args[[idx.ellipsis]] <- params[-orphans]\n      }\n    } else if (length(idx.p.unnamed) > 0) {\n        args[idx.a.unnamed[1:length(idx.p.unnamed)]] <- params[idx.p.unnamed]\n    }\n  }\n\n  # Apply default values to unset optional arguments\n  if (!is.null(defaults)) {\n    idx.optional <- idx.concrete[is.na(args[idx.concrete]) & !is.na(defaults)]\n    if (length(idx.ellipsis) > 0) {\n      idx.defaults <- ifelse(idx.optional >= idx.ellipsis,\n        idx.optional - 1,\n        idx.optional)\n    } else {\n      idx.defaults <- idx.optional\n    }\n    args[idx.optional] <- lapply(idx.defaults, \n      function(idx) eval(parse(text=defaults[idx]), list2env(args)))\n  }\n\n  if (length(idx.ellipsis) > 0) {\n    names(args)[idx.ellipsis] <- ''\n    #args <- c(args[-idx.ellipsis],unlist(args[idx.ellipsis], recursive=FALSE))\n    args <- c(args[idx.args < idx.ellipsis],\n      unlist(args[idx.ellipsis], recursive = FALSE),\n      args[idx.args > idx.ellipsis])\n  }\n  args\n}\n\n\n# Return the index of the ellipsis argument or an empty vector otherwise\nhas_ellipsis <- function(declared.types) {\n  idx <- 1:length(declared.types)\n  val <- sapply(declared.types, \n    function(x) any(grep('...', x, fixed=TRUE) > 0))\n  idx[val]\n}\n\nupdate_type_map <- function(type.map, the.type, arg.type) {\n  if (is.null(type.map[[the.type]])) {\n    if (any(arg.type %in% type.map))\n      # This forces a failure in the type check later on\n      type.map[[the.type]] <- paste(\"!\",arg.type,sep='')\n    else\n      # Add the new type if it doesn't exist\n      type.map[[the.type]] <- arg.type\n  }\n  type.map\n}\n\nstrip_ellipsis <- function(the.type) {\n  sub('...','',the.type, fixed=TRUE)\n}\n\n# Used internally to determine the declared type based on its\n# value and corresponding argument type.\ndereference_type <- function(declared.types, arg.types) {\n  type.map <- list()\n  len.delta <- length(arg.types) - length(declared.types) + 1\n\n  # Check for type variables (can only be a-z)\n  fn <- function(x) {\n    the.type <- declared.types[[x]]\n    if (the.type == '.')\n      return(arg.types[[x]])\n    else if (the.type == '...') \n      return(arg.types[x + 0:len.delta])\n    else if (the.type %in% letters) {\n      type.map <<- update_type_map(type.map, the.type, arg.types[[x]])\n      return(type.map[[the.type]])\n    }\n    else if (any(grep('[a-z]\\\\.\\\\.\\\\.', the.type) > 0)) {\n      the.type <- strip_ellipsis(the.type)\n      type.map <<- update_type_map(type.map, the.type, arg.types[[x]])\n      return(rep(type.map[[the.type]], len.delta + 1))\n    }\n    else if (any(grep('[a-zA-Z0-9._]+\\\\.\\\\.\\\\.', the.type) > 0)) {\n      the.type <- strip_ellipsis(the.type)\n      return(rep(the.type, len.delta + 1))\n    }\n    # Default\n    the.type\n  }\n}\n\n\n# Validate arguments against types\ncheck_types <- function(raw.types, raw.args)\n{\n  if (is.null(raw.types)) return(TRUE)\n  declared.types <- raw.types$types$text\n  idx.ellipsis <- has_ellipsis(declared.types)\n  if (length(idx.ellipsis) == 0 &&\n      nrow(raw.types$types) - 1 != length(raw.args)) return(FALSE)\n\n  arg.fn <- function(x) {\n    cl <- class(x)\n    if ('integer' %in% cl) cl <- c(cl, 'numeric')\n    cl\n  }\n  arg.types <- lapply(raw.args, arg.fn)\n\n  fn <- dereference_type(declared.types, arg.types)\n  declared.types <- lapply(1:(length(declared.types)-1), fn)\n  if (length(idx.ellipsis) > 0) {\n    idx.declared <- 1:length(declared.types)\n    declared.types <- c(\n      declared.types[idx.declared[idx.declared < idx.ellipsis]],\n      unlist(declared.types[idx.ellipsis], recursive=FALSE),\n      declared.types[idx.declared[idx.declared > idx.ellipsis]]\n    )\n  }\n\n  idx <- 1:length(raw.args)\n  all(sapply(idx, function(x) any(declared.types[[x]] %in% arg.types[[x]])))\n}\n\n\n\n# Get the return type of a function declaration. This is aware of type\n# variables.\n# TODO: Make this more efficient using information computed\n# by check_types.\nreturn_type <- function(raw.types, raw.args, result.class)\n{\n  declared.types <- raw.types$types$text\n  if (! has_ellipsis(declared.types) &&\n      nrow(raw.types$types) - 1 != length(raw.args)) return(MissingReturnType)\n\n  arg.types <- lapply(raw.args, function(x) class(x))\n\n  # Check for type variables (can only be a-z)\n  ret.type <- declared.types[length(declared.types)]\n  if (ret.type %in% letters) {\n    fn <- dereference_type(declared.types, c(arg.types,result.class))\n    sapply(1:(length(declared.types)-1), fn)\n    ret.type <- fn(length(declared.types))\n    if (is.null(ret.type)) ret.type <- \".lambda.r_UNIQUE\"\n  }\n  # Use Function as a proxy for function\n  gsub('\\\\bFunction\\\\b','function',ret.type, perl=TRUE)\n}\n\n.SIMPLE_TYPES <- c('numeric','character','POSIXt','POSIXct','Date')\n.is.simple <- function(x) any(class(x) %in% .SIMPLE_TYPES)\nas_simple <- function(x)\n{\n  if (! .is.simple(x)) return(class(x)[1])\n  if (length(x) == 1) return(x)\n  if (length(x) < 5) sprintf(\"c(%s)\", paste(x, collapse=','))\n  else sprintf(\"c(%s, ...)\", paste(x[1:4], collapse=','))\n}\n\nuse_error <- function(msg, fn.name, raw.args)\n{\n  args <- paste(sapply(raw.args, as_simple), collapse=',')\n  signature <- sprintf(\"'%s(%s)'\", fn.name, args)\n  sprintf(\"%s %s\", msg, signature)\n}\n\n################################# PARSE TIME #################################\niterator <- function(tree)\n{\n  if (!is.null(tree)) tree <- tree[! (tree$token=='expr' & tree$text==''),]\n  cap <- nrow(tree) + 1\n  idx <- 0\n  function(rewind=FALSE, dump=FALSE)\n  {\n    if (dump) return(tree[idx:nrow(tree),])\n    if (rewind) idx <<- idx - 1\n    else idx <<- idx + 1\n    if (idx < cap) tree[idx,]\n    else NULL\n  }\n}\n\nget_name <- function(it) {\n  line <- it()\n  if (line$token != 'SYMBOL_FUNCTION_CALL')\n    stop(\"Function must start with a symbol (instead of \",line$token,\")\")\n  line$text\n}\n\nfast_forward <- function(it, what) {\n  while (!is.null(line <- it()) && ! line$text %in% what) { }\n  it(rewind=TRUE)\n}\n\nparse_infix <- function(raw) {\n  raw <- raw[raw$token != 'expr' & raw$terminal,]\n  raw <- raw[1:nrow(raw) < which(raw$text %in% c('%as%','%::%','%when%'))[1],]\n  if (! identical(raw$token, c('SYMBOL','SPECIAL','SYMBOL'))) return(NULL)\n\n  fn.name <- raw$text[raw$token=='SPECIAL']\n  arg.name <- raw$text[raw$token=='SYMBOL']\n  data.frame(paren.level=c(0,1,1), \n    node=c('function.name','argument','argument'),\n    token=c(fn.name,arg.name),\n    pattern=NA, default=NA, stringsAsFactors=FALSE)\n}\n\n# parse_fun(raw=parser(text=\"fib(0,y=some.fun(1)) %as% 1\"))\n# parse_fun(raw=parser(text=\"fib(x,y=some.fun(1), 'bgfs') %as% 1\"))\nparse_fun <- function(it, raw=NULL) {\n  if (!is.null(raw)) { it <- iterator(raw) }\n  name <- get_name(it)\n  paren.level <- 0\n  node <- 'function.name'\n  out <- data.frame(paren.level=paren.level, node=node, token=name,\n    pattern=NA, default=NA, stringsAsFactors=FALSE)\n\n  arg.idx <- 1\n  node <- 'argument'\n  token <- pattern <- default <- NULL\n  in.default <- FALSE\n  while (!is.null(line <- it()) && line$token != \"SPECIAL\")\n  {\n    line.token <- line$token\n    if (line.token == 'expr') next\n    if (line.token == \"'('\") \n    {\n      paren.level <- paren.level + 1\n      if (paren.level == 1) next # Opening function parenthesis\n    }\n    if (line.token == \"')'\")\n    {\n      paren.level <- paren.level - 1\n      if (paren.level < 1) # Closing function parenthesis\n      {\n        # Check for 0 argument function\n        if (is.null(token) && is.null(pattern)) break\n        # Otherwise...\n        if (!is.null(token) && token == EMPTY) {\n          token <- NULL\n          pattern <- EMPTY\n        }\n        if (is.null(token)) token <- paste('.lambda',arg.idx,sep='_')\n        if (is.null(pattern)) pattern <- NA\n        #else pattern <- strip_quotes(paste(pattern, collapse=' '))\n        else pattern <- paste(pattern, collapse=' ')\n        if (is.null(default)) default <- NA\n        #else default <- strip_quotes(paste(default, collapse=' '))\n        else default <- paste(default, collapse=' ')\n        out <- rbind(out, c(1,node,token,pattern,default))\n        break\n      }\n    }\n\n    #cat(\"paren.level:\",paren.level,\"\\n\")\n    if (paren.level == 1) \n    {\n      if (!in.default && line.token %in% c('SYMBOL','SYMBOL_SUB','SYMBOL_FUNCTION_CALL'))\n      {\n        token <- line$text\n        next\n      }\n      if (line.token == 'EQ_SUB')\n      {\n        in.default <- TRUE\n        next\n      }\n      # Close current node\n      if (line.token == \"','\")\n      {\n        if (!is.null(token) && token == EMPTY) {\n          token <- NULL\n          pattern <- EMPTY\n        }\n        if (is.null(token)) token <- paste('.lambda',arg.idx,sep='_')\n        if (is.null(pattern)) pattern <- NA\n        #else pattern <- strip_quotes(paste(pattern, collapse=' '))\n        else pattern <- paste(pattern, collapse=' ')\n        if (is.null(default)) default <- NA\n        #else default <- strip_quotes(paste(default, collapse=' '))\n        else default <- paste(default, collapse=' ')\n\n        out <- rbind(out, c(paren.level,node,token,pattern,default))\n        token <- pattern <- default <- NULL\n        node <- 'argument'\n        arg.idx <- arg.idx + 1\n        in.default <- FALSE\n        next\n      }\n\n      # TODO: Current structure will fail if a default uses a function call\n      # with multiple arguments (due to the comma)\n      if (in.default) {\n        default <- c(default, line$text)\n        #cat(\"Adding to default value:\",line$text,\"\\n\")\n      } else\n        pattern <- c(pattern, line$text)\n    }\n    else \n    {\n      default <- c(default, line$text)\n      #cat(\"Default is now\",default,\"\\n\")\n    }\n  }\n  out\n}\n\nstrip_quotes <- function(x) sub('^[\\'\"]([^\\'\"]+)[\\'\"]$', '\\\\1', x)\n\n\nparse_guard <- function(it)\n{\n  guards <- NULL\n  while (!is.null(line <- it()) && line$token != \"SPECIAL\") next\n  if (line$text == '%when%')\n  {\n    line <- it()\n    if (line$token != \"'{'\")\n      stop(\"Guard missing opening block\")\n    while (!is.null(line <- it()) && line$token != \"'}'\")\n    {\n      if (line$token %in% c(\"'{'\"))\n        stop(\"Invalid symbol '\",line$text,\"'in function definition\")\n      #if (line$token %in% c('expr',\"','\")) next\n      if (line$token %in% c('expr')) next\n      guards <- rbind(guards, line)\n    }\n    #while (!is.null(line <- it()) && line$token != \"SPECIAL\") next\n  }\n  else\n    it(rewind=TRUE)\n  guards[,c('line1','token','text')]\n}\n\nguard_fn <- function(raw.args, tree, where)\n{\n  lines <- NULL\n  # Add any pattern matches\n  if (any(!is.na(raw.args$pattern)))\n  {\n    patterns <- raw.args[!is.na(raw.args$pattern),]\n    f <- function(x) {\n      if (patterns$pattern[x] == 'NULL')\n        paste(\"is.null(\", patterns$token[x],\")\", sep='')\n      else if (patterns$pattern[x] == 'NA')\n        paste(\"is.na(\", patterns$token[x],\")\", sep='')\n      else if (patterns$pattern[x] == 'EMPTY')\n        paste(\"length(\", patterns$token[x],\") == 0 || \",\n          \"(!is.null(dim(\",patterns$token[x],\")) && \",\n          \"nrow(\",patterns$token[x],\") == 0)\" , sep='')\n      else \n        paste(patterns$token[x],'==',patterns$pattern[x], sep=' ')\n    }\n    lines <- sapply(1:nrow(patterns), f)\n  }\n\n  # Add explicit guards\n  if (!is.null(tree))\n  {\n    f <- function(x) paste(tree[tree$line1 %in% x,]$text, collapse=' ')\n    index <- array(unique(tree$line1))\n    lines <- c(lines,apply(index,1,f))\n  }\n\n  if (length(lines) < 1) return(NULL)\n\n  body <- paste(lines, collapse=' & ')\n  arg.string <- paste(raw.args$token, collapse=',')\n  fn.string <- sprintf(\"function(%s) { %s }\", arg.string, body)\n  eval(parse(text=fn.string), where)\n}\n\n# A parse transform to change object@attribute to attr(object,'attribute')\n# f(x) %when% { x@name == \"bob\" } %as% x\ntransform_attrs <- function(tree)\n{\n  start <- grep(\"'@'\", tree$token, value=FALSE) - 1\n  #stop <- grep(\"SLOT\", tree$token, value=FALSE)\n  stop <- start + 2\n  if (length(start) < 1) return(tree)\n\n  template <- data.frame(line1=0,\n    token=c('SYMBOL_FUNCTION_CALL',\"'('\",'SYMBOL',\"','\",'STR_CONST',\"')'\"),\n    text=c('attr','(', 'object', ',', '\"key\"',')'),\n    stringsAsFactors=FALSE)\n  rep.fn <- function(idx,o,k)\n  {\n    template$line1 <- idx\n    template$text[3] <- o\n    template$text[5] <- paste('\"',k,'\"', sep='')\n    template\n  }\n\n  positions <- data.frame(cbind(start,stop), stringsAsFactors=FALSE)\n  cut.fn <- function(idx)\n  {\n    ls <- NULL\n    # Grab lines preceding transform\n    if (idx == 1) inf <- 1\n    else inf <- positions$stop[idx - 1] + 1\n    sup <- positions$start[idx] - 1\n    if (inf < positions$start[idx] && sup >= inf)\n      ls <- rbind(ls, tree[inf:sup,])\n\n    i <- tree[positions$start[idx],]$line1\n    o <- tree[positions$start[idx],]$text\n    k <- tree[positions$stop[idx],]$text\n    ls <- rbind(ls, rep.fn(i,o,k))\n\n    if (idx == nrow(positions)) {\n      ls <- rbind(ls, tree[(positions$stop[idx] + 1) : nrow(tree),] )\n    }\n    ls\n  }\n  lines <- lapply(1:nrow(positions), cut.fn)\n  do.call(rbind, lines)\n}\n\nis.type <- function(fn.string) { grepl('^[A-Z]', fn.string) }\n\nis.infix <- function(fn.string) { grepl('^%[^%]+%$', fn.string) }\n\n\nparse_body <- function(it)\n{\n  body <- NULL\n  # Skip until we get to the \n  while (!is.null(line <- it()) && line$token != \"SPECIAL\") next\n  if (line$text == '%as%')\n  {\n    needs.wrapping <- FALSE\n    while (!is.null(line <- it()) && TRUE)\n    {\n      if (line$token %in% c('expr')) next\n      body <- rbind(body, line)\n    }\n  }\n  else\n    it(rewind=TRUE)\n  body[,c('line1','token','text')]\n}\n\n\nbody_fn <- function(raw.args, tree, where)\n{\n  if (tree$token[1] == \"'{'\") tree <- tree[2:(nrow(tree)-1), ]\n  lines <- NULL\n\n  if (!is.null(tree))\n  {\n    f <- function(x) paste(tree[tree$line1 %in% x,]$text, collapse=' ')\n    index <- unique(tree$line1)\n    lines <- lapply(index,f)\n  }\n\n  if (length(lines) < 1) return(NULL)\n\n  body <- paste(lines, collapse='\\n')\n  if (is.null(raw.args))\n    arg.string <- ''\n  else\n    arg.string <- paste(raw.args$token, collapse=',')\n  fn.string <- tidy_source(\n    text=sprintf(\"function(%s) { %s }\", arg.string, body),\n    indent=2, output=FALSE)\n  eval(parse(text=fn.string), where)\n}\n\nparse_types <- function(it, args, sig)\n{\n  types <- NULL\n  while (!is.null(line <- it()) && line$token != \"SPECIAL\") next\n  if (line$text == '%::%')\n  {\n    while (!is.null(line <- it()) && TRUE)\n    {\n      if (line$token %in% c(\"'{'\", \"'}'\", \"'('\", \"')'\"))\n        stop(\"Invalid symbol '\",line$text,\"'in definition of \",sig)\n      if (line$token != \"SYMBOL\") next\n      types <- rbind(types, line)\n    }\n  }\n  if (is.null(args)) {\n    if (nrow(types) != 1)\n      stop(\"Incorrect number of parameters in type declaration for \",sig)\n  } else {\n    if (nrow(args) != nrow(types) - 1)\n      stop(\"Incorrect number of parameters in type declaration for \",sig)\n  }\n\n  types[,c('line1','token','text')]\n}\n\nfrom_root_env <- function(frames)\n{\n  length(frames) < 3\n}\n\nadd_variant <- function(fn.name, tree, where)\n{\n  #cat(\"NOTE: Environment for\",fn.name,\"is\\n\", sep=' ')\n  #print(sprintf(\"NOTE: Environment for %s is\",fn.name))\n  #print(where)\n  env <- capture.output(str(as.environment(where), give.attr=FALSE))\n  if (! is.null(tree$def)) {\n    attr(tree$def,'topenv') <- env\n    attr(tree$def,'name') <- fn.name\n  } else {\n    cat(\"NOTE: Empty body definition encountered for\",tree$signature,\"\\n\")\n  }\n\n  setup_parent(fn.name, where)\n  fn <- get(fn.name, where)\n  #cat(sprintf(\"The parent.env(%s) is\\n\", fn.name))\n  #print(parent.env(environment(fn)))\n  #cat(\"\\n\")\n\n  variants <- attr(fn,'variants')\n  active.type <- attr(fn,'active.type')\n  args <- NULL\n\n  if (is.null(tree$args))\n    tree$accepts <- c(0,0)\n  else {\n    args <- tree$args\n    required.args <- length(args$default[is.na(args$default)])\n    if ('...' %in% tree$args$token)\n      tree$accepts <- c(required.args-1, Inf)\n      #tree$accepts <- c(required.args : nrow(args) - 1, Inf)\n    else\n      tree$accepts <- c(required.args, nrow(args))\n    type.index <- get_type_index(fn, nrow(args), active.type)\n    if (!is.null(type.index) && length(type.index) > 0)\n      tree$type.index <- type.index\n  }\n\n  # Replace existing function clauses if there is a signature match\n  idx <- has_variant(variants, args, tree$guard, active.type)\n  if (length(idx) > 0) variants[[idx]] <- tree\n  else variants[[length(variants) + 1]] <- tree\n  attr(fn,'variants') <- variants\n\n  assign(fn.name, fn, where)\n  #if (! from_root_env(frames)) attach(where, name='lambda.r_temp_env')\n  .sync_debug(fn.name)\n  invisible()\n}\n\nget_variant <- function(fn, arg.length)\n{\n  # u:0.007 s:0.000\n  raw <- attr(fn,'variants')\n  len <- length(raw)\n  matches <- vector(length=len)\n  for (j in 1:len) {\n    accepts <- raw[[j]]$accepts\n    matches[j] <- arg.length >= accepts[1] && arg.length <= accepts[2]\n  }\n  raw[matches]\n}\n\n# Check whether this function already has the given variant\nhas_variant <- function(variants, args, guard=NULL, active.type=NULL)\n{\n  if (length(variants) == 0) return(variants)\n\n  keys <- colnames(args)[! colnames(args) %in% 'default']\n  fn <- function(x) {\n    v <- variants[[x]]\n    if (!is.null(v$type.index) && !is.null(active.type) && v$type.index != active.type) return(NA)\n    var.len <- ifelse(is.null(v$args), 0, nrow(v$args))\n    arg.len <- ifelse(is.null(args), 0, nrow(args))\n    if (var.len != arg.len) return(NA)\n    if (var.len == 0) return (x)\n\n    if (!is.null(v$guard) || !is.null(guard)) {\n      if (!is.null(v$guard) && is.null(guard)) return(NA)\n      if (is.null(v$guard) && !is.null(guard)) return(NA)\n      dv <- deparse(v$guard)\n      dg <- deparse(guard)\n      if (length(dv) != length(dg)) return(NA)\n      if (!all(deparse(v$guard) == deparse(guard))) return(NA)\n    }\n\n    args$pattern[is.na(args$pattern)] <- \".lambdar_NA\" \n    v$args$pattern[is.na(v$args$pattern)] <- \".lambdar_NA\"\n    ifelse(all(v$args[,keys] == args[,keys]),x, NA)\n  }\n  out <- sapply(1:length(variants), fn)\n  out[!is.na(out)]\n}\n\n# Adds type constraint to function\n# If an existing type constraint is encountered, then the active.type index\n# will be set to this type constraint. This has the same effect as adding a\n# new constraint.\nadd_type <- function(fn.name, tree)\n{\n  frames <- sys.frames()\n  if (length(frames) < 3)\n    where <- topenv(parent.frame(2))\n  else\n    where <- target_env(sys.calls()[[length(frames)-2]], length(frames))\n\n  setup_parent(fn.name, where)\n  fn <- get(fn.name, where)\n  types <- attr(fn,'types')\n\n  if (is.null(tree$args))\n    tree$accepts <- c(0,0)\n  else {\n    args <- tree$args\n    tree$accepts <- c(length(args$default[is.na(args$default)]), nrow(args))\n  }\n  f <- function(x) {\n    ifelse(types[[x]]$signature == tree$signature, x, NA)\n  }\n  if (length(types) > 0)\n  {\n    out <- sapply(1:length(types), f)\n  }\n  else\n    out <- NA\n  out <- out[!is.na(out)]\n  idx <- ifelse(length(out) == 0, length(types) + 1, out[1])\n  types[[idx]] <- tree\n  attr(fn,'types') <- types\n  attr(fn,'active.type') <- idx\n\n  assign(fn.name, fn, where)\n  invisible()\n}\n\n# Type declarations are scoped based on when they are created. They continue\n# until a new type declaration is added.\nget_type <- function(fn, idx)\n{\n  if (is.null(idx)) return(NULL)\n  raw <- attr(fn,'types')\n  if (length(raw) < 1) return(NULL)\n  match <- raw[[idx]]\n  # Use Function as a proxy for function\n  char.type <- match$types$text\n  match$types$text <- gsub('\\\\bFunction\\\\b','function',char.type, perl=TRUE)\n  match\n}\n\n# Get the index for the most recent type declaration for the given arg.length\nget_type_index <- function(fn, arg.length, active.type)\n{\n  raw <- attr(fn,'types')\n  if (length(raw) < 1) return(NULL)\n  if (!is.null(active.type) &&\n      !is.null(raw[[active.type]]$args) &&\n      nrow(raw[[active.type]]$args) == arg.length) return(active.type)\n  \n  match.fn <- function(x)\n    any(arg.length >= raw[[x]]$accepts & arg.length <= raw[[x]]$accepts)\n  matches <- data.frame(idx=(1:length(raw)), v=sapply(1:length(raw), match.fn))\n  if (!all(matches$v)) return(NULL)\n  max(matches$idx[matches$v==TRUE])\n}\n\nsetup_parent <- function(parent, where)\n{\n  # Overwrite a final definition (as opposed to appending)\n  if (exists(parent, where))\n  {\n    parent.def <- get(parent, where)\n    is.final <- attr(parent.def, 'sealed')\n    if ((!is.null(is.final) && is.final == TRUE) ||\n        (! any(c('lambdar.fun','lambdar.type') %in% class(parent.def))) )\n    {\n      parent.def <- init_function(parent, where)\n      assign(parent, parent.def, where)\n    }\n  }\n  else\n  {\n    parent.def <- init_function(parent, where)\n    assign(parent, parent.def, where)\n  }\n}\n\ninit_function <- function(name, where)\n{\n  if (is.type(name)) {\n    pattern <- 'function(...) NewObject(%s,\"%s\",...)'\n  } else if (is.infix(name)) {\n    pattern <- 'function(...) UseFunction(`%s`,\"%s\",...)'\n  } else {\n    pattern <- 'function(...) UseFunction(%s,\"%s\",...)'\n  }\n\n  fn <- eval(parse(text=sprintf(pattern,name,name)), where)\n  if (is.type(name))\n    attr(fn, 'class') <- c('lambdar.type', 'function')\n  else\n    attr(fn, 'class') <- c('lambdar.fun', 'function')\n  attr(fn, 'variants') <- list()\n  attr(fn, 'types') <- list()\n  #print(sprintf(\"Parent.env(%s) is\", name))\n  #print(parent.env(environment(fn)))\n  fn\n}\n\n\n# Check if the same signature already exists in the function. If so return the\n# index of the existing definition\n# Types do not require default values specified in the signature, so we don't\n# check for that\n# With guards, there could be multiple matches, so each match will get a type\n# added\n# For adding types, we want to match all applicable\n# INCOMPLETE - Requires examining guards as well\nsignature_idx <- function(tree, variants)\n{\n  if (length(variants) < 1) return(NULL)\n  args <- tree$args\n  fn <- function(idx)\n  {\n    vargs <- variants[[idx]]$args\n    if (nrow(args) != nrow(vargs)) return(NULL)\n    if (length(args$pattern[is.na(args$pattern)]) !=\n        length(vargs$pattern[is.na(vargs$pattern)]) ) return(NULL)\n    if (!all(args$token == vargs$token))\n      stop(\"Mismatched argument names found\")\n    idx\n  }\n  temp <- sapply(array(1:length(variants)), fn)\n  do.call(c, temp)\n}\n\nseal <- function(fn)\n{\n  fn.name <- deparse(substitute(fn))\n  attr(fn,'sealed') <- TRUE\n  assign(fn.name, fn, inherits=TRUE)\n  invisible()\n}\n\n# This is a fall back for special cases. It is clearly not efficient but is\n# necessary for unit testing frameworks that manipulate the normal environment\n# structures\n# Returns the index of the most recent frame that contains the variable\n# UNUSED\nreally_get <- function(x)\n{\n  frames <- sys.frames()\n  match.idx <- sapply(frames, function(y) x %in% ls(y))\n  frame.idx <- (1:length(frames))[match.idx]\n  if (length(frame.idx) < 1) stop(\"Still couldn't find \",x,\"\\n\")\n  get(x, frames[frame.idx[length(frame.idx)]])\n}\n\nget_function_env <- function() {\n  frames <- sys.frames()\n\n  if (from_root_env(frames)) {\n    #print(\"Assuming in root environment\")\n    where <- topenv(parent.frame(2))\n  } else {\n    #print(\"Getting target environment from call stack\")\n    #if ('lambda.r_temp_env' %in% search())\n    #  detach('lambda.r_temp_env', character.only=TRUE)\n    my.call <- sys.calls()[[length(frames)-2]]\n    where <- target_env(my.call, length(frames))\n  }\n  where\n}\n\n\n# Get the target env for the function definition. Normally this would be\n# just traversing the frame stack, but we need to add special logic to\n# handle eval() calls with an explicit environment.\ntarget_env <- function(head.call, frame.length)\n{\n  parsed.call <- getParseData(parse(text=deparse(head.call)))\n  it <- iterator(parsed.call)\n  args <- parse_eval(it)\n\n  # 3 is a magic number based on the lambda.r call stack to this function\n  stack.depth <- 3\n  top.env <- topenv(parent.frame(stack.depth))\n  if (args$token[1] != 'eval') return(top.env)\n\n  eval.frame <- sys.frame(frame.length-stack.depth)\n  lambda.r_temp_env <- tryCatch(get('envir', envir=eval.frame),\n    error=function(e) stop(\"Unable to extract envir in eval frame\\n\"))\n\n  #cat(\"NOTE: Using lambda.r_temp_env for\",parsed.call[1,'token'],\"\\n\", sep=' ')\n  lambda.r_temp_env\n}\n\nparse_eval <- function(it, raw=NULL)\n{\n  if (!is.null(raw))\n  {\n    if (!is.null(attr(raw,'data'))) raw <- attr(raw,'data')\n    it <- iterator(raw)\n  }\n  name <- get_name(it)\n  paren.level <- 0\n  node <- 'function.name'\n  out <- data.frame(paren.level=paren.level, node=node, token=name,\n    pattern=NA, default=NA, stringsAsFactors=FALSE)\n\n  arg.idx <- 1\n  node <- 'argument'\n  token <- NULL\n  while (!is.null(line <- it()) && TRUE)\n  {\n    line.token <- line$token\n    if (line.token == 'expr') next\n    if (line.token == \"'('\") \n    {\n      paren.level <- paren.level + 1\n      if (paren.level == 1) next # Opening function parenthesis\n    }\n    if (line.token == \"')'\")\n    {\n      paren.level <- paren.level - 1\n      if (paren.level < 1) # Closing function parenthesis\n      {\n        out <- rbind(out, c(1,node,paste(token,collapse=' '),NA,NA))\n        break\n      }\n    }\n\n    if (paren.level == 1 && line.token == \"','\")\n    {\n      out <- rbind(out, c(paren.level,node,paste(token,collapse=' '),NA,NA))\n      token <- NULL\n      arg.idx <- arg.idx + 1\n      next\n    }\n    token <- c(token, line$text)\n  }\n  out\n}\n\n.sync_debug <- function(fn.name) {\n  os <- getOption('lambdar.debug')\n  if (is.null(os)) return(invisible())\n\n  os[[fn.name]] <- NULL\n  options(lambdar.debug=os)\n  invisible()\n}\n\n\nget_lr <- function(fn.name) {\n  fn <- NULL\n  frames <- sys.frames()\n  n <- length(frames)\n  while (n > 0) {\n    fn <- get0(fn.name, frames[[n]], inherits=FALSE)\n    if (! is.null(fn)) return(fn)\n    n <- n - 1\n  }\n  get(fn.name)\n}\n"
  },
  {
    "path": "R/introspection.R",
    "content": "describe(fn, idx, raw=FALSE) %when% { raw } %:=% {\n  class(fn) <- NULL\n  print(fn)\n}\ndescribe(fn, idx) %when% {\n  idx > 0\n} %:=% {\n  variants <- attr(fn,'variants')\n  types <- attr(fn,'types')\n  if (length(variants) < 1) stop(\"Nothing to describe\")\n  if (idx > length(variants)) stop(\"Invalid index specified\")\n  variants[[idx]]$def\n}\nseal(describe)\n\n\ndebug.lr <- function(x)\n{\n  name <- deparse(substitute(x))\n  os <- getOption('lambdar.debug')\n  if (is.null(os)) os <- list()\n\n  os[[name]] <- TRUE\n  options(lambdar.debug=os)\n\n  if (! any(c('lambdar.fun','lambdar.type') %in% class(x)))\n    return(debug(x))\n\n  variants <- attr(x,'variants')\n  sapply(variants, function(v) debug(v$def))\n  invisible()\n}\n\nundebug.lr <- function(x)\n{\n  if (is.function(x)) {\n    name <- deparse(substitute(x))\n  } else {\n    name <- x\n    x <- get(x, parent.frame(), inherits=TRUE)\n  }\n  os <- getOption('lambdar.debug')\n  if (is.null(os)) return(invisible())\n\n  os[[name]] <- NULL\n  options(lambdar.debug=os)\n\n  if (! any(c('lambdar.fun','lambdar.type') %in% class(x)))\n    return(undebug(x))\n\n  variants <- attr(x,'variants')\n  sapply(variants, function(v) undebug(v$def))\n  invisible()\n}\n\n#' Undebug all registered functions\nundebug.all <- function() {\n  sapply(which.debug(), undebug.lr)\n  invisible()\n}\n\nis.debug <- function(fn.name) {\n  os <- getOption('lambdar.debug')\n  fn.name %in% names(os)\n}\n\nwhich.debug <- function() {\n  names(getOption('lambdar.debug'))\n}\n\nprint.lambdar.fun <- function(x, ...)\n{\n  variants <- attr(x,'variants')\n  types <- attr(x,'types')\n  if (is.null(variants)) stop(\"Oops: lambda.r function incorrectly defined\")\n  if (length(variants) < 1) stop(\"Function has no clauses\")\n  cat(\"<function>\\n\")\n  fn <- function(idx)\n  {\n    f <- variants[[idx]]\n    cat(\"[[\",idx,\"]]\\n\",sep='')\n    if (!is.null(f$type.index)) \n      cat(types[[f$type.index]]$signature,\"\\n\")\n    cat(f$signature,\"%:=% ...\\n\")\n  }\n  sapply(1:length(variants),fn)\n  invisible()\n}\n\nprint.lambdar.type <- function(x, ...)\n{\n  variants <- attr(x,'variants')\n  types <- attr(x,'types')\n  if (is.null(variants)) stop(\"Oops: lambda.r type constructor incorrectly defined\")\n  cat(\"<type constructor>\\n\")\n  fn <- function(idx)\n  {\n    f <- variants[[idx]]\n    cat(\"[[\",idx,\"]]\\n\",sep='')\n    if (!is.null(f$type.index)) \n      cat(types[[f$type.index]]$signature,\"\\n\")\n    cat(f$signature,\"%:=% ...\\n\")\n  }\n  sapply(1:length(variants),fn)\n  invisible()\n}\n"
  },
  {
    "path": "R/objects.R",
    "content": "MissingReturnType <- \"MissingReturnType\"\n"
  },
  {
    "path": "README.md",
    "content": "[![Build Status](https://travis-ci.org/zatonovo/lambda.r.png)](https://travis-ci.org/zatonovo/lambda.r)\n\nDescription\n===========\nProvides a syntax for writing functional programs in R. Lambda.r has a clean\nsyntax for defining multi-part functions with optional guard statements.\nSimple pattern matching is also supported. Types can be\neasily defined and instantiated using the same functional notation. Type \nchecking is integrated and optional, giving the programmer complete flexibility\nover their application or package.\n\nBasic Usage\n===========\nDefining a function\n-------------------\nFunctions are defined using `%as%` notation. Any block of code can be in the \nfunction definition.\n\n```R\nfib(n) %as% { fib(n-1) + fib(n-2) }\n```\n\nPattern matching\n----------------\nMulti-part function definitions are easily constructed. For simple criteria,\npattern matching of literals can be used directly in lambda.r.\n\n```R\nfib(0) %as% 1\nfib(1) %as% 1\n```\n\nStrings can also be pattern matched within definitions.\n\nGuard statements\n----------------\nExecuting different function variants within a multi-part function sometimes\nrequires more detail than simple pattern matching. For these scenarios a guard\nstatement is used to define the condition for execution. Guards are simply an \nadditional clause in the function definition.\n\n```R\nfib(n) %when% { n >= 0 } %as% { fib(n-1) + fib(n-2) }\n```\n\nA function variant only executes if the guard statements all evaluate to true.\nAs many guard statements as desired can be added in the block. Just separate\nthem with either a new line or a semi-colon.\n\n```R\nfib(n) %when% {\n  is.numeric(n)\n  n >= 0\n} %as% { fib(n-1) + fib(n-2) }\n```\n\nNote that in the above example the type check can be handled using a type \ndeclaration, which is discussed below.\n\nFor functions defined in multiple parts, each separate function variant is\nevaluated in the same order as they are defined. Hence a less restrictive\nvariant that evaluates to true defined early in the chain of function\ndefinitions will take precedence over variants defined later. (If you are\nfollowing along in sequence, the pattern matches for `fib(0)` and `fib(1)` will\nnever be called since the first definition `fib(n)` will always evaulate to true).\n\nTypes\n=====\nLambda.R introduces types as an alternative to classes. Types are data \nstructures with type information attached to it. Like classes, constructors\nexist for types and one type can inherit from another type. The difference is\nthat types do not have embedded methods. In functional programming, functions\nare first class so there is no need to embed them within the data structure.\nUsing types provides type safety, which means that a function variant will only\nexecute if the types are correct. \n\nDefining a type\n---------------\nTypes are defined by defining their constructor.  We define constructors using \nan uppercase function name.  The return value of the constructor is \nautomatically typed.  Hence the value x will be of type Integer.\n\n```R\nInteger(x) %as% x\n```\n\nInstantiating the type is as simple as calling the function. Check the type\nusing the standard S3 introspection function `class`. The `%isa%` operator\ncan also be used to test whether an object is a particular type.\n\n```R\nx <- Integer(5)\nx %isa% Integer\n```\n\nType declarations\n-----------------\nType constraints can be added to a function. These constraints specify the type\nof each input argument in addition to the return type. Using this approach\nensures that the arguments can only have compatible types when the function is\ncalled. The final type in the constraint is the return type, which is checked\nafter a function is called. If the result does not have the correct return type,\nthen the call will fail.\n\n```R\nfib(n) %::% Integer : Integer\nfib(0) %as% Integer(1)\nfib(1) %as% Integer(1)\nfib(n) %as% { fib(n-1) + fib(n-2) }\n\nfib(x)\n```\n\nThe call `fib(1)` will fail because `1` is not of type `Integer`.\n\n```R\n> fib(1)\nError in UseFunction(\"fib\", ...) : No valid function for 'fib(1)'\n```\n\nProperly typing the argument by calling `fib(Integer(1))` will give the\ncorrect output. Note that pattern matching works even with the custom type.\n\n```R\n> fib(Integer(1))\n[1] 1\nattr(,\"class\")\n[1] \"Integer\" \"numeric\"\n```\n\nType constraints must be declared prior to the function implementation. Once\ndeclared, the type declaration will retain scope\nuntil another type declaration with the same number of parameters is declared\n(see tests/types.R for an example).\n\nLegacy types\n------------\nThere are plenty of built-in types that are supported just like custom types \ndefined in lambda.r. Use the same syntax for these types. In the example above\nwe can just as easily declare\n\n```R\nfib(n) %::% numeric : numeric\n```\n\nor even \n\n```R\nfib(n) %::% Integer : numeric\n```\n\nNOTE: For objects of type function, due to the precedence rules of the parser,\nyou cannot specify 'function' in a type constraint. Instead use 'Function'.\n\n```R\n# Do this\nmake.gen(n) %::% numeric : Function\n\n# Don't do this\nmake.gen(n) %::% numeric : function\n\n```\n\nType Variables\n--------------\nType constraints are useful, but too specific of a constraint can destroy the\npolymorphism of a function. To preserve this while still retaining some\ntype safety you can use a type variable. With type variables the actual type\nis not checked. Instead it is the relationship between types that are checked.\n\n```R\nfib(n) %::% a : a\nfib(0) %as% 1\nfib(1) %as% 1\nfib(n) %as% { fib(n-1) + fib(n-2) }\n\n```\n\nIn this type constraint, both the input and output types must match.\n\nNote that the only characters valid for a type variable are the lowercase\nletters (i.e. a-z). If you need more than this for a single function definition,\nyou've got other problems.\n\nThe Ellipsis Type\n-----------------\nThe ellipsis can be inserted in a type constraint. This has interesting\nproperties as the ellipsis represents a set of arguments. To specify\nthat input values should be captured by the ellipsis, use ```...``` within\nthe type constraint. For example, suppose you want a function that\nmultiplies the sum of a set of numbers. The ellipsis type tells\nlambda.r to bind the types associated with the ellipsis type.\n\n```R\nsumprod(x, ..., na.rm=TRUE) %::% numeric : ... : logical : numeric\nsumprod(x, ..., na.rm=TRUE) %as% { x * sum(..., na.rm=na.rm) }\n\n> sumprod(4, 1,2,3,4)\n[1] 40\n```\n\nAlternatively, suppose you want all the values bound to the ellipsis\nto be of a certain type. Then you can append ```...``` to a concrete\ntype.\n\n```R\nsumprod(x, ..., na.rm=TRUE) %::% numeric : numeric... : logical : numeric\nsumprod(x, ..., na.rm=TRUE) %as% { x * sum(..., na.rm=na.rm) }\n\n> sumprod(4, 1,2,3,4)\n[1] 40\n> sumprod(4, 1,2,3,4,'a')\nError in UseFunction(sumprod, \"sumprod\", ...) :\n  No valid function for 'sumprod(4,1,2,3,4,a)'\n```\n\nIf you want to preserve polymorphism but still constrain values bound\nto the ellipsis to a single type, you can use a type variable. Note that\nthe same rules for type variables apply. Hence a type variable represents\na type that is not specified elsewhere.\n\n```R\nsumprod(x, ..., na.rm=TRUE) %::% a : a... : logical : a\nsumprod(x, ..., na.rm=TRUE) %as% { x * sum(..., na.rm=na.rm) }\n\n> sumprod(4, 1,2,3,4)\n[1] 40\n> sumprod(4, 1,2,3,4,'a')\nError in UseFunction(sumprod, \"sumprod\", ...) :\n  No valid function for 'sumprod(4,1,2,3,4,a)'\n```\n\nThe Don't-Care Type\n-------------------\nSometimes it is useful to ignore a specific type in a constraint. Since\nwe are not inferring all types in a program, this is an acceptable\naction. Using the ```.``` within a type constraint tells lambda.r to not\ncheck the type for the given argument.\n\nFor example in ```R f(x, y) %::% . : numeric : numeric```, the type of \n```x``` will not be checked.\n\n\nOne Shot\n========\nHere is the complete example using built-in types:\n\n```R\nfib(n) %::% numeric : numeric\nfib(0) %as% 1\nfib(1) %as% 1\nfib(n) %as% { fib(n-1) + fib(n-2) }\n\nfib(5)\nseal(fib)\n```\n\nTo ignore types altogether, just omit the type declaration in the above listing\nand the code will evaluate the same.\n\nHere is the same example with custom types:\n\n```R\nInteger(x) %as% x\n     \nfib(n) %::% Integer : Integer\nfib(0) %as% Integer(1)\nfib(1) %as% Integer(1)\nfib(n) %as% { fib(n-1) + fib(n-2) }\n\nx <- Integer(5)\nfib(x)\n```\n\nThe `seal` command in the first example prevents new statements from being\nadded to an existing function definition. Instead new definitions reset the\nfunction. Typically you don't need this function as lambda.r will auto-replace\nfunction definitions that have the same signature.\n\nSugar Coating\n=============\nAll the great features of R function calls are still supported in lambda.r. In \naddition, lambda.r provides some parse transforms to add some extra features\nto make application development even faster.\n\nObject Attributes\n-----------------\nAttributes are a form of meta data that decorate an object. This information\ncan be used to simplify type structures retaining polymorphism and compatibility\nwith existing functions while providing the detail needed for your application.\nLambda.R provides convenient syntax for interacting with attributes via the `@`\nsymbol.\n\n```R\nTemperature(x, system, units) %as%\n{\n  x@system <- system\n  x@units <- units\n  x\n}\n```\n\nThese attributes can then be accessed in guards and function bodies using the\nsame syntax.\n\n```R\nfreezing(x) %::% Temperature : logical\nfreezing(x) %when% {\n  x@system == 'metric'\n  x@units == 'celsius'\n} %as% {\n  if (x < 0) { TRUE }\n  else { FALSE }\n}\n```\n \nNote that outside of lambda.r you must use the standard attr() function to \naccess specific attributes. Also note that attributes have not been tested with\nS4 objects.\n\nOptional Arguments\n------------------\nA nice convenience in R is the ability to specify optional arguments with\ndefault values. Lambda.R preserves this feature in multipart function \ndefinitions. Functions are matched based on the order in which they are \ndefined, and this holds true with functions with optional arguments.\n\n```R\nTemperature(x, system=\"metric\", units='celsius') %as%\n{\n  x@system <- system\n  x@units <- units\n  x\n}\n\n> ctemp <- Temperature(20)\n> ctemp\n[1] 20\nattr(,\"system\")\n[1] \"metric\"\nattr(,\"units\")\n[1] \"celsius\"\nattr(,\"class\")\n[1] \"Temperature\" \"numeric\"\n```\n\nThe Ellipsis Argument\n---------------------\nSupport for the ellipsis argument is built into lambda.r. Required arguments \nmust still be matched, while any additional arguments will be enclosed in the \nellipsis. Here's an example using the plant data included in R's lm help page.\n\n```R\nregress(formula, ..., na.action='na.fail') %as% {\n  lm(formula, ..., na.action=na.action)\n}\n\nctl <- c(4.17,5.58,5.18,6.11,4.50,4.61,5.17,4.53,5.33,5.14)\ntrt <- c(4.81,4.17,4.41,3.59,5.87,3.83,6.03,4.89,4.32,4.69)\ndata <- data.frame(group=gl(2,10,20,labels=c(\"Ctl\",\"Trt\")), weight=c(ctl, trt))\nlm.D9 <- regress(weight ~ group, data=data)\n```\n\nCare does need to be used with the ellipsis as it behaves like a greedy match,\nso subsequent definitions may not work as you intend when using the ellipsis\nargument in a function variant.\n\nNamed Arguments\n---------------\nThe examples above all hint at supporting named arguments. Named arguments can\nbe mixed and matched with positional arguments just as in legacy function\ndefinitions.\n\n```R\nlm.D9 <- regress(data=data, weight ~ group)\n```\n\nAuto Replace and Sealing Definitions\n-------------------\nAs of version 1.1.0, lambda.r can detect a duplicate function signature and\nupdate an existing definition. This means development is more efficient \nsince you can re-source files and the existing definitions will update as you\nexpect. This process is compatible with multi-part function definitions and\ntype constraints. Do note that when using type constraints, only functions\nassociated with the active type constraint can be auto replaced. The reason is\nthat there can be two identical function signatures and lambda.r really has\nno way of knowing which one you mean. Hence, you have to tell lambda.r via\nthe type constraint.\n\n\nFor example take this simple reciprocal function. There are two type constraint\nclauses, and three total function variants.  The signatures for variants 2 and 3 \nare identical, so the only thing that distinguishes them are the different type \nconstraints associated with each one.  Notice that there is an explicit bug in \nthe definition of variant 2.\n\n```R\nreciprocal(n) %::% numeric : numeric\nreciprocal(0) %as% stop(\"Reciprocal of 0 is undefined\")\nreciprocal(n) %as% { 2/n }\n\nreciprocal(n) %::% character : numeric\nreciprocal(n) %as% { reciprocal(as.numeric(n)) }\n```\n\nTo change the definition of variant 2, you must re-declare\nthe first type constraint.  Otherwise, lambda.r would not know whether to update\nvariant 2 or 3.\n\n```R\nreciprocal(n) %::% numeric : numeric\nreciprocal(n) %as% { 1/n }\n```\n\nLambda.R has no way of knowing whether a function definition is complete or not.\nExplicitly telling lambda.r will ensure that any new function definitions will\nreset the function as opposed to append another definition.\n\n```R\nseal(freezing)\n```\n\nIf providing a broad interface, be careful not to seal the function. Sealing is\nanalogous to making a variable final in Java, such that no further modifications\ncan be made. The key difference is that attempting to add further defintions to\nthe sealed function will overwrite the existing definition. This behavior is\nintended to make application and package development more iterative.\n\nIntrospection\n=============\nA function in lambda.r has a lot of meta data attached to it. Accessing the raw\ndata can be overwhelming, so lambda.r provides facilities to extract the \nuseful bits. Viewing basic information about a function is accomplished by just\ntyping out the function in the shell. This results in a dump of the type\ndeclarations and function signatures for the function.\n\n```R\n> fib\n<function>\n[[1]]\nfib(n) %::% Integer:Integer \nfib(0) %as% ...\n[[2]]\nfib(n) %::% Integer:Integer \nfib(1) %as% ...\n[[3]]\nfib(n) %::% Integer:Integer \nfib(n) %as% ...\n```\n\nActual function bodies are not displayed to minimize clutter. \n\nExamining Functions\n-------------------\nTo view a full function definition, use the 'describe' function to get the\ndefinition of a specific function variant. The numbers separating each variant\nis the index to use.\n\n```R\n> describe(fib,3)\nfunction(n) { Integer ( fib ( n - 1 ) + fib ( n - 2 ) ) }\n<environment: 0x10488ed10>\n```\n\nExamining Types\n---------------\nA type constructor is similar to a normal function, and the same technique works\nto view a type body.\n\n```R\n> describe(Integer,1)\nfunction(x) { x }\n<environment: 0x10494aca8>\n```\n\n\nMonads\n------\n\nIf you want to play around with monads in R, `lambda.r` has your back.\nHere are some examples. Note that `lambda.tools` implements some common\nmonadic operators.\n\n```\nMaybe(a) %:=% a\nJust(a) %:=% Maybe(a)\nNothing() %:=% Maybe(NA)\n\nmreturn(x) %as% Just(x)\n\n\nm %>>=% g %when% { is.null(m) } %as% NULL\nm %>>=% g %::% Just : Function : Maybe\nm %>>=% g %as% g(m)\n\n\n\nm %>>=% g %::% Nothing : Function : Maybe\nm %>>=% g %as% m\n\nm %>>=% g %::% Just : Function : Maybe\nm %>>=% g %as% g(m)\n```\n\n\nComposition\n```\nf %.% g %:=% function(...) f(g(...))\n\n> unsafelogsqrt <- log %.% sqrt\n> unsafelogsqrt(100)\n [1] 2.302585\n```\n\n\nMonadic composition\n```\nf %>=>% g %:=% { function(x) f(x) %>>=% g }\nf %<=<% g %:=% { function(x) g(x) %>>=% f }\n\nsafelog(x) %::% numeric : Maybe\nsafelog(x) %when% { x <= 0 } %as% Nothing()\nsafelog(x) %:=% Just(log(x))\n\nsafesqrt(x) %::% numeric : Maybe\nsafesqrt(x) %when% { x <= 0 } %as% Nothing()\nsafesqrt(x) %:=% Just(sqrt(x))\n\nsafelogsqrt <- safelog %<=<% safesqrt\n```\n\n\n\n\nDebugging\n---------\nThe standard debug function will not work with lambda.r functions. Instead, use\nthe included functions debug.lr and undebug.lr. These functions will allow you\nto debug through a complete multipart function call.\n\nKnown Limitations\n=================\nIf you try to break lambda.r, you will most likely succeed. There are things \nthat won't work, but most use cases should work fine. Do let me know if you \nfind something that fails, but don't break it just to break it. Below are\nsome things that won't work.\n\n1. Complex mix and match of named and positional arguments\n\n```R\nlm.D9 <- regress(data=data, formula=weight ~ group, NULL)\n```\n\nDon't do this, please. It's bad style.\n\nWhat's New\n==========\n\nVersion 1.1.5\n-------------\n+ Support the ellipsis (...) in type constraints\n+ Support a typed ellipsis (numeric...) in type constraints\n+ Support ellipsis type variable (a...) in type constraints\n+ Support debug.lr in functions defined in packages (currently locked)\n+ Show which functions are being debugged\n+ Handle default arguments that execute a function\n+ Support more pattern matching (like empty lists)\n+ Support guards of the form f(a,b,c) %when% { sum(a,b,c) == 1 } %as% { 1 }\n+ Support guards of the form f(x) %when% { length(grep('foo',x)) > 0 } %as% { 1 }\n+ Support proper import namespace for packages\n+ Install from github using devtools: install_github('lambda.r','zatonovo')\n+ Travis CI integration: https://travis-ci.org/zatonovo/lambda.r\n\nVersion 1.1.1\n-------------\n+ Support Function in every type position (only supported for return type)\n+ Auto-replacing a function with 0 arguments fails\n+ Fix type inheritance\n+ Functions that return non-scalar values work as default values on arguments\n+ Support pattern matching on NULL and NA\n+ Support pattern matching on special symbol EMPTY\n\nVersion 1.1.0\n-------------\n+ Handle function types in type declarations\n+ Support type variables\n+ Auto-replace function definitions with a matching signature (no need for seal)\n+ Handle 0 argument functions\n\nFuture\n======\n+ Support *apply and lambda expressions in guard statements\n+ Support defining operators\n+ Lock functions by default (check when next function is different name). Use\n  public() as way to indicate function can be globally modified\n+ Think about supporting namespaces\n+ Support take, drop, cycle\n+ Support partial function application\n+ Check for side effects\n+ Support tail recursion\n+ Support type inference\n\n"
  },
  {
    "path": "man/UseFunction.Rd",
    "content": "\\name{UseFunction}\n\\alias{UseFunction}\n\\alias{NewObject}\n\\title{Primary dispatcher for functional programming }\n\\description{UseFunction manages the dispatching for multipart functions in \nlambda.r. This is used internally by lambda.r.}\n\\usage{\nUseFunction(fn, fn.name, ...)\nNewObject(type.fn, type.name, ...)\n}\n\\arguments{\n  \\item{fn}{The function reference that is being applied}\n  \\item{fn.name}{The name of a function that uses functional dispatching. This\n    is just the name of the function being defined}\n  \\item{type.fn}{The function representing the type constructor}\n  \\item{type.name}{The name of the type}\n  \\item{\\dots}{The arguments that are passed to dispatched functions }\n}\n\\details{\n  This function is used internally and generally does not need to be called\n  by an end user.\n}\n\\value{\n  Returns the value of the dispatched function\n}\n\\author{ Brian Lee Yung Rowe }\n\n\\seealso{\n\\code{\\link{\\%as\\%}}\n}\n\\examples{\n# Note that these are trivial examples for pedagogical purposes. Due to their\n# trivial nature, most of these examples can be implemented more concisely\n# using built-in R features.\n\n\nreciprocal(x) \\%::\\% numeric : numeric\nreciprocal(x) \\%when\\% {\n  x != 0\n} \\%as\\% {\n  1 / x\n}\n\nreciprocal(x) \\%::\\% character : numeric\nreciprocal(x) \\%as\\% {\n  reciprocal(as.numeric(x))\n}\n\nseal(reciprocal)\n\nprint(reciprocal)\nreciprocal(4)\nreciprocal(\"4\")\n\n}\n\\keyword{ methods }\n\\keyword{ programming }\n"
  },
  {
    "path": "man/duck.Rd",
    "content": "\\name{duck-typing}\n\\alias{\\%isa\\%}\n\\alias{\\%hasa\\%}\n\\alias{\\%hasall\\%}\n\\title{Functions for duck typing}\n\\description{Duck typing is a way to emulate type checking by virtue of an\nobject's characteristics as opposed to strong typing.}\n\\usage{\nargument \\%isa\\% type\nargument \\%hasa\\% property\nargument \\%hasall\\% property\n\n}\n\\arguments{\n  \\item{argument}{An object to inspect}\n  \\item{type}{A type name}\n  \\item{property}{A property of an object}\n}\n\\details{\n  These operators provide a convenient method for testing for specific\n  properties of an object. \n\n  \\code{\\%isa\\%} checks if an object is of the given type.\n\n  \\code{\\%hasa\\%} checks if an object has a given property. This can\n  be any named element of a list or data.frame.\n}\n\\value{\n  Boolean value indicating whether the specific test is true or not.\n}\n\\author{ Brian Lee Yung Rowe }\n\n\\seealso{\n\\code{\\link{\\%as\\%}}\n}\n\\examples{\n5 \\%isa\\% numeric\n\nPoint(r,theta, 'polar') \\%as\\% {\n  o <- list(r=r,theta=theta)\n  o@system <- 'polar'\n  o\n}\n\np <- Point(5, pi/2, 'polar')\np %hasa% theta\n\n}\n\\keyword{ methods }\n\\keyword{ programming }\n"
  },
  {
    "path": "man/framework.Rd",
    "content": "\\name{\\%as\\%}\n\\alias{\\%as\\%}\n\\alias{\\%:=\\%}\n\\alias{\\%::\\%}\n\\alias{EMPTY}\n\\alias{seal}\n\\title{Define functions and type constructors in lambda.r}\n\\description{The \\%as\\% function is used in place of the \nassignment operator for defining functions and type constructors \nwith lambda.r. The \\%as\\% operator is the gateway to a\nfull suite of advanced functional programming features.}\n\\usage{\nsignature \\%::\\% types\nsignature \\%as\\% body\nseal(fn)\n}\n\\arguments{\n  \\item{signature}{The function signature for the function to be defined}\n  \\item{types}{The type constraints for the function}\n  \\item{body}{The body of the function}\n  \\item{fn}{The function to seal}\n}\n\\details{\n  The \\%as\\% and \\%::\\% operators are the primary touch points with lambda.r.\n\n  Functions are defined using \\%as\\% notation. Any block of code can be in the \n  function definition. For simple criteria, pattern matching of literals can \n  be used directly in lambda.r. Executing different function clauses within a\n  multipart function sometimes requires more detail than simple pattern \n  matching. For these scenarios a guard statement is used to define the \n  condition for execution. Guards are simply an additional clause in the \n  function definition defined by the \\%when\\% operator.\n\n  \\code{ fib(n) \\%when\\% { n >= 0 } \\%as\\% { fib(n-1) + fib(n-2) } }\n\n  A function variant only executes if the guard statements all evaluate to true.\n  As many guard statements as desired can be added in the block. Just separate\n  them with either a new line or a semi-colon.\n\n  Type constructors are no different from regular functions with one exception:\n  the function name must start with a capital letter. In lambda.r, types are\n  defined in PascalCase and functions are lower case. Violating this rule will\n  result in undefined behavior. The return value of the type constructor is the\n  object that represents the type. It will have the type attached to the object.\n\n  \\code{ Number(x, set='real') \\%as\\% {\n    x@set <- set\n    x\n  }}\n\n  Attributes can be accessed using lambda.r's at-notation, which borrows from\n  S4's member notation. These attributes are standard R attributes and should\n  not be confused with object properties. Hence with lambda.r it is possible to\n  use both the $ to access named elements of lists and data.frames while using\n  the @ symbol to access the object's attributes.\n\n  Type constraints specify the type of each input argument in addition to the\n  return type. Using this approach ensures that the arguments can only have\n  compatible types when the function is called. The final type in the\n  constraint is the return type, which is checked after a function is called.\n  If the result does not have the correct return type, then the call will fail.\n  Each type is separated by a colon and their order is defined by the order of\n  the function clause signature. \n  \n  Each function clause can have its own type constraint. Once a constraint is\n  defined, it will continue to be valid until another type constraint is\n  defined.\n\n  'seal' finalizes a function definition. Any new statements found will reset\n  the definition, effectively deleting it. This is useful to prevent other\n  people from accidentally modifying your function definition.\n}\n\\value{\n  The defined functions are invisibly returned.\n}\n\\author{ Brian Lee Yung Rowe }\n\n\\examples{\n# Type constraints are optional and include the return type as the \n# final type\nreciprocal(x) \\%::\\% numeric : numeric\nreciprocal(0) \\%as\\% stop(\"Division by 0 not allowed\")\n\n# The type constraint is still valid for this function clause\nreciprocal(x) \\%when\\% {\n  # Guard statements can be added in succession\n  x != 0\n  # Attributes can be accessed using '@' notation\n  is.null(x@dummy.attribute)\n} \\%as\\% {\n  # This is the body of the function clause\n  1 / x\n}\n\n# This new type constraint applies from this point on\nreciprocal(x) \\%::\\% character : numeric\nreciprocal(x) \\%as\\% {\n  reciprocal(as.numeric(x))\n}\n\n# Seal the function so no new definitions are allowed\nseal(reciprocal)\n\nprint(reciprocal)\nreciprocal(4)\nreciprocal(\"4\")\n\n}\n\\keyword{ methods }\n\\keyword{ programming }\n"
  },
  {
    "path": "man/introspection.Rd",
    "content": "\\name{introspection}\n\\alias{describe}\n\\alias{debug.lr}\n\\alias{undebug.lr}\n\\alias{undebug.all}\n\\alias{is.debug}\n\\alias{which.debug}\n\\alias{print.lambdar.fun}\n\\alias{print.lambdar.type}\n\\title{Introspection for lambda.r}\n\\description{These tools are used for debugging and provide a means of examining\nthe evaluation order of the function definitions as well as provide a lambda.r\ncompatible debugger.}\n\\usage{\ndebug.lr(x)\n\nundebug.lr(x)\n\nis.debug(fn.name)\n\nwhich.debug()\n\nundebug.all()\n\ndescribe(\\dots)\n\\method{print}{lambdar.fun}(x, \\dots)\n\\method{print}{lambdar.type}(x, \\dots)\n}\n\\arguments{\n  \\item{x}{The function}\n  \\item{fn.name}{The name of the function}\n  \\item{\\dots}{Additional arguments}\n}\n\\details{\n  For a basic description of the function it is easiest to just type the \n  function name in the shell. This will call the print methods and print a\n  clean output of the function definition. The definition is organized based\n  on each function clause. If a type constraint exists, this precedes the \n  clause signature including guards. To reduce clutter, the actual body of the\n  function clause is not printed. To view a clause body, each clause is \n  prefixed with an index number, which can be used in the \\code{describe}\n  function to get a full listing of the function.\n\n  \\code{describe(fn, idx)} \n\n  The 'debug.lr' and 'undebug.lr' functions are replacements for the built-in\n  debug and undebug functions. They provide a mechanism to debug a complete\n  function, which is compatible with the dispatching in lambda.r. The semantics\n  are identical to the built-ins. Note that these functions will properly\n  handle non-lambda.r functions so only one set of commands need to be\n  issued.\n\n  Lambda.r keeps track of all functions that are being debugged. To see\n  if a function is currently set for debugging, use the \\code{is.debug}\n  function. To see all functions that are being debugged, use\n  \\code{which.debug}. It is possible to undebug all debugged functions\n  by calling \\code{undebug.all}.\n}\n\\value{\n  The defined functions are invisibly returned.\n}\n\\author{ Brian Lee Yung Rowe }\n\n\\examples{\n\\dontrun{\nf(x) %as% x\ndebug.lr(f)\nwhich.debug()\nundebug.lr(f)\n}\n}\n\\keyword{ methods }\n\\keyword{ programming }\n"
  },
  {
    "path": "man/lambda.r-package.Rd",
    "content": "\\name{lambda.r-package}\n\\alias{lambda.r-package}\n\\alias{lambda.r}\n\\docType{package}\n\\title{\nModeling Data with Functional Programming\n}\n\\description{\nLambda.r is a language extension that supports a functional programming \nstyle in R. As an alternative to the object-oriented systems,\nlambda.r offers a functional syntax for defining types and functions.\nFunctions can be defined with multiple distinct function clauses\nsimilar to how multipart mathematical functions are defined.\nThere is also support for pattern matching and guard expressions to \nfinely control function dispatching, all the while still\nsupporting standard features of R. Lambda.r also introduces its own\ntype system with intuitive type constructors are and\ntype constraints that can optionally be added to function definitions.\nAttributes are also given the attention they deserve with a clean\nand convenient syntax that reduces type clutter.\n}\n\\details{\n\\tabular{ll}{\nPackage: \\tab lambda.r\\cr\nType: \\tab Package\\cr\nVersion: \\tab 1.2.4\\cr\nDate: \\tab 2019-09-15\\cr\nLicense: \\tab LGPL-3\\cr\nLazyLoad: \\tab yes\\cr\n}\nData analysis relies so much on mathematical operations, transformations,\nand computations that a functional approach is better suited for these\ntypes of applications. The reason is that object models rarely make sense in\ndata analysis since so many transformations are applied to data sets. Trying to\ndefine classes and attach methods to them results in a futile enterprise rife\nwith arbitrary choices and hierarchies. Functional programming avoids this\nunnecessary quandry by making objects and functions first class and preserving\nthem as two distinct entities. \n\nR provides many functional programming concepts mostly inherited from \nScheme. Concepts like first class functions and lazy evaluation are\nkey components to a functional language, yet R lacks some of the more\nadvanced features of modern functional programming languages.\nLambda.r introduces a syntax for writing applications using a\ndeclarative notation that facilitates reasoning about your program\nin addition to making programs modular and easier to maintain.\n\n\n\\subsection{Function Definition}{\nFunctions are defined using the \\code{\\%as\\%} (or \\code{\\%:=\\%}) symbol \nin place of \\code{<-}.\nSimple functions can be defined as simply\n\\preformatted{f(x) \\%as\\% x }\nand can be called like any other function.\n\\preformatted{f(1) }\n\nFunctions that have a more complicated body require braces.\n\\preformatted{f(x) \\%as\\% { 2 * x }\n\ng(x, y) \\%:=\\% {\n  z <- x + y\n  sqrt(z)\n}\n}\n\n\\subsection{Infix notation}{\nFunctions can be defined using infix notation as well.\nFor the function \\code{g} above, it can be defined as an infix operator\nusing\n\nx \\%g\\% y \\%:=\\% {\n  z <- x + y\n  sqrt(z)\n}\n}\n\n\\subsection{Multipart functions and guards}{\nMany functions are defined in multiple parts. For example absolute value\nis typically defined in two parts: one covering negative numbers and one\ncovering everything else. Using guard expressions and the \\code{\\%when\\%}\nkeyword, these parts can be easily captured.\n\\preformatted{abs(x) \\%when\\% { x < 0 } \\%as\\% -x\nabs(x) \\%as\\% x\n}\n\nAny number of guard expressions can be in a guard block, such that all\nguard expressions must evaluate to true.\n\\preformatted{abs(x) \\%when\\% {\n  is.numeric(x)\n  length(x) == 1\n  x < 0\n} \\%as\\% -x\n\nabs(x) \\%when\\% {\n  is.numeric(x)\n  length(x) == 1\n} \\%as\\% x\n}\n\nIf a guard is not satisfied, then the next clause is tried. If no\nfunction clauses are satisfied, then an error is thrown.\n}\n\n\\subsection{Pattern matching}{\nSimple scalar values can be specified in a function definition in \nplace of a variable name. These scalar values become patterns that\nmust be matched exactly in order for the function clause to execute.\nThis syntactic technique is known as pattern matching.\n\nRecursive functions can be defined simply using pattern matching.\nFor example the famed Fibonacci sequence can be defined recursively.\n\\preformatted{fib(0) \\%as\\% 1\nfib(1) \\%as\\% 1\nfib(n) \\%as\\% { fib(n-1) + fib(n-2) }\n}\nThis is also useful for conditionally executing a function.\nThe reason you would do this is that it becomes easy to symbolically\ntransform the code, making it easier to reason about.\n\\preformatted{pad(x, length, TRUE) \\%as\\% c(rep(NA,length), x)\npad(x, length, FALSE) \\%as\\% x\n}\n\nIt is also possible to match on \\code{NULL} and \\code{NA}.\n\\preformatted{sizeof(NULL) \\%as\\% 0\nsizeof(x) \\%as\\% length(x)\n}\n}\n\n}\n\n\\subsection{Types}{\nA type is a custom data structure with meaning. Formally a type is\ndefined by its type constructor, which codifies how to create objects\nof the given type. The lambda.r type system is fully compatible with\nthe built-in S3 system. Types in lambda.r must start with a\ncapital letter.\n\n\\subsection{Type constructors}{\nA type constructor is responsible for creating objects of a given type.\nThis is simply a function that has the name of the type. So to\ncreate a type \\code{Point} create its type constructor.\n\\preformatted{Point(x,y) \\%as\\% list(x=x,y=y) }\nNote that any built-in data structure can be used as a base type. \nLambda.r simply extends the base type with additional type information.\n\nTypes are then created by calling their type constructor.\n\\preformatted{p <- Point(3,4)}\n\nTo check whether an object is of a given type, use the \\code{\\%isa\\%}\noperator. \\preformatted{p \\%isa\\% Point}\n}\n\n\\subsection{Type constraints}{\nOnce a type is defined, it can be used to limit execution of a\nfunction. R is a dynamically typed language, but with type constraints\nit is possible to add static typing to certain functions. S4 does\nthe same thing, albeit in a more complicated manner.\n\nSuppose we want to define a distance function for \\code{Point}.\nSince it is only meaningful for \\code{Point}s we do not want to \nexecute it for other types. This is achieved by using a type constraint,\nwhich declares the function argument types as well as the\ntype of the return value. Type constraints are defined by declaring the\nfunction signature followed by type arguments. \\preformatted{distance(a,b) \\%::\\% Point : Point : numeric\ndistance(a,b) \\%as\\% { sqrt((b$x - a$x)^2 + (b$y - a$y)^2) }}\nWith this type constraint \\code{distance} will only be called if both arguments\nare of type \\code{Point}. After the function is applied, a further\nrequirement is that the return value must be of type \\code{numeric}.\nOtherwise lambda.r will throw an error.\nNote that it is perfectly legal to mix and match lambda.r types with\nS3 types in type constraints.\n\n}\n\n\\subsection{Type variables}{\nDeclaring types explicitly gives a lot of control, but it also\nlimits the natural polymorphic properties of R functions. \nSometimes all that is needed is to define the relationship\nbetween arguments. These relationships can be captured by\na type variable, which is simply any single lower case letter \nin a type constraint.\n\nIn the distance example, suppose we do not want to restrict the \nfunction to just \\code{Point}s, but whatever type is used must\nbe consistent for both arguments. In this case a type variable is\nsufficient. \\preformatted{distance(a,b) \\%::\\% z : z : numeric\ndistance(a,b) \\%as\\% { sqrt((b$x - a$x)^2 + (b$y - a$y)^2) }}\nThe letter \\code{z} was used to avoid confusion with the names of\nthe arguments, although it would have been just as valid to use\n\\code{a}.\n\nType constraints and type variables can be applied to any lambda.r\nfunction, including type constructors.\n}\n\n\\subsection{The ellipsis type}{\nThe ellipsis can be inserted in a type constraint. This has interesting\nproperties as the ellipsis represents a set of arguments. To specify\nthat input values should be captured by the ellipsis, use \\code{...} within\nthe type constraint. For example, suppose you want a function that\nmultiplies the sum of a set of numbers. The ellipsis type tells\nlambda.r to bind the types associated with the ellipsis type.\n\n\\preformatted{sumprod(x, ..., na.rm=TRUE) \\%::\\% numeric : ... : logical : numeric\nsumprod(x, ..., na.rm=TRUE) \\%as\\% { x * sum(..., na.rm=na.rm) }\n\n> sumprod(4, 1,2,3,4)\n[1] 40}\n\nAlternatively, suppose you want all the values bound to the ellipsis\nto be of a certain type. Then you can append ```...``` to a concrete\ntype.\n\n\\preformatted{sumprod(x, ..., na.rm=TRUE) \\%::\\% numeric : numeric... : logical : numeric\nsumprod(x, ..., na.rm=TRUE) \\%as\\% { x * sum(..., na.rm=na.rm) }\n\n> sumprod(4, 1,2,3,4)\n[1] 40\n> sumprod(4, 1,2,3,4,'a')\nError in UseFunction(sumprod, \"sumprod\", ...) :\n  No valid function for 'sumprod(4,1,2,3,4,a)' }\n\nIf you want to preserve polymorphism but still constrain values bound\nto the ellipsis to a single type, you can use a type variable. Note that\nthe same rules for type variables apply. Hence a type variable represents\na type that is not specified elsewhere.\n\n\\preformatted{sumprod(x, ..., na.rm=TRUE) \\%::\\% a : a... : logical : a\nsumprod(x, ..., na.rm=TRUE) \\%as\\% { x * sum(..., na.rm=na.rm) }\n\n> sumprod(4, 1,2,3,4)\n[1] 40\n> sumprod(4, 1,2,3,4,'a')\nError in UseFunction(sumprod, \"sumprod\", ...) :\n  No valid function for 'sumprod(4,1,2,3,4,a)' }\n\n}\n\n\\subsection{The don't-care type}{\nSometimes it is useful to ignore a specific type in a constraint. Since\nwe are not inferring all types in a program, this is an acceptable\naction. Using the ```.``` within a type constraint tells lambda.r to not\ncheck the type for the given argument.\n\nFor example in \\code{f(x, y) \\%::\\% . : numeric : numeric}, the type of \n\\code{x} will not be checked.\n\n}\n\n}\n\n\\subsection{Attributes}{\nThe attribute system in R is a vital, yet often overlooked feature.\nThis orthogonal data structure is essentially a list attached to \nany object. The benefit of using attributes is that it reduces\nthe need for types since it is often simpler to reuse existing\ndata structures rather than create new types.\n\nSuppose there are two kinds of \\code{Point}s: those defined as\nCartesian coordinates and those as Polar coordinates. Rather than\ncreate a type hierarchy, you can attach an attribute to the object.\nThis keeps the data clean and separate from meta-data that only\nexists to describe the data.\n\\preformatted{Point(r,theta, 'polar') \\%as\\% {\n  o <- list(r=r,theta=theta)\n  o@system <- 'polar'\n  o\n}\n\nPoint(x,y, 'cartesian') \\%as\\% {\n  o <- list(x=x,y=y)\n  o@system <- 'cartesian'\n  o\n}\n}\n\nThen the \\code{distance} function can be defined according to the\ncoordinate system.\n\\preformatted{distance(a,b) \\%::\\% z : z : numeric\ndistance(a,b) \\%when\\% {\n  a@system == 'cartesian'\n  b@system == 'cartesian'\n} \\%as\\% {\n  sqrt((b$x - a$x)^2 + (b$y - a$y)^2)\n}\n\ndistance(a,b) \\%when\\% {\n  a@system == 'polar'\n  b@system == 'polar'\n} \\%as\\% {\n  sqrt(a$r^2 + b$r^2 - 2 * a$r * b$r * cos(a$theta - b$theta))\n}\n}\nNote that the type constraint applies to both function clauses.\n\n}\n\n\\subsection{Debugging}{\nAs much as we would like, our code is not perfect. To help\ntroubleshoot any problems that exist, lambda.r provides hooks into\nthe standard debugging system. Use \\code{debug.lr} as a drop-in \nreplacement for \\code{debug} and \\code{undebug.lr} for \\code{undebug}.\nIn addition to being aware of multipart functions, lambda.r's \ndebugging system keeps track of what is being debugged, so you can \nquickly determine which functions are being debugged. To see \nwhich functions are currently marked for debugging, call\n\\code{which.debug}. Note that if you use \\code{debug.lr} for\nall debugging then lambda.r will keep track of all debugging in \nyour R session. Here is a short example demonstrating this.\n\\preformatted{> f(x) \\%as\\% x\n> debug.lr(f)\n> debug.lr(mean)\n>\n> which.debug()\n[1] \"f\"    \"mean\"\n}\n}\n\n}\n\\note{\nStable releases are uploaded to CRAN about once a year. The most recent\npackage is always available on github [2] and can be installed via\n`rpackage` in `crant` [3].\n\\preformatted{rpackage https://github.com/zatonovo/lambda.r/archive/master.zip\n}\n}\n\\author{\nBrian Lee Yung Rowe\n\nMaintainer: Brian Lee Yung Rowe <r@zatonovo.com>\n}\n\\references{\n[1] Blog posts on lambda.r: http://cartesianfaith.com/category/r/lambda-r/\n\n[2] Lambda.r source code, https://github.com/muxspace/lambda.r\n\n[3] Crant, https://github.com/muxspace/crant\n}\n\\keyword{ package }\n\\keyword{ programming }\n\\seealso{\n\\code{\\link{\\%as\\%}}, \\code{\\link{describe}}, \\code{\\link{debug.lr}},\n\\code{\\link{\\%isa\\%}}\n}\n\\examples{\nis.wholenumber <-\n  function(x, tol = .Machine$double.eps^0.5)  abs(x - round(x)) < tol\n\n## Use built in types for type checking\nfib(n) \\%::\\% numeric : numeric\nfib(0) \\%as\\% 1\nfib(1) \\%as\\% 1\nfib(n) \\%when\\% {\n  is.wholenumber(n)\n} \\%as\\% {\n  fib(n-1) + fib(n-2)\n}\n\nfib(5)\n\n\n## Using custom types\nInteger(x) \\%when\\% { is.wholenumber(x) } \\%as\\% x\n\nfib.a(n) \\%::\\% Integer : Integer\nfib.a(0) \\%as\\% Integer(1)\nfib.a(1) \\%as\\% Integer(1)\nfib.a(n) \\%as\\% { Integer(fib.a(n-1) + fib.a(n-2)) }\n\nfib.a(Integer(5))\n\n\n## Newton-Raphson optimization\nconverged <- function(x1, x0, tolerance=1e-6) abs(x1 - x0) < tolerance\nminimize <- function(x0, algo, max.steps=100)\n{\n  step <- 0\n  old.x <- x0\n  while (step < max.steps)\n  {\n    new.x <- iterate(old.x, algo)\n    if (converged(new.x, old.x)) break\n    old.x <- new.x\n  }\n  new.x\n}\n\niterate(x, algo) \\%::\\% numeric : NewtonRaphson : numeric\niterate(x, algo) \\%as\\% { x - algo$f1(x) / algo$f2(x) }\n\niterate(x, algo) \\%::\\% numeric : GradientDescent : numeric\niterate(x, algo) \\%as\\% { x - algo$step * algo$f1(x) }\n\nNewtonRaphson(f1, f2) \\%as\\% list(f1=f1, f2=f2)\nGradientDescent(f1, step=0.01) \\%as\\% list(f1=f1, step=step)\n\n\nfx <- function(x) x^2 - 4\nf1 <- function(x) 2*x\nf2 <- function(x) 2\n\nalgo <- NewtonRaphson(f1,f2)\nminimize(3, algo)\n\nalgo <- GradientDescent(f1, step=0.1)\nminimize(3, algo)\n}\n"
  },
  {
    "path": "tests/test-all.R",
    "content": "library(testit)\ntest_pkg('lambda.r')\n\n"
  },
  {
    "path": "tests/testit/test-auto_replace.1.R",
    "content": "rm(list=ls())\n\nassert('auto_replace.no_types_1a', {\n  fib(0) %as% 2\n  fib(0) %as% 1\n  fib(1) %as% 1\n  fib(n) %as% { fib(n-1) + fib(n-2) }\n  seal(fib)\n\n  act <- fib(3)\n  act == 3\n})\n\nassert('auto_replace.no_types_1b', {\n  fib(0) %as% 2\n  fib(0) %as% 1\n  fib(1) %as% 1\n  fib(n) %as% { fib(n-1) - fib(n-2) }\n  fib(n) %as% { fib(n-1) + fib(n-2) }\n  seal(fib)\n\n  act <- fib(3)\n  act == 3\n})\n\n# Zero argument functions\nassert('auto_replace.no_types_1c', {\n  foo() %as% 2\n  foo() %as% 1\n  seal(foo)\n\n  act <- foo()\n  act == 1\n})\n\n# Zero argument functions as part of a multipart definition\nassert('auto_replace.no_types_1c', {\n  foo(n) %as% n\n  foo() %as% 2\n  foo() %as% 1\n  seal(foo)\n\n  act.1 <- foo()\n  act.2 <- foo(5)\n\n  (act.1 == 1)\n  (act.2 == 5)\n})\n\n"
  },
  {
    "path": "tests/testit/test-auto_replace.2.R",
    "content": "assert('auto_replace.types_2a', {\n  fib(n) %::% numeric : numeric\n  fib(0) %as% 1\n  fib(1) %as% 2\n  fib(n) %as% { fib(n-1) - fib(n-2) }\n  fib(n) %as% { fib(n-1) + fib(n-2) }\n\n  fib(n) %::% character : numeric\n  fib(n) %as% { fib(as.numeric(n)) }\n\n  fib(n) %::% numeric : numeric\n  fib(1) %as% 1\n  seal(fib)\n\n  act.1 <- fib(3)\n  act.2 <- fib(\"3\")\n\n  (act.1 == 3)\n  (act.2 == 3)\n})\n\nassert('auto_replace.types_2b', {\n  fib() %::% numeric\n  fib() %as% 3\n\n  fib(n) %::% numeric : numeric\n  fib(0) %as% 1\n  fib(1) %as% 2\n  fib(n) %as% { fib(n-1) - fib(n-2) }\n  fib(n) %as% { fib(n-1) + fib(n-2) } \n  fib(n) %::% character : numeric\n  fib(n) %as% { fib(as.numeric(n)) }\n\n  fib(n) %::% numeric : numeric\n  fib(1) %as% 1\n\n  fib() %as% 5\n  seal(fib)\n\n  act.1 <- fib(3)\n  act.2 <- fib(\"3\")\n  act.3 <- fib()\n\n  (act.1 == 3)\n  (act.2 == 3)\n  (act.3 == 5)\n})\n\nassert('auto_replace.types_2c', {\n  fib() %::% numeric\n  fib() %as% 3\n  fib() %as% 5\n  seal(fib)\n\n  act <- fib()\n  act == 5\n})\n\ntest.auto_replace.types_2d <- function() {\n  fib() %::% numeric\n  fib() %as% 3\n\n  fib(n) %::% numeric : numeric\n  fib(n) %as% n\n\n  fib() %as% 5\n  seal(fib)\n\n  act.1 <- fib()\n  act.2 <- fib(4)\n\n  (act.1 == 5)\n  (act.2 == 4)\n}\n\n"
  },
  {
    "path": "tests/testit/test-auto_replace.3.R",
    "content": "test.auto_replace_3 <- function() {\n  fib(0) %as% 2\n  fib(0) %as% 1\n  fib(1) %as% 1\n  fib(n=5) %as% { fib(n-1) - fib(n-2) }\n  fib(n=2) %as% { fib(n-1) + fib(n-2) }\n  seal(fib)\n\n  # These are failing\n  act.1 <- fib(3)\n  act.2 <- fib(2)\n\n  (act.1 == 3)\n  (act.2 == 2)\n}\n\n"
  },
  {
    "path": "tests/testit/test-dispatching.1.R",
    "content": "rm(list=ls())\nassert('dispatching_1a', {\n  fib(0) %as% 1\n  fib(1) %as% 1\n  fib(n) %when% {\n    abs(n - round(n)) < .Machine$double.eps^0.5\n  } %as% {\n    fib(n-1) + fib(n-2)\n  }\n  seal(fib)\n\n  fib(5) == 8\n})\n\nrm(list=ls())\nassert('dispatching_1b', {\n  fib(n) %::% numeric : numeric\n  fib(0) %as% 1\n  fib(1) %as% 1\n  fib(n) %as% { fib(n-1) + fib(n-2) }\n  seal(fib)\n\n  act.1 <- fib(5)\n  act.2 <- tryCatch(fib(\"a\"), error=function(x) 'error')\n\n  (act.1 == 8)\n  (act.2 == 'error')\n})\n\nrm(list=ls())\nassert('dispatching_1c', {\n  Integer(x) %as% x\n\n  fib(n) %::% Integer : Integer\n  fib(0) %as% Integer(1)\n  fib(1) %as% Integer(1)\n  fib(n) %as% { Integer(fib(n-1) + fib(n-2)) }\n  seal(Integer)\n  seal(fib)\n\n  act <- tryCatch(fib(5), error=function(x) 'error')\n\n  (fib(Integer(5)) == Integer(8))\n  (act == 'error')\n})\n\nrm(list=ls())\nassert('dispatching_1d', {\n  abs_max(a,b) %::% numeric : numeric : numeric\n  abs_max(a,b) %when% {\n    a != b\n  } %as% {\n    pmax(abs(a), abs(b))\n  }\n\n  abs_max(a,b) %::% character : character : numeric\n  abs_max(a,b) %as%\n  {\n    abs_max(as.numeric(a), as.numeric(b))\n  }\n\n  abs_max(a) %as% { max(abs(a)) }\n  seal(abs_max)\n\n  a <- c(1,2,5,6,3,2,1,3)\n\n  (abs_max(2,-3) == 3)\n  (abs_max(\"3\",\"-4\") == 4)\n  (abs_max(a) == 6)\n})\n\n\nrm(list=ls())\nassert('different_names', {\n  A(a) %as% { list(a=a) }\n  A(b) %as% { list(b=b) }\n  seal(A)\n\n  (A(5)$a == 5)\n  (A(a=5)$a == 5)\n  (A(b=5)$b == 5)\n})\n\nrm(list=ls())\nassert('empty_function', {\n  a() %as% {  }\n  seal(a)\n\n  b(a) %as% {  }\n  seal(b)\n\n  # Empty functions will fail\n  has_error(a())\n  has_error(b(1))\n})\n\nrm(list=ls())\nassert('empty_type_constructor', {\n  A() %as% {  }\n  seal(A)\n\n  B(a) %as% {  }\n  seal(B)\n\n  # Empty functions will fail\n  has_error(A())\n  has_error(B(1))\n})\n\n"
  },
  {
    "path": "tests/testit/test-ellipsis_arguments.1.R",
    "content": "rm(list=ls())\n\nPrices(series, asset.class, periodicity) %as% \n{\n  series@asset.class <- asset.class\n  series@periodicity <- periodicity\n  series@visualize <- TRUE\n  series\n}\n\nvisualize(x, ...) %when% {\n  x@visualize == TRUE\n} %as% {\n  plot(x, ...)\n}\nseal(Prices)\nseal(visualize)\n\ndummy(x, ...) %as% { list(...) }\nseal(dummy)\n\n\nassert('ellipsis_arguments_1', {\n  ps <- Prices(rnorm(50), 'equity', 'daily')\n  visualize(ps, main='Prices', xlab='time')\n\n  scatter <- matrix(rnorm(200), ncol=2)\n  act <- tryCatch(visualize(scatter), error=function(x) 'error')\n\n  attr(scatter,'visualize') <- TRUE\n  visualize(scatter)\n\n  visualize(scatter, main='random')\n\n  (act == 'error')\n})\n\nassert('ellipsis_unnamed_arguments 1', {\n  act <- dummy(1,2)\n  all.equal(act, list(2))\n})\n\nassert('ellipsis_unnamed_arguments 2', {\n  act <- dummy(1,2,3,4)\n  all.equal(act, list(2,3,4))\n})\n\n"
  },
  {
    "path": "tests/testit/test-ellipsis_arguments.2.R",
    "content": "rm(list=ls())\n\n# :vim set filetype=R\nregress(formula, ..., na.action=na.fail) %as% {\n  lm(formula, ..., na.action=na.action)\n}\nseal(regress)\n\nassert('ellipsis_arguments_2', {\n  ctl <- c(4.17,5.58,5.18,6.11,4.50,4.61,5.17,4.53,5.33,5.14)\n  trt <- c(4.81,4.17,4.41,3.59,5.87,3.83,6.03,4.89,4.32,4.69)\n  data <- data.frame(group=gl(2,10,20,labels=c(\"Ctl\",\"Trt\")), weight=c(ctl, trt))\n  lm.1 <- regress(weight ~ group, data=data)\n  lm.2 <- regress(data=data, formula=weight ~ group)\n\n  all(lm.2$coefficients == lm.1$coefficients)\n  all(lm.2$residuals == lm.1$residuals)\n})\n"
  },
  {
    "path": "tests/testit/test-examples.R",
    "content": "assert('example_1', {\n  reciprocal(x) %::% numeric : numeric\n  reciprocal(x) %when% { x != 0 } %as% { 1 / x }\n  reciprocal(x) %::% character : numeric\n  reciprocal(x) %as% { reciprocal(as.numeric(x)) }\n\n  act.1 <- reciprocal(4)\n  act.2 <- reciprocal(\"4\")\n\n  (act.1 == 0.25)\n  (act.2 == 0.25)\n})\n"
  },
  {
    "path": "tests/testit/test-factorial.1.R",
    "content": "rm(list=ls())\n\nassert('factorial_1', {\n  fac(0) %as% 1\n  fac(n) %when% { n > 0 } %as% { n * fac(n - 1) }\n  seal(fac)\n\n  act <- tryCatch(fac(-1), error=function(x) 'error')\n\n  (fac(1) == 1)\n  (fac(5) == 120)\n  (act == 'error')\n})\n"
  },
  {
    "path": "tests/testit/test-factorial.2.R",
    "content": "rm(list=ls())\n\nassert('factorial_2', {\n  WholeNumber(x) %when% { x > 0 } %as% x\n\n  fac(n) %::% WholeNumber : WholeNumber\n  fac(0) %as% WholeNumber(1)\n  fac(n) %when% { n > 0 } %as% { n * fac(n - 1) }\n\n  fac(n) %::% numeric : WholeNumber\n  fac(n) %as% fac(WholeNumber(n))\n\n  (fac(WholeNumber(1)) == WholeNumber(1))\n  (fac(WholeNumber(5)) == WholeNumber(120))\n  (fac(1) == WholeNumber(1))\n  (fac(5) == WholeNumber(120))\n\n  act <- tryCatch(fac(-1), error=function(x) 'error')\n  (act == 'error')\n})\n"
  },
  {
    "path": "tests/testit/test-fill_args.R",
    "content": "rm(list=ls())\n\n#act <- tryCatch(fib(3), error=function(x) 'error')\n#checkEquals(act, 'error')\n\nassert('type_fill_args_1', {\n  mysum(x, y, ...) %as% { (x - y) * sum(...) }\n  seal(mysum)\n\n  act <- mysum(2, 3, 1, 2, 3)\n  (act == -6)\n\n  act <- mysum(x=2, 3, 1, 2, 3)\n  (act == -6)\n\n  act <- mysum(2, y=3, 1, 2, 3)\n  (act == -6)\n\n  act <- mysum(y=3, x=2, 1, 2, 3)\n  (act == -6)\n\n  act <- mysum(y=3, 1, 2, 3, x=2)\n  (act == -6)\n\n  act <- mysum(2, 1, 2, 3, y=3)\n  (act == -6)\n})\n\nassert('type_fill_args_2', {\n  mysum(x, y=3, ...) %as% { (x - y) * sum(...) }\n  seal(mysum)\n\n  act <- mysum(2, 1, 1, 2, 3)\n  (act == -7)\n\n  act <- mysum(1, y=2, 1, 1, 2, 3)\n  (act == -7)\n\n  act <- mysum(y=2, x=1, 1, 1, 2, 3)\n  (act == -7)\n\n  act <- mysum(1, 1, 2, 3, x=2)\n  (act == -7)\n\n  act <- mysum(1, 1, 1, 2, 3, y=2)\n  (act == -7)\n})\n\n\n"
  },
  {
    "path": "tests/testit/test-function_args.1.R",
    "content": "rm(list=ls())\n\nassert('function_args_1', {\n  f() %as% 1\n  seal(f)\n  act <- f()\n  (act ==1)\n})\n\nassert('function_args_2', {\n  f() %::% numeric\n  f() %as% 1\n  seal(f)\n  act <- f()\n  (act ==1)\n})\n\nassert('function_args_3', {\n  f() %::% numeric\n  f() %as% 1\n  f(a) %::% numeric : numeric\n  f(a) %as% a\n  seal(f)\n\n  act <- f()\n  (act ==1)\n  act <- f(3)\n  (act ==3)\n})\n\nassert('function_args_4', {\n  f() %::% numeric\n  f() %:=% 1\n  f(a) %::% numeric : numeric\n  f(a) %:=% a\n  seal(f)\n\n  act <- f()\n  (act ==1)\n  act <- f(3)\n  (act ==3)\n})\n\n"
  },
  {
    "path": "tests/testit/test-function_type.1.R",
    "content": "rm(list=ls())\n\nassert('function_type_1', {\n  seq.gen(start) %::% a : Function\n  seq.gen(start) %as%\n  {\n    value <- start - 1\n    function() {\n      value <<- value + 1\n      return(value)\n    }\n  }\n  seal(seq.gen)\n\n  act <- seq.gen(1)\n  ('function' %in% class(act))\n})\n"
  },
  {
    "path": "tests/testit/test-heaviside_step.1.R",
    "content": "assert('heaviside_1', {\n  h.step(n) %when% { n < 0 } %as% { 0 }\n  h.step(0) %as% 0.5\n  h.step(n) %as% 1\n  seal(h.step)\n\n  (h.step(-1) == 0)\n  (h.step(0) == 0.5)\n  (h.step(1) == 1)\n})\n"
  },
  {
    "path": "tests/testit/test-heaviside_step.2.R",
    "content": "rm(list=ls())\n\nassert('heaviside_2', {\n  h.step(n) %::% numeric : numeric\n  h.step(n) %when% { n < 0 } %as% { 0 }\n  h.step(0) %as% 0.5\n  h.step(n) %as% 1\n  seal(h.step)\n\n  (h.step(-1) == 0)\n  (h.step(0) == 0.5)\n  (h.step(1) == 1)\n\n  has_error(h.step(\"a\"))\n})\n"
  },
  {
    "path": "tests/testit/test-infix.1.R",
    "content": "rm(list=ls())\n\nassert('infix.1', {\n  a %mod% b %:=% { a %/% b }\n  seal(`%mod%`)\n\n  act <- 5 %mod% 2\n  exp <- 5 %/% 2\n  (act == exp)\n})\n\nassert('infix.2', {\n  a %mod% b %as% { a %/% b }\n  seal(`%mod%`)\n\n  act <- 5 %mod% 2\n  exp <- 5 %/% 2\n  (act == exp)\n})\n\n"
  },
  {
    "path": "tests/testit/test-optional_arguments.1.R",
    "content": "# vim: set filetype=R\n\nrm(list=ls())\nassert('optional_arguments_1a', {\n  Prices(series, asset.class='equity', periodicity='daily') %as% {\n    series@asset.class <- asset.class\n    series@periodicity <- periodicity\n    series\n  }\n\n  returns(x) %when% {\n    x@asset.class == \"equity\"\n    x@periodicity == \"daily\"\n  } %as% {\n    x[2:length(x)] / x[1:(length(x) - 1)] - 1\n  }\n  seal(Prices)\n  seal(returns)\n\n  ps <- Prices(abs(rnorm(50)))\n  (attr(ps,'asset.class') == 'equity')\n  (attr(ps,'periodicity') == 'daily')\n\n  ps <- Prices(abs(rnorm(50)), 'fx')\n  (attr(ps,'asset.class') == 'fx')\n  (attr(ps,'periodicity') == 'daily')\n\n  ps <- Prices(abs(rnorm(50)), periodicity='monthly')\n  (attr(ps,'asset.class') == 'equity')\n  (attr(ps,'periodicity') == 'monthly')\n\n  ps <- Prices(periodicity='monthly', series=abs(rnorm(50)))\n  (attr(ps,'asset.class') == 'equity')\n  (attr(ps,'periodicity') == 'monthly')\n\n  err <- tryCatch(returns(ps), error=function(x) 'error')\n  (err == 'error')\n\n  ps <- Prices(abs(rnorm(50)))\n  (length(returns(ps)) == length(ps) - 1)\n\n})\n\n\nrm(list=ls())\nassert('optional_arguments_1b', {\n  Temperature(x, system='metric', units='celsius') %as% {\n    x@system <- system\n    x@units <- units\n    x\n  }\n\n  freezing(x) %::% Temperature : logical\n  freezing(x) %when% {\n    x@system == 'metric'\n    x@units == 'celsius'\n  } %as% {\n    if (x < 0) { TRUE }\n    else { FALSE }\n  }\n\n  freezing(x) %when% {\n    x@system == 'metric'\n    x@units == 'kelvin'\n  } %as% {\n    if (x < 273) { TRUE }\n    else { FALSE }\n  }\n  seal(Temperature)\n  seal(freezing)\n\n  ctemp <- Temperature(20)\n  (! freezing(ctemp))\n\n  ktemp <- Temperature(20, units='kelvin')\n  (freezing(ktemp))\n})\n\n\nrm(list=ls())\nassert('optional_arguments_1c', {\n  avg(x, fun=mean) %as% { fun(x) }\n\n  a <- 1:4\n  a.mean <- avg(a)\n  (a.mean == 2.5)\n\n  a.med <- avg(a, median)\n  (a.med == 2.5)\n})\n"
  },
  {
    "path": "tests/testit/test-optional_arguments.2.R",
    "content": "# vim: set filetype=R\nrm(list=ls())\nassert('optional_arguments_no_args', {\n  f(name='ROOT') %as% 1\n  seal(f)\n  (f() == 1)\n  (f('a') == 1)\n})\n\nrm(list=ls())\nassert('optional_arguments_no_args_type_constraint', {\n  f(name) %::% character : numeric\n  f(name='ROOT') %as% 1\n  seal(f)\n  (f() == 1)\n  (f('a') == 1)\n})\n\nrm(list=ls())\nassert('optional_arguments_function', {\n  f(x, y=runif(5)) %as% { x + y }\n  seal(f)\n  act <- f(1)\n  (length(act) == 5)\n})\n\nrm(list=ls())\nassert('optional_arguments_function_named', {\n  f(y=runif(5), x) %as% { x + y }\n  seal(f)\n  act <- f(x=1)\n  (length(act) == 5)\n})\n\nrm(list=ls())\nassert('optional_arguments_reference_var', {\n  f(y=min(x), x) %as% { x + y }\n  seal(f)\n  act <- f(x=1:5)\n  (length(act) == 5)\n  (act == 2:6)\n})\n"
  },
  {
    "path": "tests/testit/test-parse_transforms.1.R",
    "content": "rm(list=ls())\n\nassert('parse_transforms_1', {\n  Prices(series) %as% \n  {\n    series@asset.class <- 'equity'\n    series@periodicity <- 'daily'\n    series\n  }\n\n  returns(x) %when% {\n    x@asset.class == \"equity\"\n    x@periodicity == \"daily\"\n  } %as% {\n    x[2:length(x)] / x[1:(length(x) - 1)] - 1\n  }\n\n  ps <- Prices(rnorm(50))\n  (attr(ps,'asset.class') == 'equity')\n  (attr(ps,'periodicity') == 'daily')\n\n  rs <- returns(ps)\n  (length(rs) == length(ps) - 1)\n})\n"
  },
  {
    "path": "tests/testit/test-parse_transforms.2.R",
    "content": "rm(list=ls())\n\nTemperature(x, system, units) %as%\n{\n  x@system <- system\n  x@units <- units\n  x\n}\n\nfreezing(x) %when% {\n  x@system == 'metric'\n  x@units == 'celsius'\n} %as% {\n  if (x < 0) { TRUE }\n  else { FALSE }\n}\n\nassert('parse_transforms_2', {\n  temp <- Temperature(20, 'metric', 'celsius')\n  (attr(temp,'system') == 'metric')\n  (attr(temp,'units') == 'celsius')\n\n  (! freezing(temp))\n})\n"
  },
  {
    "path": "tests/testit/test-parse_transforms.3.R",
    "content": "rm(list=ls())\n\nWishartModel(n,m,Q,sd) %as% {\n  x <- list()\n  x@n <- n\n  x@m <- m\n  x@Q <- Q\n  x@sd <- sd\n  x\n}\n\nWishartMatrix(x, model) %as% {\n  x@n <- model@n\n  x@m <- model@m\n  x@Q <- model@Q\n  x@sd <- model@sd\n  x\n}\n\n\nassert('parse_transforms_3', {\n  model <- WishartModel(10,20,2,1)\n  mat <- WishartMatrix(rnorm(10), model)\n\n  (attr(mat,'n') == 10)\n  (attr(mat,'m') == 20)\n  (attr(mat,'Q') == 2)\n  (attr(mat,'sd') == 1)\n})\n"
  },
  {
    "path": "tests/testit/test-pattern_matching.R",
    "content": "# :vim set filetype=R\n\n\nrm(list=ls())\nassert('pattern_null', {\n  fold(f, x, acc) %as% acc\n  fold(f, NULL, acc) %as% acc\n  \n  act <- fold(function(x,y) x + y, NULL, 5)\n  (5 == act)\n})\n\nrm(list=ls())\nassert('pattern_na', {\n  fold(f, x, acc) %as% acc\n  fold(f, NA, acc) %as% acc\n  \n  act <- fold(function(x,y) x + y, NA, 5)\n  (5 == act)\n})\n\nrm(list=ls())\nassert('pattern_empty', {\n  fold(f, EMPTY, acc) %as% acc\n  fold(f,x,acc) %as% { fold(f,x[-1], f(x[1],acc)) }\n  plus <- function(x,y) x + y\n  \n  act <- fold(plus, 1:5, 0)\n  (15 == act)\n})\n"
  },
  {
    "path": "tests/testit/test-taylor_series.1.R",
    "content": "rm(list=ls())\n\ncompare <- function(a,b, xs) {\n  plot(xs, a(xs), type='l')\n  lines(xs, b(xs), type='l', col='blue')\n  invisible()\n}\n\n# f <- taylor(sin, pi)\n# xs <- seq(2,4.5,0.02)\n# compare(sin,f, xs)\n#\n# p <- function(x) x^4 + 3 * (x-2)^3 - 2 * x^2 + 1\n# p1 <- function(x) 4*x^3 + 9*(x-2)^2 - 4*x\n# p2 <- function(x) 12*x^2 + 18*(x-2) - 4\n# p3 <- function(x) 24*x + 18\n#\n# f <- taylor(p, 1)\n# xs <- seq(-5,5,0.02)\n# compare(p,f, xs)\n# \n# f(x) ~ f(a) + f'(a) * (x - a) + f''(a) / 2! * (x - a)^2 + ...\nassert('taylor_series_1', {\n  fac(1) %as% 1\n  fac(n) %when% { n > 0 } %as% { n * fac(n - 1) }\n  seal(fac)\n\n  # TODO: Implement this properly for k > 2\n  d(f, 1, h=10^-9) %as% function(x) { (f(x + h) - f(x - h)) / (2*h) }\n  d(f, 2, h=10^-9) %as% function(x) { (f(x + h) - 2*f(x) + f(x - h)) / h^2 }\n   \n  taylor(f, a, step=2) %as% taylor(f, a, step, 1, function(x) f(a))\n  taylor(f, a, 0, k, g) %as% g\n  taylor(f, a, step, k, g) %as% {\n    df <- d(f,k)\n    g1 <- function(x) { g(x) + df(a) * (x - a)^k / fac(k) }\n    taylor(f, a, step-1, k+1, g1)\n  }\n\n  f <- taylor(sin, pi)\n  v <- f(3.1)\n  all.equal(v, sin(3.1), tolerance=0.01)\n})\n"
  },
  {
    "path": "tests/testit/test-type_any_type.R",
    "content": "\nrm(list=ls())\nassert('type_any_type_1', {\n  fib(n) %::% . : a\n  fib(0) %as% 1\n  fib(1) %as% 1\n  fib(n) %as% { fib(n-1) + fib(n-2) }\n  seal(fib)\n\n  act <- fib(4)\n  (act == 5)\n})\n\nrm(list=ls())\nassert('type_any_type_2', {\n  hypotenuse(a,b) %::% . : . : numeric\n  hypotenuse(a,b) %as% { (a^2 + b^2)^.5 }\n  seal(hypotenuse)\n\n  act <- hypotenuse(3,4)\n  (act ==5)\n})\n\nrm(list=ls())\nassert('type_any_type_3', {\n  hypotenuse(a,b) %::% numeric : numeric: .\n  hypotenuse(a,b) %as% { (a^2 + b^2)^.5 }\n  seal(hypotenuse)\n\n  act <- hypotenuse(3,4)\n  (act ==5)\n})\n\nrm(list=ls())\nassert('type_any_type_4', {\n  hypotenuse(a,b) %::% a : a: .\n  hypotenuse(a,b) %as% { (a^2 + b^2)^.5 }\n  seal(hypotenuse)\n\n  act <- hypotenuse(3,4)\n  (act ==5)\n})\n\n"
  },
  {
    "path": "tests/testit/test-type_ellipsis.R",
    "content": "#act <- tryCatch(fib(3), error=function(x) 'error')\n#checkEquals(act, 'error')\n\nrm(list=ls())\nassert('type_ellipsis_1', {\n  ioc(f, ...) %::% Function : ... : .\n  ioc(f, ...) %as% f(...)\n  seal(ioc)\n\n  act <- ioc(sum, 1, 2, 3)\n  (act == 6)\n})\n\nrm(list=ls())\nassert('type_ellipsis_2', {\n  ioc(f, ...) %::% Function : ... : numeric\n  ioc(f, ...) %as% f(...)\n  seal(ioc)\n\n  act <- ioc(sum, 1, 2, 3)\n  (act == 6)\n})\n\nrm(list=ls())\nassert('type_ellipsis_3', {\n  mysum(x, ...) %::% a : ... : numeric\n  mysum(x, ...) %as% sum(...)\n  seal(mysum)\n\n  act <- mysum('foo', 1, 2, 3)\n  (act == 6)\n})\n\nrm(list=ls())\nassert('type_ellipsis_4', {\n  mysum(..., x) %::% ... : logical : numeric\n  mysum(..., x) %as% sum(..., na.rm=x)\n  seal(mysum)\n\n  act <- mysum(1, 2, 3, x=TRUE)\n  (act == 6)\n})\n\nrm(list=ls())\nassert('type_ellipsis_var_1', {\n  mysum(..., x) %::% numeric... : logical : numeric\n  mysum(..., x) %as% sum(..., na.rm=x)\n  seal(mysum)\n\n  act <- mysum(1, 2, 3, x=FALSE)\n  (act == 6)\n})\n\n"
  },
  {
    "path": "tests/testit/test-type_functions.R",
    "content": "rm(list=ls())\n\nassert('zero', {\n  zero() %::% Function\n  zero() %as% { function() 1 }\n\n  act <- zero()\n  (act() == 1)\n})\n\nassert('one_application', {\n  fn.0 <- function() 0\n\n  one_application(x) %::% Function : numeric\n  one_application(x) %as% { x() }\n\n  act <- one_application(fn.0)\n  (act == 0)\n})\n\nassert('one_identity', {\n  fn.0 <- function() 0\n\n  one_identity(x) %::% Function : Function\n  one_identity(x) %as% { x }\n\n  act <- one_identity(fn.0)\n  identical(act, fn.0)\n})\n\nassert('two_application', {\n  fn.1 <- function(x) x\n\n  two_application(x,y) %::% Function : numeric : numeric\n  two_application(x,y) %as% { x(y) }\n\n  two_application(y,x) %::% numeric : Function : numeric\n  two_application(y,x) %as% { x(y) }\n\n  act <- two_application(fn.1,2)\n  (act == 2)\n\n  act <- two_application(4,fn.1)\n  (act == 4)\n})\n\nassert('two_identity', {\n  fn.0 <- function() 0\n  fn.1 <- function(x) x\n\n  two_identity(x,y) %::% Function : numeric : Function\n  two_identity(x,y) %as% { x }\n\n  two_identity(y,x) %::% numeric : Function : Function\n  two_identity(y,x) %as% { x }\n\n  act <- two_identity(fn.0, 1)\n  identical(act, fn.0)\n\n  act <- two_identity(2, fn.1)\n  identical(act, fn.1)\n})\n\n"
  },
  {
    "path": "tests/testit/test-type_inheritance.R",
    "content": "\n\nrm(list=ls())\nassert('inheritance_one_arg', {\n  Base(x) %as% x\n  A(x) %as% { Base(x) }\n  B(x) %as% { A(x) }\n  E(x) %as% { Base(x) }\n\n  one.arg(x) %::% A : character\n  one.arg(x) %as% { \"a\" }\n\n  one.arg(x) %::% Base : character\n  one.arg(x) %as% { \"base\" }\n\n  seal(Base)\n  seal(A)\n  seal(B)\n  seal(E)\n  seal(one.arg)\n\n  a <- A(1)\n  b <- B(2)\n  c <- E(3)\n  act.a <- one.arg(a)\n  (act.a == \"a\")\n  act.b <- one.arg(b)\n  (act.b == \"a\")\n  act.c <- one.arg(c)\n  (act.c == \"base\")\n})\n\n\nrm(list=ls())\nassert('inheritance_two_arg', {\n  Base(x) %as% x\n  A(x) %as% { Base(x) }\n  B(x) %as% { A(x) }\n  E(x) %as% { Base(x) }\n\n  two.arg(x,y) %::% A : B : character\n  two.arg(x,y) %as% { \"a\" }\n\n  two.arg(x,y) %::% Base : Base : character\n  two.arg(x,y) %as% { \"base\" }\n\n  seal(Base)\n  seal(A)\n  seal(B)\n  seal(E)\n  seal(two.arg)\n\n  a <- A(1)\n  b <- B(2)\n  c <- E(3)\n  act.a <- two.arg(a,b)\n  (act.a == \"a\")\n  act.b <- two.arg(b,b)\n  (act.b == \"a\")\n  act.c <- two.arg(c,b)\n  (act.c == \"base\")\n})\n\n\nrm(list=ls())\nassert('inheritance_with_type_variable', {\n  Base(x) %as% x\n  A(x) %as% { Base(x) }\n  B(x) %as% { A(x) }\n  E(x) %as% { Base(x) }\n\n  two.arg(x,y) %::% a : B : character\n  two.arg(x,y) %as% { \"a\" }\n\n  two.arg(x,y) %::% Base : Base : character\n  two.arg(x,y) %as% { \"base\" }\n\n  seal(Base)\n  seal(A)\n  seal(B)\n  seal(E)\n  seal(two.arg)\n\n  a <- A(1)\n  b <- B(2)\n  c <- E(3)\n  act.a <- two.arg(a,b)\n  (act.a == \"a\")\n  act.b <- two.arg(b,b)\n  (act.b == \"a\")\n  act.c <- two.arg(c,b)\n  (act.c == \"a\")\n})\n\n\nrm(list=ls())\nassert('inheritance_with_ellipsis_1', {\n  Base(x, ...) %as% list(x=x, ...)\n  A(x, z) %as% { Base(x, z=z) }\n\n  seal(Base)\n  seal(A)\n\n  a <- A(1, 2)\n  (a$x == 1)\n  (a$z == 2)\n})\n\n\nrm(list=ls())\nassert('inheritance_with_ellipsis_2', {\n  Base(x=1, ...) %as% list(x=x, ...)\n  A(z) %as% { Base(z=z) }\n\n  seal(Base)\n  seal(A)\n\n  a <- A(2)\n  (a$x == 1)\n  (a$z == 2)\n})\n"
  },
  {
    "path": "tests/testit/test-type_integer_inheritance.R",
    "content": "rm(list=ls())\nassert('type_integer_1', {\n  fib(n) %::% numeric : numeric\n  fib(0) %as% 1\n  fib(1) %as% 1\n  fib(n) %as% { fib(n-1) + fib(n-2) }\n  seal(fib)\n\n  act <- fib(3)\n  (act == 3)\n})\n\nrm(list=ls())\nassert('type_integer_2', {\n  fib(n) %::% numeric : numeric\n  fib(0) %as% 1\n  fib(1) %as% 1\n  fib(n) %as% { fib(n-1) + fib(n-2) }\n  seal(fib)\n\n  act <- fib(as.integer(3))\n  (act == 3)\n})\n\nrm(list=ls())\nassert('type_integer_5', {\n  fib(n) %::% numeric : numeric\n  fib(0) %as% as.integer(1)\n  fib(1) %as% as.integer(1)\n  fib(n) %as% { as.integer(fib(n-1) + fib(n-2)) }\n  seal(fib)\n\n  act <- fib(as.integer(3))\n  (act == 3)\n})\n\nrm(list=ls())\nassert('type_integer_3', {\n  hypotenuse(a,b) %::% numeric : numeric : numeric\n  hypotenuse(a,b) %as% { (a^2 + b^2)^.5 }\n  seal(hypotenuse)\n\n  act <- hypotenuse(as.integer(3),4)\n  (act ==5)\n})\n\nrm(list=ls())\nassert('type_integer_4', {\n  hypotenuse(a,b) %::% numeric : numeric : numeric\n  hypotenuse(a,b) %as% { (a^2 + b^2)^.5 }\n  seal(hypotenuse)\n\n  act <- hypotenuse(as.integer(3), as.integer(4))\n  (act ==5)\n})\n\n"
  },
  {
    "path": "tests/testit/test-type_variable.1.R",
    "content": "rm(list=ls())\ntest.type_variable_1 <- function() {\n  fib(n) %::% a : a\n  fib(0) %as% 1\n  fib(1) %as% 1\n  fib(n) %as% { fib(n-1) + fib(n-2) }\n  seal(fib)\n\n  #act <- tryCatch(f(2,3), error=function(x) 'error')\n  #checkEquals(act, 'error')\n  act <- fib(3)\n  (act == 3)\n}\n\nrm(list=ls())\nignore.type_variable_2 <- function() {\n  fib(n) %::% b : a\n  fib(0) %as% 1\n  fib(1) %as% 1\n  fib(n) %as% { fib(n-1) + fib(n-2) }\n  seal(fib)\n\n  act <- tryCatch(f(2), error=function(x) 'error')\n  #cat(\"\\ntest.type_variable_2: act =\",act,\"\\n\")\n  ('error' == act)\n}\n\nrm(list=ls())\nignore.type_variable_3 <- function() {\n  fib(n) %::% a : b\n  fib(0) %as% 1\n  fib(1) %as% 1\n  fib(n) %as% { fib(n-1) + fib(n-2) }\n  seal(fib)\n\n  act <- tryCatch(f(2), error=function(x) 'error')\n  ('error' == act)\n}\n\nrm(list=ls())\ntest.type_variable_4 <- function() {\n  hypotenuse(a,b) %::% a : a : a\n  hypotenuse(a,b) %as% { (a^2 + b^2)^.5 }\n  seal(hypotenuse)\n\n  #act <- tryCatch(f(2), error=function(x) 'error')\n  #checkEquals(act, 'error')\n  act <- hypotenuse(3,4)\n  (act ==5)\n}\n\nrm(list=ls())\ntest.type_variable_5 <- function() {\n  hypotenuse(a,b) %::% a : b : a\n  hypotenuse(a,b) %as% { (a^2 + b^2)^.5 }\n  seal(hypotenuse)\n\n  act <- tryCatch(hypotenuse(5,12), error=function(x) 'error')\n  (act == 'error')\n}\n\nrm(list=ls())\ntest.type_variable_6 <- function() {\n  hypotenuse(a,b) %::% a : a : b\n  hypotenuse(a,b) %as% { (a^2 + b^2)^.5 }\n  seal(hypotenuse)\n\n  act <- tryCatch(hypotenuse(5,12), error=function(x) 'error')\n  (act == 'error')\n}\n\nrm(list=ls())\ntest.mixed_type_variable_1 <- function() {\n  Point(x,y) %as% list(x=x,y=y)\n  distance(a,b) %::% Point : Point : z \n  distance(a,b) %as% { ((a$x - b$x)^2 + (a$y - b$y)^2)^.5 }\n  seal(distance)\n\n  point.1 <- Point(2, 2)\n  point.2 <- Point(1, 1)\n\n  act <- distance(point.1, point.2)\n  (act == sqrt(2))\n}\n"
  },
  {
    "path": "tests/testit/test-types.1.R",
    "content": "# vim: set filetype=R\n\nrm(list=ls())\ntest.types_1 <- function() {\n  A(x) %as% x\n  B(x) %as% x\n\n  f(a,b) %::% A : B : numeric\n  f(a,0) %when% { a < 5; a > 0 } %as% { z <- a + 2; unclass(z * 2) }\n  f(a,b) %when% { a < 0 } %as% { unclass(abs(a) + b) }\n  f(a,b) %as% { unclass(a + b) }\n\n  seal(A)\n  seal(B)\n  seal(f)\n\n  act.1 <- tryCatch(f(2,3), error=function(x) 'error')\n  #cat(\"[test.types_1] act.1 =\",act.1,\"\\n\")\n  (act.1 == 'error')\n  a <- A(2)\n  b <- B(3)\n  act.2 <- f(a,b)\n  (act.2 == 5)\n}\n\n\nrm(list=ls())\ntest.types_2.1 <- function() {\n  Point(x,y) %as% list(x=x,y=y)\n  Polar(r,theta) %as% list(r=r,theta=theta)\n\n  distance(a,b) %::% Point : Point : numeric\n  distance(a,b) %as% { ((a$x - b$x)^2 + (a$y - b$y)^2)^.5 } \n\n  distance(a,b) %::% Polar : Polar : numeric\n  distance(a,b) %as%\n  {\n    (a$r^2 + b$r^2 - 2 * a$r * b$r * cos(a$theta - b$theta))^.5\n  }\n  seal(Point)\n  seal(Polar)\n  seal(distance)\n\n  point.1 <- Point(2,3)\n  point.2 <- Point(5,7)\n  (distance(point.1,point.2) == 5)\n}\n\n\nrm(list=ls())\ntest.types_2.2 <- function() {\n  Point(x,y) %as% list(x=x,y=y)\n  Polar(r,theta) %as% list(r=r,theta=theta)\n\n  distance(a,b) %::% Point : Point : numeric\n  distance(a,b) %as% { ((a$x - b$x)^2 + (a$y - b$y)^2)^.5 } \n\n  distance(a,b) %::% Polar : Polar : numeric\n  distance(a,b) %as%\n  {\n    (a$r^2 + b$r^2 - 2 * a$r * b$r * cos(a$theta - b$theta))^.5\n  }\n  seal(Point)\n  seal(Polar)\n  seal(distance)\n\n  point.3 <- Polar(3,pi/2)\n  point.4 <- Polar(4,pi)\n  (distance(point.3,point.4) == 5)\n}\n"
  }
]