#  File src/library/methods/R/as.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2013 The R Core Team
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  A copy of the GNU General Public License is available at
#  http://www.r-project.org/Licenses/

as <-
  ## Returns the version of this object coerced to be the given `Class'.
  ## If the corresponding `is' relation is true, it will be used.  In particular,
  ## if the relation has a coerce method, the method will be invoked on `object'.
  ##
  ## If the `is' relation is FALSE, and `coerceFlag' is `TRUE',
  ## the coerce function will be called (which will throw an error if there is
  ## no valid way to coerce the two objects).  Otherwise, `NULL' is returned.
  function(object, Class, strict = TRUE, ext = possibleExtends(thisClass, Class))
{
    ## prior to 2.7.0 there was a pseudo-class "double"
    if(.identC(Class, "double")) Class <- "numeric"
    thisClass <- .class1(object)
    if(.identC(thisClass, Class) || .identC(Class, "ANY"))
        return(object)
    where <- .classEnv(thisClass, mustFind = FALSE)
    coerceFun <- getGeneric("coerce", where = where)
    ## get the methods table, use inherited table
    coerceMethods <- .getMethodsTable(coerceFun,environment(coerceFun),inherited= TRUE)
    asMethod <- .quickCoerceSelect(thisClass, Class, coerceFun, coerceMethods, where)
    if(is.null(asMethod)) {
        sig <-  c(from=thisClass, to = Class)
        ## packageSlot(sig) <- where
        ## try first for an explicit (not inherited) method
        ## ?? Can this ever succeed if .quickCoerceSelect failed?
        asMethod <- selectMethod("coerce", sig, optional = TRUE,
                                 useInherited = FALSE, #optional, no inheritance
                                 fdef = coerceFun, mlist = getMethodsForDispatch(coerceFun))
        if(is.null(asMethod)) {
            canCache <- TRUE
            inherited <- FALSE
            if(is(object, Class)) {
                ClassDef <- getClassDef(Class, where)
                ## use the ext information, computed or supplied
                if(identical(ext, FALSE))
                    stop(sprintf("internal problem in as(): %s is(object, \"%s\") is TRUE, but the metadata asserts that the 'is' relation is FALSE",
                                 dQuote(thisClass), Class),
                         domain = NA)
                else if(identical(ext, TRUE))
                    asMethod <- .makeAsMethod(quote(from), TRUE, Class, ClassDef, where)
                else {
                  test <- ext@test
                  asMethod <- .makeAsMethod(ext@coerce, ext@simple, Class, ClassDef, where)
                  canCache <- (!is(test, "function")) || identical(body(test), TRUE)
                 }
            }
            if(is.null(asMethod) && extends(Class, thisClass)) {
                ClassDef <- getClassDef(Class, where)
                asMethod <- .asFromReplace(thisClass, Class, ClassDef, where)
            }
            ## if none of these applies, look for an inherited method
            ## but only on the from argument
            if(is.null(asMethod)) {
                asMethod <- selectMethod("coerce", sig, optional = TRUE,
                                         c(from = TRUE, to = FALSE),
                                         fdef = coerceFun, mlist = coerceMethods)
                inherited <- TRUE
            }
            else if(canCache)  # make into method definition
                asMethod <- .asCoerceMethod(asMethod, thisClass, ClassDef, FALSE, where)
	    if(is.null(asMethod))
		stop(gettextf("no method or default for coercing %s to %s",
			      dQuote(thisClass),
                              dQuote(Class)),
                     domain = NA)
	    else if(canCache) {
		## cache in the coerce function's environment
		cacheMethod("coerce", sig, asMethod, fdef = coerceFun,
			    inherited = inherited)
	    }
        }
    }
    if(strict)
        asMethod(object)
    else
        asMethod(object, strict = FALSE)
}

.quickCoerceSelect <- function(from, to, fdef, methods, where) {
    if(is.null(methods))
        return(NULL)
    else if(is.environment(methods)) {
        method <- .findMethodInTable(c(from, to), methods)
        if(is.environment(method))
            NULL # FIXME:  should resolve by checking package
        else
            method
    }
    else {
        allMethods <- methods@allMethods
        i <- match(from, names(allMethods))
        if(is.na(i))
          NULL
        else {
            methodsi <- allMethods[[i]]
            j <- match(to, names(methodsi))
            if(is.na(j))
              NULL
            else
              methodsi[[j]]
        }
    }
}

