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

## assumes oldClass has been defined as a virtual class

setOldClass <- function(Classes, prototype = NULL,
                        where = topenv(parent.frame()), test = FALSE,
                        S4Class) {
    simpleCase <- is.null(prototype)
    mainClass <- Classes[[1L]]
    prevDef <- getClassDef(mainClass, where, inherits = FALSE)
    if(!missing(S4Class)) {
        if(test)
          stop("not allowed to have test==TRUE and an S4Class definition")
        if(!is(S4Class, "classRepresentation")) {
            if(is.character(S4Class)) {
                clName <- S4Class
                S4Class <- getClass(S4Class)
                if(.identC(clName, Classes[[1L]]))
                  removeClass(clName, where = where) # so Recall() will work
            }
            else
              stop(gettextf("argument 'S4Class' must be a class definition: got an object of class %s",
                            dQuote(class(S4Class))),
                   domain = NA)
        }
        if(!is.null(prototype)) {
            S4prototype <- S4Class@prototype
            ## use the explicit attributes from the supplied argument, else S4prototype
            S4Class@prototype <- .mergeAttrs(prototype, S4prototype)
        }
        ## register simple S3 class(es), including main class, if it's not defined already
        Recall(Classes, where = where)
        return(.S4OldClass(Classes[[1L]], if(length(Classes) > 1) Classes[[2L]] else "oldClass", S4Class, where, prevDef))
    }
    if(test)
        return(.setOldIs(Classes, where))
    if(!is.null(prevDef)) {
        on.exit(.restoreClass(prevDef, where))
        removeClass(mainClass, where = where) # so Recall() will work
    }
    prevClass <- "oldClass"
    S3Class <- character()  #will accumulate the S3 classes inherited
    ## The table of S3 classes, used
    ## to convert S4 objects in S3 method dispatch.
    ## TODO:  should provide an optional argument to setOldClass()
    ## to prevednt this conversion if it's not needed
    if(is.null(S3table <- where$.S3MethodsClasses)) {
      S3table <- new.env()
      assign(".S3MethodsClasses", S3table, envir = where)
    }
    dataPartClass <- NULL
    for(cl in rev(Classes)) {
       S3Class <- c(cl, S3Class)
        if(isClass(cl, where)) {
            def <- getClass(cl, where)
            if(!extends(def, prevClass)) {
                ## maybe an object type or other valid data part
                cl1 <- .validDataPartClass(cl, where, dataPartClass)
                if(is.null(cl1))
                  stop(gettextf("inconsistent old-style class information for %s; the class is defined but does not extend %s and is not valid as the data part",
                                dQuote(cl),
                                dQuote(prevClass)),
                       domain = NA)
                else dataPartClass <- cl1
              }
            else {
              prevP <- def@prototype
              if(missing(prototype))
                prototype <- prevP # keep track of inherited prototype for use in mainClass
              prevS3Class <- attr(prevP, ".S3Class")
              if(length(prevS3Class) > length(S3Class)) #implies cl is registered S3 class
                S3Class <- prevS3Class
            }
        }
        else {
            useP <- TRUE
            if(cl != mainClass || simpleCase) {
                setClass(cl, contains = c(prevClass, "VIRTUAL"), where = where)
            }
            else if(isClass(class(prototype)))
                setClass(cl, contains = prevClass, prototype = prototype, where = where)
            else { #exceptionally, we allow an S3 object from the S3 class as prototype
                if(.class1(prototype) != mainClass)
                  stop(gettextf('the S3 class of the prototype, "%s", is undefined; only allowed when this is the S3 class being registered ("%s")', .class1(prototype), mainClass), domain = NA)
                setClass(cl, contains = prevClass, where = where)
                useP <- FALSE
            }
            def <- getClassDef(cl, where)
            if(useP) clp <- def@prototype else clp <- prototype
            attr(clp, ".S3Class") <- S3Class
            def@prototype <- .notS4(clp)
            assignClassDef(cl, def, where = where)
            ## add the class to the table of S3 classes
            assign(cl, def, envir= S3table)
        }
       prevClass <- cl
    }
    if(!is.null(prevDef)) # cancel error action
      on.exit()
}

