#  File src/library/methods/R/ClassExtensions.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2018 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
#  https://www.R-project.org/Licenses/

.InitExtensions <- function(where) {
    ## to be called from the initialization
    setClass("SClassExtension",
	     representation(subClass = "character", superClass = "character",
			    package = "character", coerce = "function",
			    test = "function", replace = "function",
			    simple = "logical", by = "character",
			    dataPart = "logical", distance = "numeric"),
	     where = where)
    ## a class for conditional extensions, so they will not break the hierarchical
    ## structure.
    setClass("conditionalExtension", contains = "SClassExtension")
    assign(".SealedClasses", c(get(".SealedClasses", where), "SClassExtension",
                               "conditionalExtension"),
	   where)
}

.simpleExtCoerce <- function(from, strict = TRUE)from
.simpleIsCoerce <- function(from)from
.simpleExtTest <- function(object)TRUE
## TO DO:  the simple replace below only handles the case of classes with slots.
## There are some other simple relations (e.g., with virtual classes).  Replacing in
## these cases is less likely but needs to be tested (below) and a suitable
## replace function inserted.
.simpleExtReplace <- function(from, to, value){
    for(what in .InhSlotNames(to))
        slot(from, what) <- slot(value, what)
    from
}
## slot names for inheritance (to be used in replace methods).  Extends slots to implicit
## .Data for basic classes.
.InhSlotNames <- function(Class) {
   ClassDef <- getClass(Class)
    value <- names(ClassDef@slots)
    if(length(value)==0 && (Class %in% .BasicClasses || extends(ClassDef, "vector")))
        ## No slots, but extends "vector" => usually a basic class; treat as data part
        value <- ".Data"
   value
}
.dataPartReplace <- list(f1 = function(from, to, value){
    from@.Data <- value
    from
},

f2 = function(from, to, value){
    from@.Data <- as(value, THISCLASS, strict = FALSE)
    from
},

## and a version of dataPartReplace w/o the unused `to' argument
f2args = function(from, value) {
    from@.Data <- value
    from
})

S3Part <- function(object, strictS3 = FALSE, S3Class) {
    if(!isS4(object))
      return(object)
    classDef <- getClass(class(object))
    oldClassCase <- extends(classDef, "oldClass")
    defltS3Class <- missing(S3Class)
    if(oldClassCase) {
        if(defltS3Class)
            S3Class <- .S3Class(object)
        keepSlots <- slotNames(S3Class[[1L]])
     }
    else {
        if(all(is.na(match(extends(classDef), .BasicClasses))))
          stop(gettextf("S3Part() is only defined for classes set up by setOldCLass(), basic classes or subclasses of these:  not true of class %s", dQuote(class(object))), domain = NA)
        if(missing(S3Class)) {
            S3Class <- classDef@slots$.Data
            if(is.null(S3Class)) # is this an error?
              S3Class <- typeof(object)
            keepSlots <- character()
        }
        else
          keepSlots <- slotNames(S3Class[[1L]])
    }
    if(!(defltS3Class || extends(classDef, S3Class)))
      stop(gettextf("the 'S3Class' argument must be a superclass of %s:  not true of class %s", dQuote(class(object)), dQuote(S3Class)), domain = NA)
    if(strictS3)
      keepSlots <- keepSlots[is.na(match(keepSlots, ".S3Class"))]
    deleteSlots = slotNames(classDef)
    deleteSlots <- deleteSlots[is.na(match(deleteSlots,keepSlots))]
    for(slot in deleteSlots)
      attr(object, slot) <- NULL
    if(strictS3) {
        object <- .notS4(object)
        class(object) <- S3Class
    }
    else
      class(object) <- S3Class[[1L]]
    object
}

"S3Part<-" <- function(object, strictS3 = FALSE, needClass = .S3Class(object) , value) {
    S3Class <- .S3Class(value)
    def <- getClassDef(S3Class[[1L]])
    if(is.null(def) || !extends(def, needClass[[1L]]))
      stop(gettextf("replacement value must extend class %s, got %s", dQuote(needClass), dQuote(S3Class[[1L]])), domain = NA)
    slots <- slotNames(class(object))
    if(!strictS3) {
        fromValue <- names(attributes(value))
        slots <- slots[is.na(match(slots, fromValue))]
    }
    slots <- c("class", slots)  # always preserve class(object)
    for(slot in slots)
      attr(value, slot) <- attr(object, slot)
    if(extends(def, "oldClass"))
      attr(value, ".S3Class") <- S3Class
    if(isS4(object))
      value <- .asS4(value)
    value
}

## templates for replacement methods for S3 classes in classes that extend oldClass
.S3replace <-
    list(e1 =
         quote( {
             S3Part(from, needClass = NEED) <- value
             from
         }),
         e2 = quote( {
             if(is(value, CLASS)) {
                 S3Part(from,  needClass = NEED) <- value
                 from
             }
             else
                 stop(gettextf("replacement value must be of class %s, got one of class %s",
                               dQuote(CLASS),
                               dQuote(class(value)[[1L]])))

         })
         )