.asFromReplace <- function(fromClass, toClass, ClassDef, where) {
    ## toClass extends fromClass, so an asMethod will
    ## be the equivalent of new("toClass", fromObject)
    ## But must check that replacement is defined, in the case
    ## of nonstandard superclass relations
    replaceMethod <- elNamed(ClassDef@contains, fromClass)
    if(is(replaceMethod, "SClassExtension") &&
       !identical(as(replaceMethod@replace, "function"), .ErrorReplace)) {
        f <- function(from, to) NULL
        body(f, envir = where) <-
            substitute({obj <- new(TOCLASS); as(obj, FROMCLASS) <- from; obj},
                       list(FROMCLASS = fromClass, TOCLASS = toClass))
        f
    }
    else
        NULL

}



"as<-" <-
  ## Set the portion of the object defined by the right-hand side.
  ##
  ## Typically, the object being modified extends the class of the right-hand side object,
  ## and contains the slots of that object. These slots (only) will then be replaced.
  function(object, Class, value) {
    thisClass <- .class1(object)
    if(!.identC(.class1(value), Class))
      value <- as(value, Class, strict = FALSE)
    where <- .classEnv(class(object))
    coerceFun <- getGeneric("coerce<-", where = where)
    coerceMethods <- getMethodsForDispatch(coerceFun)
    asMethod <- .quickCoerceSelect(thisClass, Class, coerceFun, coerceMethods, where)
    if(is.null(asMethod)) {
        sig <-  c(from=thisClass, to = Class)
        canCache <- TRUE
        inherited <- FALSE
        asMethod <- selectMethod("coerce<-", sig, TRUE, FALSE, #optional, no inheritance
                                 fdef = coerceFun, mlist = coerceMethods)
        if(is.null(asMethod)) {
            if(is(object, Class)) {
                asMethod <- possibleExtends(thisClass, Class)
                if(identical(asMethod, TRUE)) {# trivial, probably identical classes
                    class(value) <- class(object)
                    return(value)
                }
                else {
                    test <- asMethod@test
                    asMethod <- asMethod@replace
                    canCache <- (!is(test, "function")) || identical(body(test), TRUE)
                    if(canCache) { ##the replace code is a bare function
                        ClassDef <- getClassDef(Class, where)
                        asMethod <- .asCoerceMethod(asMethod, thisClass, ClassDef, TRUE, where)
                    }
                }
            }
            else { # search for inherited method
              asMethod <- selectMethod("coerce<-", sig, TRUE, c(from = TRUE, to = FALSE), doCache = TRUE)
              inherited <- TRUE
            }
        }
        ## cache for next call
        if(canCache && !is.null(asMethod))
                 cacheMethod("coerce<-", sig, asMethod, fdef = coerceFun,
                             inherited = inherited)
     }
    if(is.null(asMethod))
        stop(gettextf("no method or default for as() replacement of %s with Class=\"%s\"",
                      dQuote(thisClass),
                      Class),
             domain = NA)
    asMethod(object, Class, value)
}



