setClass("InterfaceRepresentation",
         representation=representation(.slots="list"))

.slots <- function(object, ...)
    slot(object, ".slots")

setValidity("InterfaceRepresentation", function(object) {
    msg <- NULL
    slots <- .slots(object)
    if (length(slots)==0)
        msg <- c(msg, "interfaces must have slots defined")
    ok <- sapply(slots, is, "function")
    if (!all(ok))
        msg <- c(msg, "all slots must be functions")
    ## FIXME: other checks
    if (is.null(msg)) TRUE else msg
})

.InterfaceRepresentation <- function(...) {
    new("InterfaceRepresentation", .slots=list(...))
}

.interfaces <- new.env(parent=emptyenv())

setInterface <- function(interface, ...) {
    slots <- list(...)
    .interfaces[[interface]] <- .InterfaceRepresentation(...)
    setClass(interface,
             contains="Implementation",
             representation=representation("VIRTUAL"))
    invisible(.interfaces[[interface]])
}

## FIXME: get, show for InterfaceRepresentation

.implementationMangler <- function(class, interface, ...)
    paste(".__I__", interface, ":", class, sep="")

.implementationDemangler <- function(name, ...) {
    parts <- strsplit(name, "[_:]")[[1]][5:6]
    paste("implements '", parts[[1]], "' of class '", parts[[2]], "'",
          sep="")
}

setClass("Implementation")

setMethod("$", "Implementation", function(x, name) {
    ## FIXME: enforce 'name' as member of interface
    slot(x, name)
})

setMethod(show, "Implementation", function(object) {
    cat("class:", .implementationDemangler(class(object)), "\n")
    cat("interface:\n")
    nms <- slotNames(object)
    args <- lapply(nms, function(elt) {
        frmls <- formals(slot(object, elt))
        paste(names(frmls), as.character(frmls), sep="=", collapse=", ")
    })
    cat(paste("  ", nms, "(", args, ")\n", sep="", collapse=""))
})

setImplementation <- function(Class, interface, ...) {
    if (!exists(interface, .interfaces))
        stop("undefined interface '", interface, "'", sep="")
    interfaceRepresentation <- .interfaces[[interface]]

    vals <- list(...)
    slots <- .slots(interfaceRepresentation)
    ok <- names(vals) %in% names(slots)
    if (!all(ok))
        stop("unknown implementation arguments:",
             paste(names(vals)[!ok], collapse=" "))
    ok <- sapply(vals, is, "function")
    if (!all(ok))
        stop("non-function values:",
             paste(names(vals)[!ok], collapse=" "))

    slots[names(vals)] <- vals
    cls <- lapply(slots, class)
    representation <- do.call(representation, cls)
    prototype <- do.call(prototype, slots)
    implClassName <- .implementationMangler(Class, interface)
    setClass(implClassName,
             contains=interface,
             representation=representation,
             prototype=prototype)
    setIs(Class, interface, coerce=function(from) {
        ## yuck -- lying about what is returned
        from
    }, replace=function(from, value) {
        stop("cannot use 'as<-'")
    })
    invisible(getClass(implClassName))
}

setGeneric("getImplementation", function(Class, interface, ...)
{
    standardGeneric("getImplementation")
})

setMethod(getImplementation, "character",
    function(Class, interface, ...) 
{
    implementationName <- .implementationMangler(Class, interface)
    new(implementationName)
})

setMethod(getImplementation, "ANY",
    function(Class, interface, ...)
{
    callGeneric(class(Class), interface, ...)
})