.S3coerce <- function(from, to) {
    S3Part(from)
}

.ErrorReplace <- function(from, to, value)
    stop(gettextf("no 'replace' method was defined for 'as(x, \"%s\") <- value' for class %s",
                  to, dQuote(class(from))), domain = NA)

.objectSlotNames <- function(object) {
    ## a quick version that makes no attempt to check the class definition
    value <- names(attributes(object))
    if(is.null(value)) ## not possible with methods package?
        character()
    else
        value[-match("class", value, 0L)]
}

makeExtends <- function(Class, to,
                        coerce = NULL, test = NULL, replace = NULL,
                        by = character(), package,
                        slots = getSlots(classDef1),
                        classDef1 = getClass(Class), classDef2) {
    ## test for datapart class:  must be the data part class, except
    ## that extensions within the basic classes are allowed (numeric, integer)
    dataEquiv <- function(cl1, cl2) {
        .identC(cl1, cl2) ||
          (extends(cl1, cl2) && !any(is.na(match(c(cl1, cl2), .BasicClasses))))
    }
    packageEnv <- .requirePackage(package)
    class1Defined <- missing(slots) # only at this time can we construct methods
    simple <- is.null(coerce) && is.null(test) && is.null(replace) && (length(by)==0)
    distance <- 1
    ##FIX ME:  when by is supplied, should use the existing extension information
    ## to compute distance
    dataPartClass <- elNamed(slots, ".Data") # This seems to be the only elNamed that has to stay
    dataPart <- FALSE
    if(simple && !is.null(dataPartClass)) {
        if(!(is.null(getClassDef(dataPartClass)) || is.null(getClassDef(to)))) {
            ## note that dataPart, to are looked up in the methods package & parents,
            ## because the default in getClassDef is the topenv of the caller (this fun.):
            ## Assertion is that only these classes are allowed as data slots
            dataPart <- dataEquiv(dataPartClass, to)
        }
    }
    if(is.null(coerce)) {
        coerce <- .simpleExtCoerce
        if(isXS3Class(classDef2)) {
##            allNames <- names(slots)
            body(coerce, envir = packageEnv) <-
                substitute({
                    if(strict) S3Part(from, S3Class = S3CLASS)
                    else from
                }, list(S3CLASS =  to))
        }
        else if(!isVirtualClass(classDef2))
            body(coerce, envir = packageEnv) <-
                 .simpleCoerceExpr(Class, to, names(slots), classDef2)
    }
    else if(is.function(coerce)) {
        ## we allow definitions with and without the `strict' argument
        ## but create a  function that can be called with the argument
        if(length(formals(coerce)) == 1) {
            coerce <- .ChangeFormals(coerce, .simpleIsCoerce, "'coerce' argument to setIs ")
            tmp <- .simpleExtCoerce
            body(tmp, envir = environment(coerce)) <- body(coerce)
            coerce <- tmp
        }
        else
            coerce <- .ChangeFormals(coerce, .simpleExtCoerce, "'coerce' argument to setIs ")

    }
    else stop(gettextf("the 'coerce' argument to 'setIs' should be a function of one argument, got an object of class %s",
                       dQuote(class(coerce))), domain = NA)
    if(is.null(test)) {
        test <- .simpleExtTest
        extClass <- "SClassExtension"
    }
    else {
        test <- .ChangeFormals(test, .simpleExtTest, "'test' argument to setIs ")
        extClass <- "conditionalExtension"
    }
    if(is.null(replace)) {
        if(dataPart) {
            extn <- classDef2@contains[[dataPartClass]]
            if(is(extn, "SClassExtension"))
                easy <- extn@simple
            else
                easy <- FALSE
            if(easy)
                replace <- .dataPartReplace$f1
            else {
                replace <- .dataPartReplace$f2
                bdy <- body(replace)
                body(replace, envir = environment(replace)) <-
                    substituteDirect(bdy, list(THISCLASS = dataPartClass))
            }
        }
        else if(simple) {
            replace <- .simpleExtReplace
            if(isXS3Class(classDef2)) {  # replace the S3 part & slots in class to
                S3Class <- attr(classDef2@prototype, ".S3Class")
                if(is.null(S3Class)) # the setOldClass case ?
                  S3Class <- to
                body(replace, envir = packageEnv) <-
                  quote({
                      S3Part(from) <- value
                      from
                  })
            }
            else if(isVirtualClass(classDef2)) {  # a simple is to a virtual class => a union
                body(replace, envir = packageEnv) <-
                    substitute({
                        if(!is(value, TO))
                            stop(gettextf("the computation: 'as(object,\"%s\") <- value' is valid when object has class %s only if 'is(value, \"%s\")' is TRUE ('class(value)' was %s)\n",
                                 TO, dQuote(FROM), TO, dQuote(class(value))), domain = NA)
                        value
                    }, list(FROM = Class, TO = to))
            }
            else if(class1Defined && length(slots) == 0) {
                ## check for the classes having the same representation
                ## (including the case of no slots)
                ext <- getAllSuperClasses(classDef1, TRUE)
                toSlots <- classDef2@slots
                sameSlots <- TRUE
                for(eclass in ext) {
                    ## does any superclass other than "to" have slots?
                    if(.identC(eclass, to))
                        next
                    edef <- getClassDef(eclass, where = packageEnv)
                    if(!is.null(edef) && length(edef@slots) > 0) {
                        sameSlots <- FALSE
                        break
                    }
                }
                if(sameSlots)
                    body(replace, envir = packageEnv) <-
                        substitute({class(value) <- FROM; value}, list(FROM = Class))
                else if(length(toSlots) == 0) # seems replacement not defined in this case?
                    replace <- .ErrorReplace
            }
            else
                body(replace, envir = packageEnv) <-
                    .simpleReplaceExpr(classDef2)
        }
        else
            replace <- .ErrorReplace
        if(identical(replace, .ErrorReplace))
            warning(gettextf("there is no automatic definition for 'as(object, \"%s\") <- value' when object has class %s and no 'replace' argument was supplied; replacement will be an error",
                             to, dQuote(Class)), domain = NA)
    }
    else if(is.function(replace)) {
        ## turn function of two or three arguments into correct 3-arg form
        if(length(formals(replace)) == 2) {
            replace <- .ChangeFormals(replace, .dataPartReplace$f2args, "'replace' argument to setIs ")
            tmp  <- .ErrorReplace
            body(tmp, envir = environment(replace)) <- body(replace)
            replace <- tmp
        }
        else
            replace <- .ChangeFormals(replace, .ErrorReplace, "'replace' argument to setIs ")
    }
    else
        stop(gettextf("the 'replace' argument to setIs() should be a function of 2 or 3 arguments, got an object of class %s",
                      dQuote(class(replace))), domain = NA)

    new(extClass, subClass = Class, superClass = to, package = package,
	coerce = coerce, test = test, replace = replace, simple = simple,
	by = by, dataPart = dataPart, distance = distance)
}