setAs <-
  function(from, to, def, replace = NULL, where = topenv(parent.frame()))
{
    ## where there is an "is" relation, modify it
    fromDef <- getClassDef(from, where)
    extds <- possibleExtends(from, to, fromDef)
    if(is(extds, "SClassExtension")) {
        test <- extds@test
        if(is.null(replace))
            replace <- extds@replace
        test <- NULL
        setIs(from, to, test = test, coerce = def, replace = replace, where = where)
    }
    else if(identical(extds, TRUE)) {
        if(.identC(from, to))
            stop(gettextf("trying to set an 'as' relation from %s to itself",
                          dQuote(.class1(from))),
                 domain = NA)
        ## usually to will be a class union, where setAs() is not
        ## allowed by the definition of a union
        toDef <- getClassDef(to, where=where)
        if(is.null(toDef))
            stop(gettextf("class %s is not defined in this environment",
                          dQuote(to)),
                 domain = NA)
        if(isClassUnion(toDef))
            stop(gettextf("class %s is a class union: 'coerce' relations to a class union are not meaningful",
                          dQuote(to)),
                 domain = NA)
        ## else go ahead (but are there any cases here where extds is TRUE?)
        setIs(from, to, coerce = def, replace = replace, where = where)
    }
    ## else extds is FALSE -- no is() action
        args <- formalArgs(def)
        if(!is.na(match("strict", args))) args <- args[-match("strict", args)]
        if(length(args) == 1)
            def <- substituteFunctionArgs(def, "from", functionName = "coerce")
        else  if(length(args) != 2 || !identical(args, c("from", "to")))
               stop(gettextf("'as' method should have one argument, or match the arguments of coerce(): got  (%s)",
                           paste(formalArgs(def), collapse = ", ")),
                  domain = NA)
    ## coerce@.Data is the "prototype" from which we construct the method
        method <- as.list(coerce@.Data) # the function def'n, just to get arguments correct
        method$to <- to
        method <- as.function(method)
        body(method, envir = environment(def)) <- body(def)
        setMethod("coerce", c(from, to), method, where = where)
        if(!is.null(replace)) {
            args <- formalArgs(replace)
            if(identical(args, c("from", "to", "value")))
                method <- replace
            else {
                ## if not from an extends object, process the arguments
                if(length(args) != 2)
                    stop(gettextf("a 'replace' method definition in 'setAs' must be a function of two arguments, got %d", length(args)), domain = NA)
                replace <- body(replace)
                if(!identical(args, c("from", "value"))) {
                    ll <- list(quote(from), quote(value))
                    names(ll) <- args
                    replace <- substituteDirect(replace, ll)
                    warning(gettextf("argument names in 'replace' changed to agree with 'coerce<-' generic:\n%s", paste(deparse(replace), sep="\n    ")),
                            domain = NA)
                }
                method <- eval(function(from, to, value)NULL)
                functionBody(method, envir = .GlobalEnv) <- replace
            }
            setMethod("coerce<-", c(from, to), method, where = where)
        }
}

.setCoerceGeneric <- function(where) {
  ## create the initial version of the coerce function, with methods that convert
  ## arbitrary objects to the basic classes by calling the corresponding as.<Class>
  ## functions.
  setGeneric("coerce", function(from, to, strict = TRUE) {
      if(TRUE) {
          warning("direct use of coerce() is deprecated:  use as(from, class(to)) instead", domain = NA)
          return(as(from, class(to), strict = strict))
      }
      standardGeneric("coerce")
      },
             where = where)
  setGeneric("coerce<-", function(from, to, value) {
      if(TRUE) {
          warning("direct use of coerce() is deprecated:  use as(from, class(to)) <- value instead", domain = NA)
          return(`as<-`(from, class(to), value))
      }
      standardGeneric("coerce<-")
      }, where = where)
  basics <- c(
 "POSIXct",  "POSIXlt", "Date",  "array",  "call",  "character",  "complex",  "data.frame",
 "environment",  "expression",  "factor",  "formula",  "function",  "integer",
 "list",  "logical",  "matrix",  "name",  "numeric",  "ordered",
  "single",  "table",   "vector")
  basics <- basics[!is.na(match(basics,.BasicClasses))]
  for(what in basics) {
      ## if the class is a basic class and there exists an as.<class> function,
      ## use it as the coerce method.
      method  <- .basicCoerceMethod
      switch(what,
	     array =, matrix = body(method, envir = environment(method)) <-
	     substitute({
		 value <- AS(from)
		 if(strict) {
		     dm <- dim(value)
		     dn <- dimnames(value)
		     attributes(value) <- NULL
		     dim(value) <- dm
		     dimnames(value) <- dn
		 }
		 value
	     }, list(AS = as.name(paste0("as.", what)))),
	     ##
	     ts = body(method, envir = environment(method)) <- quote({
		 value <- as.ts(from)
		 if(strict) {
		     attributes(value) <- NULL
		     class(value) <- class(new("ts"))
		     tsp(value) <- tsp(from)
		 }
		 value
	     }),
	     ## default: no attributes
	     body(method, envir = environment(method)) <- substitute({
		 value <- AS(from)
		 if(strict)
		     attributes(value) <- NULL
		 value
	     }, list(AS = as.name(paste0("as.", what))))
	     )
      setMethod("coerce", c("ANY", what), method, where = where)
  }
  ## and some hand-coded ones
  body(method) <- quote(as.null(from))
  setMethod("coerce", c("ANY", "NULL"), method, where = where)
  body(method) <- quote({
            if(length(from) != 1)
                warning("ambiguous object (length != 1) to coerce to \"name\"")
            as.name(from)
        })
  setMethod("coerce", c("ANY","name"), method, where = where)
  ## not accounted for and maybe not needed:  real, pairlist, double
}