.restoreClass <- function(def, where) {
    cl <- def@className
    message(gettextf("restoring definition of class %s", dQuote(cl)),
            domain = NA)
    if(isClass(cl, where = where))
       removeClass(cl, where = where)
    assignClassDef(cl, def, where = where)
}

.S4OldClass <- function(Class, prevClass, def,where, prevDef) {
    ## def is the S4 version of this class def'n, maybe by another class
    ## name, and may or may not already extend oldClass
    curDef <- getClassDef(Class, where) # asserted to be defined
    ## arrange to restore previous definition if there was one.  Also done in setOldClass
    ## when no S4Class argument supplied
    if(!is.null(prevDef)) {
        on.exit(.restoreClass(prevDef, where))
        removeClass(Class, where = where) # so Recall() will work
    }
    if(!identical(def@className, curDef@className))
      def <- .renameClassDef(def, curDef@className)
    ## check that any common slots will give a valid S3 object
    .validS3Extends(def, curDef)
    def@slots[names(curDef@slots)] <- curDef@slots
    ext <- c(def@contains, curDef@contains)
    ## correct ordering & duplicate resolution: copied from .walkClassGraph
    distOrder <- sort.list(vapply(ext, function(x) x@distance, 1))
    ext <- ext[distOrder]
    if(anyDuplicated(names(ext)))
        ext <- .resolveSuperclasses(def, ext, where)
    def@contains <- ext
    oldSupers <- setdiff(names(def@contains), names(curDef@contains))
    addSubclass <- function(super) {
      superDef <- getClassDef(super, where)
      superWhere <- .findOrCopyClass(super, superDef, where, "subclass")
      superDef@subclasses[[Class]] <- def@contains[[super]]
      assignClassDef(super, superDef, superWhere, TRUE)
    }
    lapply(oldSupers, addSubclass)
    subcls <- curDef@subclasses
    if(length(subcls) > 0) {
      def@subclasses[names(subcls)]  <- subcls
    }
    proto <- def@prototype
    if(is.null(attr(proto, ".S3Class"))) { # no S3 class slot, as will usually be true
        attr(proto, ".S3Class") <- if(.identC(prevClass, "oldClass")) Class else S3Class(curDef@prototype)
        def@prototype <- proto
    }
    assignClassDef(Class, def, where = where)
    ## allow an existing superclass relation to remain (it may have a coerce method)
    ## Otherwise, create a simple transformation, which relies on consistency
    ## in the slots.
    if(!extends(def, prevClass, maybe = FALSE))
      setIs(Class, prevClass, classDef = def, where = where)
    slotsMethod <- function(object) NULL
    body(slotsMethod) <- substitute({LIST}, list(LIST = def@slots))
    setMethod("slotsFromS3", Class, slotsMethod, where = where)
    if(!is.null(prevDef)) # cancel error action
      on.exit()
}

.validS3Extends <- function(classDef1, classDef2) {
    slots2 <- classDef2@slots
    if(length(slots2) > 0) {
        n2 <- names(slots2)
        slots1 <- classDef1@slots
        n1 <- names(slots1)
        bad <- character()
        for(what in n2[match(n2, n1, 0) > 0])
          if(!extends(slots1[[what]], slots2[[what]])) {
              message(gettextf("slot %s: class %s should extend class %s",
                               sQuote(what),
                               dQuote(slots1[[what]]),
                               dQuote(slots2[[what]])),
                      domain = NA)
              bad <- c(bad, what)
          }
        if(length(bad)>0)
          stop(
               gettextf("invalid S4 class corresponding to S3 class: slots in  S4 version must extend corresponding slots in S3 version: fails for %s",
                        paste0('"', bad, '"',  collapse = ", ")),
               domain = NA)
    }
    TRUE
}

##.initS3Classes will make this generic, with a method for "oldClass"
slotsFromS3 <- function(object) {
    list()
}

utils::globalVariables("CLASS")