.findAll <- function(what, where = topenv(parent.frame())) {
    ## search in envir. & parents thereof
    ## For namespaces, this follows R's soft namespace policy
    ## by not stopping when it reaches the basenamespace
    ## The code used to do so and then had a kludge for looking
    ## in the methods namespace.  But that failed anyway on
    ## non-namespace (package) environments and was inconsistent
    ## with the normal R lookup with namespace environments.
    value <- list()
    if(is.environment(where)) {
        if(isNamespace(where)) repeat {
            if(exists(what, where, inherits = FALSE))
                value <- c(value, list(where))
            if(identical(where, emptyenv()))
                break
            where <- parent.env(where)
        }
        else {  # typically, a package environment: look here, then in the search list
            if(exists(what, where, inherits = FALSE))
                value <- c(value, list(where))
            for(i in seq_along(search())) {
                if(exists(what, i, inherits = FALSE)) {
                    evi <- as.environment(i)
                    addMe<- TRUE
                    for(other in value)
                        if(identical(other, evi)) {
                            addMe <- FALSE
                            break
                        }
                    if(addMe)
                        value <- c(value, list(evi))
                }
            }
        }
    }
    else
        for(i in where) {
            if(exists(what, i, inherits = FALSE))
                value <- c(value, list(i))
        }
    value
}

.S4inherits <- function(x, what, which) {
    superClasses <- extends(getClass(class(x)))
    if(which)
       match(what, superClasses, 0L)
    else
      what %in% superClasses
}

## find the S3 classes or their extensions in the indirect superclasses
## and give them the correct coerce and replacement methods
.S3Extends <- function(ClassDef, exts, where) {
    superClasses <- names(exts)
    S3Class <- attr(ClassDef@prototype, ".S3Class")
    need <- S3Class[[1L]]
    for(i in seq_along(exts)) {
        exti <- exts[[i]]
        if(exti@distance == 1)
            next # asserted that this was done by makeExtends
        what <- superClasses[[i]]
        whatDef <- getClassDef(what, package=packageSlot(exti))
        if(is.null(whatDef) # but shouldn't happen,
           || !isXS3Class(whatDef))
            next
        coerce <- exti@coerce
        body(coerce, environment(coerce))<- body(.S3coerce)
        exti@coerce <- coerce
        replace <- exti@replace
        pos <- match(what, S3Class, 0L)
        if(pos > 1) # not the complete S3 class, probably an error
          body(replace, environment(replace)) <-
            substituteDirect(.S3replace$e2, list(CLASS = what, NEED = need))
        else
          body(replace, environment(replace))  <-
            substituteDirect(.S3replace$e1, list(NEED = need))
        exti@replace <- replace
        exts[[i]] <- exti
    }
    exts
}