.basicCoerceMethod <- function(from, to, strict = TRUE)
    stop("undefined 'coerce' method")

.makeAsMethod <- function(expr, simple, Class, ClassDef, where) {
    if(is(expr, "function")) {
        where <- environment(expr)
        args <- formalArgs(expr)
        if(!identical(args, "from"))
            expr <- .ChangeFormals(expr,
                    if(length(args) > 1) .simpleExtCoerce else .simpleIsCoerce)
        expr <- body(expr)
    }
    ## commented code below is needed if we don't assume asMethod sets the class correctly
#     if(isVirtualClass(ClassDef))
#         value <- expr
#     else if(identical(expr, quote(from)))
#         value <- substitute({class(from) <- CLASS; from},
#                            list(CLASS = Class))
#     else value <- substitute({from <- EXPR; class(from) <- CLASS; from},
#                            list(EXPR = expr, CLASS = Class) )
    ## else
    value <- expr
    if(simple && !identical(expr, quote(from)))
        value <- substitute(if(strict) EXPR else from,
                           list(EXPR = expr))
    f <- .simpleExtCoerce
    body(f, envir = where) <- value
    f
}

## check for and remove a previous coerce method.  Called from setIs
## We warn if the previous method seems to be from a
## setAs(), indicating a conflicting setIs() A previous
## version of setIs is OK, but we remove the methods anyway to be safe.
## Definitions are only removed from the current function's environment,
## not from a permanent copy.
.removePreviousCoerce <- function(from, to, where, prevIs) {
    sig <- c(from, to)
    cdef <- getGeneric("coerce", where = where)
    if(is.null(cdef))
        return(FALSE) # only for booting the methods package?
    prevCoerce <- !is.null(selectMethod("coerce", sig, TRUE, FALSE,
                                        fdef = cdef))
    rdef <- getGeneric("coerce<-", where = where)
    if(is.null(rdef))
        return(FALSE) # only for booting the methods package?
    prevRepl <- !is.null(selectMethod("coerce<-", sig, TRUE, FALSE,
                                      fdef = rdef))
    if(prevCoerce || prevRepl) {
        if(!prevIs)
            warning(gettextf("methods currently exist for coercing from %s to %s; they will be replaced.",
                             dQuote(from),
                             dQuote(to)),
                    domain = NA)
        if(prevCoerce)
            setMethod(cdef, sig, NULL, where = baseenv())
        if(prevRepl)
            setMethod(rdef, sig, NULL, where = baseenv())
        TRUE
    }
    else
        FALSE

}

canCoerce <- function(object, Class) {
    is(object, Class) ||
    !is.null(selectMethod("coerce", c(class(object), Class),
			  optional = TRUE,
			  useInherited = c(from=TRUE, to=FALSE)))
}

## turn raw function into method for coerce() or coerce<-()
## Cheats a little to get past booting the methods package
## (mainly in knowing the slots of the "signature" class).
.asCoerceMethod <- function(def, thisClass, ClassDef, replace, where) {
    fdef <-
	if(replace) quote(function(from, to = TO, value) NULL)
	else	    quote(function(from, to = TO, strict = TRUE) NULL)
    fdef[[2L]]$to <- ClassDef@className
    fdef <- eval(fdef)
    body(fdef, environment(def)) <- body(def)
    attr(fdef, "source") <- deparse(fdef) # because it's wrong from the quote()
    sig <- new("signature")
    sig@.Data <- c(thisClass, ClassDef@className)
    sig@names <- c("from", "to")
    thisPackage <- packageSlot(thisClass)
    sig@package <- if(is.null(thisPackage))
        c(getPackageName(where, FALSE), ClassDef@package) else
        c(thisPackage, ClassDef@package)
    value <- new("MethodDefinition")
    value@.Data <- fdef
    value@target <- sig
    value@defined <- sig
    value@generic <- structure( #FIXME: there should be a genericName()
                if(replace) "coerce<-" else "coerce", package = "methods")
    value
}