.oldTestFun <- function(object) CLASS %in% attr(object, "class")
.oldCoerceFun <- function(from, strict = TRUE) {
    if(strict)
        stop(gettextf("explicit coercion of old-style class (%s) is not defined", paste(class(from), collapse = ", ")), domain = NA)
    from
}
.oldReplaceFun <- function(from, to, value)
    stop(gettextf("explicit replacement not defined for as(x, \"%s\") <- value for old-style class %s",
                  to, dQuote(class(from)[1L])),
         domain = NA)

## the inheritance of these S3 classes must be decided on a per-instance
## basis.  At one time, there were classes in base/stats that had this
## property, (e.g., POSIXt, POSIX{cl}t) but apparently no longer.
## The possibility is still allowed
## for user-defined S3 classes.
.setOldIs <- function(Classes, where) {
    if(length(Classes) != 2)
        stop(gettextf("argument 'Classes' must be a vector of two classes; got an argument of length %d", length(Classes)), domain = NA)
    for(cl in Classes) {
        if(isClass(cl, where)) {
            if(!extends(cl, "oldClass"))
                warning(gettextf("inconsistent old-style class information for %s (maybe mixing old and new classes?)",
                                 dQuote(cl)), domain = NA)
        }
        else
            setClass(cl, representation("oldClass", "VIRTUAL"), where = where)
    }
    Class1 <- Classes[[1L]]
    for(cl in Classes[-1L]) {
        tfun <- .oldTestFun
        body(tfun, envir = environment(tfun)) <-
            substitute(inherits(object, CLASS), list(CLASS = cl))
        setIs(Class1, cl, test = tfun, coerce = .oldCoerceFun,
              replace = .oldReplaceFun, where = where)
    }
    NULL
}

isXS3Class <- function(classDef) {
    ".S3Class" %in% names(classDef@slots)
}

S3Class <- function(object) {
    value <- attr(object, ".S3Class")
    if(is.null(value)) {
        if(isS4(object)) {
            if(is.na(match(".Data", names(getClass(class(object))@slots))))
                stop(gettextf("'S3Class' only defined for extensions of %s or classes with a data part:  not true of class %s",
                              dQuote("oldClass"),
                              dQuote(class(object))),
                     domain = NA)
            class(getDataPart(object))
        }
        else
          class(object)
    }
    else
      value
}

.S3Class <- S3Class # alias for functions with S3Class as an argument

.addS3Class <- function(class, prototype, contains, where) {
    for(what in contains) {
        whatDef <- getClassDef(what@superClass, package=packageSlot(what))
        if(isXS3Class(whatDef))
          class <- c(class, attr(whatDef@prototype, ".S3Class"))
    }
    attr(prototype, ".S3Class") <- unique(class)
    prototype
}

"S3Class<-" <- function(object, value) {
    if(isS4(object)) {
        current <- attr(object, ".S3Class")
        if(is.null(current)) {
            if(is.na(match(value, .BasicClasses)))
               stop(gettextf("'S3Class' can only assign to S4 objects that extend \"oldClass\"; not true of class %s",
                             dQuote(class(object))),
                    domain = NA)
            mode(object) <- value ## may still fail, a further check would be good
        }
        else
          slot(object, ".S3Class") <- value
    }
    else
      class(object) <- value
    object
}

## rename a class definition:  needs to change if any additional occurences of class
## name are added, other than the className slot and the super/sub class names
## in the contains, subclasses slots respectively.
.renameClassDef <- function(def, className) {
##    oldName <- def@className
    validObject(def) # to catch any non-SClassExtension objects
    def@className <- className
    comp <- def@contains
    for(i in seq_along(comp))
        comp[[i]]@subClass <- className
    def@contains <- comp
    comp <- def@subclasses
    for(i in seq_along(comp))
        comp[[i]]@superClass <- className
    def@subclasses <- comp
    def
}

## extends() w/o conditional inheritance:  used for S3 inheritance, method
## selection on S4 objects
..extendsForS3 <- function(Class)
    extends(Class, maybe = FALSE)
## dummy version while generating methods package
.extendsForS3 <- function(Class)
    extends(Class)