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

# Functions for making Rd and human readable versions of bibentry records.

# Clean up LaTeX accents and braces
cleanupLatex <- function(x) {
    if (!length(x)) return(x)
    latex <- tryCatch(parseLatex(x), error = identity)
    if (inherits(latex, "error")) {
    	x
    } else {
    	deparseLatex(latexToUtf8(latex), dropBraces=TRUE, math=c("\\eqn{", "}"))
    }
}

make_bibstyle_JSS <- function() {

    # First, some utilities

    collapse <- function(strings)
        paste(strings, collapse="\n")

    # Add a period if there's no sentence punctuation already
    addPeriod <- function(string)
        sub("([^.?!])$", "\\1.", string)

    # Separate args by sep, add a period at the end.
    sentence <- function(..., sep = ", ") {
        strings <- c(...)
        if (length(strings)) {
            addPeriod(paste(strings, collapse = sep))
        }
    }

    # Now some simple markup

    plain <- function(pages)
        if (length(pages)) collapse(pages)

    plainclean <- function(s) plain(cleanupLatex(s))

    emph <- function(s)
        if (length(s)) paste0("\\emph{", collapse(s), "}")

    emphclean <- function(s) emph(cleanupLatex(s))

    # This creates a function to label a field by adding a prefix or
    # suffix (or both)

    label <- function(prefix=NULL, suffix=NULL, style=plain) {
        force(prefix); force(suffix); force(style)
        function(s)
            if (length(s)) style(paste0(prefix, collapse(s), suffix))
    }

    labelclean <- function(prefix=NULL, suffix=NULL, style=plain) {
        f <- label(prefix, suffix, style)
        function(s) f(cleanupLatex(s))
    }

    # Now the formatters for each particular field.  These take
    # a character vector; if length zero, they return NULL, otherwise
    # a single element character vector putting everything together

    fmtAddress <- plainclean
    fmtBook <- emphclean
    fmtBtitle <- emphclean
    fmtChapter <- labelclean(prefix = "chapter ")
    fmtDOI <- function(doi) {
        ## PR#17725: DOIs can contain % signs, and need multiple levels
        ## of escaping when translated to Rd. 
        .escape <- function(s)
            gsub("%", paste0(strrep("\\", 11L), "%"), s, fixed = TRUE)
        .fmtDOI <- label(prefix = "\\doi{", suffix = "}")
        .fmtDOI(.escape(doi))
    }
    fmtEdition <- labelclean(suffix=" edition")
    fmtEprint <- plain
    fmtHowpublished <- plainclean
    fmtISBN <- label(prefix = "ISBN ")
    fmtISSN <- label(prefix = "ISSN ")
    fmtInstitution <- function(s) {
        if(inherits(s, "person"))
            s <- s$given
        plainclean(s)
    }
    fmtNote <- plainclean
    fmtPages <- plain
    fmtSchool <- fmtInstitution
    ## fmtTechreportnumber <- labelclean(prefix="Technical Report ")
    fmtUrl <- label(prefix = "\\url{", suffix="}")
    fmtTitle <- function(title) 
        if (length(title)) {
            title <- gsub("%", "\\\\\\%", title)
            paste0("\\dQuote{",
                   addPeriod(collapse(cleanupLatex(title))), "}")
        }
    fmtYear <- function(year) {
        if (!length(year)) year <- "????"
        paste0("(", collapse(year), ")")
    }

    fmtType <- function(type, default) {
        if(length(type) && any(nzchar(type)))
            plainclean(type)
        else
            default
    }

    # Now some more complicated ones that look at multiple fields
    volNum <- function(paper) {
        if (length(paper$volume)) {
            result <- paste0("\\bold{", collapse(paper$volume), "}")
            if (length(paper$number))
                result <- paste0(result, "(", collapse(paper$number), ")")
            result
        }
    }

    ## Format one person object in short "Murdoch DJ" format
    shortName <- function(person) {
        if (length(person$family)) {
            result <- cleanupLatex(person$family)
            if (length(person$given))
                paste(result,
                      paste(substr(vapply(person$given, cleanupLatex, ""),
                                   1L, 1L),
                            collapse = ""))
            else result
        }
        else
            paste(cleanupLatex(person$given), collapse = " ")
    }

    # Format all authors for one paper
    authorList <- function(paper) {
        names <- vapply(paper$author, shortName, "")
        if (length(names) > 1L)
            result <- paste(names, collapse = ", ")
        else
            result <- names
        result
    }

    # Format all editors for one paper
    editorList <- function(paper) {
        names <- vapply(paper$editor, shortName, "")
        if (length(names) > 1L)
            result <- paste(paste(names, collapse = ", "), "(eds.)")
        else if (length(names))
            result <- paste(names, "(ed.)")
        else
            result <- NULL
        result
    }

    extraInfo <- function(paper) {
        result <- paste(c(fmtNote(paper$note),
                          fmtEprint(paper$eprint),
                          fmtUrl(paper$url)),
                        collapse = ", ")
        if (nzchar(result)) result
    }

    bookVolume <- function(book) {
        result <- ""
        if (length(book$volume))
            result <- paste("volume", collapse(book$volume))
        if (length(book$number))
            result <- paste(result, "number", collapse(book$number))
        if (length(book$series))
            result <- paste(result, "series", collapse(cleanupLatex(book$series)))
        if (nzchar(result)) result
    }

    bookPublisher <- function(book) {
        if(length(p <- book$publisher)) {
            if(inherits(p, "person"))
                p <- p$given
            result <- collapse(cleanupLatex(p))
            if(length(book$address))
                result <- paste(result,
                                collapse(book$address),
                                sep = ", ")
            result
        }
    }

    procOrganization <- function(paper) {
        if(length(o <- paper$organization)) {
            if(inherits(o, "person"))
                o <- o$given
            result <- collapse(cleanupLatex(o))
            if(length(paper$address))
                result <- paste(result,
                                collapse(cleanupLatex(paper$address)),
                                sep = ", ")
            result
        }
    }

    fmtTechreportnumber <- function(paper) {
        if(length(paper$number)) {
            paste(fmtType(paper$type, "Technical Report"),
                  plainclean(paper$number))
        }
    }

    formatArticle <- function(paper) {
        collapse(c(fmtPrefix(paper),
                   sentence(authorList(paper), fmtYear(paper$year), sep = " "),
                   fmtTitle(paper$title),
                   sentence(fmtBook(paper$journal), volNum(paper),
                            fmtPages(paper$pages)),
                   sentence(fmtISSN(paper$issn)),
                   sentence(fmtDOI(paper$doi)),
                   sentence(extraInfo(paper))))
    }

    formatBook <- function(book) {
        authors <- authorList(book)
        if(!length(authors))
            authors <- editorList(book)

        collapse(c(fmtPrefix(book),
                   sentence(authors, fmtYear(book$year), sep = " "),
                   sentence(fmtBtitle(book$title), bookVolume(book),
                            fmtEdition(book$edition)),
                   sentence(bookPublisher(book)),
                   sentence(fmtISBN(book$isbn)),
                   sentence(fmtDOI(book$doi)),
                   sentence(extraInfo(book))))
    }

    formatInbook <- function(paper) {
        authors <- authorList(paper)
        editors <- editorList(paper)
        if(!length(authors)) {
            authors <- editors
            editors <- NULL
        }
        collapse(c(fmtPrefix(paper),
                   sentence(authors, fmtYear(paper$year), sep =" "),
                   fmtTitle(paper$title),
                   paste("In", sentence(editors, fmtBtitle(paper$booktitle),
                                        bookVolume(paper),
                                        fmtChapter(paper$chapter),
                                        fmtPages(paper$pages),
                                        fmtEdition(paper$edition))),
                   sentence(bookPublisher(paper)),
                   sentence(fmtISBN(paper$isbn)),
                   sentence(fmtDOI(paper$doi)),
                   sentence(extraInfo(paper))))
    }

    formatIncollection <- function(paper) {
        collapse(c(fmtPrefix(paper),
                   sentence(authorList(paper), fmtYear(paper$year), sep = " "),
                   fmtTitle(paper$title),
                   paste("In", sentence(editorList(paper),
                                        fmtBtitle(paper$booktitle),
                                        bookVolume(paper),
                                        fmtEdition(paper$edition),
                                        fmtChapter(paper$chapter),
                                        fmtPages(paper$pages))),
                   sentence(bookPublisher(paper)),
                   sentence(fmtISBN(paper$isbn)),
                   sentence(fmtDOI(paper$doi)),
                   sentence(extraInfo(paper))))
    }

    formatInProceedings <- function(paper)
        collapse(c(fmtPrefix(paper),
                   sentence(authorList(paper), fmtYear(paper$year), sep = " "),
                   fmtTitle(paper$title),
                   paste("In", sentence(editorList(paper),
                                        fmtBtitle(paper$booktitle),
                                        bookVolume(paper),
                                        fmtEdition(paper$edition),
                                        fmtPages(paper$pages))),
                   sentence(procOrganization(paper)),
                   sentence(fmtISBN(paper$isbn)),
                   sentence(fmtDOI(paper$doi)),
                   sentence(extraInfo(paper))))

    formatManual <- function(paper) {
        collapse(c(fmtPrefix(paper),
                   sentence(authorList(paper), fmtYear(paper$year), sep = " "),
                   sentence(fmtBtitle(paper$title), bookVolume(paper),
                            fmtEdition(paper$edition)),
                   sentence(procOrganization(paper)),
                   sentence(fmtISBN(paper$isbn)),
                   sentence(fmtDOI(paper$doi)),
                   sentence(extraInfo(paper))))
    }

    formatMastersthesis <- function(paper) {
        collapse(c(fmtPrefix(paper),
                   sentence(authorList(paper), fmtYear(paper$year), sep = " "),
                   sentence(fmtBtitle(paper$title)),
                   sentence(fmtType(paper$type, "Master's thesis"),
                            fmtSchool(paper$school),
                            fmtAddress(paper$address)),
                   sentence(fmtDOI(paper$doi)),
                   sentence(extraInfo(paper))))
    }

    formatPhdthesis <- function(paper) {
        collapse(c(fmtPrefix(paper),
                   sentence(authorList(paper), fmtYear(paper$year), sep = " "),
                   sentence(fmtBtitle(paper$title)),
                   sentence(fmtType(paper$type, "Ph.D. thesis"),
                            fmtSchool(paper$school),
                            fmtAddress(paper$address)),
                   sentence(fmtDOI(paper$doi)),
                   sentence(extraInfo(paper))))
    }

    formatMisc <- function(paper) {
        collapse(c(fmtPrefix(paper),
                   sentence(authorList(paper), fmtYear(paper$year), sep = " "),
                   fmtTitle(paper$title),
                   sentence(fmtHowpublished(paper$howpublished)),
                   sentence(fmtDOI(paper$doi)),
                   sentence(extraInfo(paper))))
    }

    formatProceedings <- function(book) {
        if (is.null(book$editor)) editor <- "Anonymous (ed.)"
        else editor <- editorList(book)
        collapse(c(fmtPrefix(book), # not paper
                   sentence(editor, fmtYear(book$year), sep = " "),
                   sentence(fmtBtitle(book$title), bookVolume(book)),
                   sentence(procOrganization(book)),
                   sentence(fmtISBN(book$isbn)),
                   sentence(fmtISSN(book$issn)),
                   sentence(fmtDOI(book$doi)),
                   sentence(extraInfo(book))))
    }

    formatTechreport <- function(paper) {
        collapse(c(fmtPrefix(paper),
                   sentence(authorList(paper), fmtYear(paper$year), sep = " "),
                   fmtTitle(paper$title),
                   sentence(fmtTechreportnumber(paper),
                            fmtInstitution(paper$institution),
                            fmtAddress(paper$address)),
                   sentence(fmtDOI(paper$doi)),
                   sentence(extraInfo(paper))))
    }

    formatUnpublished <- function(paper) {
        collapse(c(fmtPrefix(paper),
                   sentence(authorList(paper), fmtYear(paper$year), sep = " "),
                   fmtTitle(paper$title),
                   sentence(fmtDOI(paper$doi)),
                   sentence(extraInfo(paper))))
    }

    sortKeys <- function(bib) {
        result <- character(length(bib))
        for (i in seq_along(bib)) {
            authors <- authorList(bib[[i]])
            if (!length(authors))
                authors <- editorList(bib[[i]])
            if (!length(authors))
                authors <- ""
            result[i] <- authors
        }
        result
    }

    # Replace this if you want a bibliography style
    # that puts a prefix on each entry, e.g. [n]
    # The formatting routine will have added a field .index
    # as a 1-based index within the complete list.

    fmtPrefix <- function(paper) NULL

    cite <- function(key, bib, ...)
        utils::citeNatbib(key, bib, ...) # the defaults are JSS style

    environment()
}

make_bibstyle_R <- function() {
    env <- make_bibstyle_JSS()

    ## Format one person object in not-so-short "Murdoch D. J." format
    shortName <- function(person) {
        if(length(family <- person$family)) {
            result <- cleanupLatex(family)
            if(length(given <- person$given)) {
                given <- vapply(given, cleanupLatex, "")
                paste(result,
                      paste0(substring(given, 1L, 1L),
                             ifelse(nchar(given) > 1L, ".", ""),
                             collapse = " "))
            } else result
        }
        else paste(cleanupLatex(person$given), collapse = " ")
    }
    environment(shortName) <- env
    
    ## authorList <- function(paper) {
    ##     names <- vapply(paper$author, shortName, "")
    ##     if (length(names) > 1L)
    ##         result <- paste(names, collapse = " and ")
    ##     else
    ##         result <- names
    ##     result
    ## }
    ## environment(authorList) <- env
    
    ## editorList <- function(paper) {
    ##     names <- vapply(paper$editor, shortName, "")
    ##     if (length(names) > 1L)
    ##         result <- paste(paste(names, collapse = " and "), "(eds.)")
    ##     else if (length(names))
    ##         result <- paste(names, "(ed.)")
    ##     else
    ##         result <- NULL
    ##     result
    ## }
    ## environment(editorList) <- env
    
    env$shortName <- shortName
    ## env$authorList <- authorList
    ## env$editorList <- editorList
    
    env
}

bibstyle <- local({
    styles <- list(JSS = make_bibstyle_JSS(),
                   R = make_bibstyle_R())
    default <- "JSS"
    function(style, envir, ..., .init = FALSE, .default=TRUE) {
        newfns <- list(...)
        if (missing(style) || is.null(style)) {
            if (!missing(envir) || length(newfns) || .init)
            	stop("Changes require specified 'style'")
            style <- default
        } else {
	    if (!missing(envir)) {
		stopifnot(!.init)
		styles[[style]] <<- envir
	    }
	    if (.init) styles[[style]] <<- make_bibstyle_JSS()
	    if (length(newfns) && style == "JSS")
		stop("The default JSS style may not be modified.")
	    for (n in names(newfns))
		assign(n, newfns[[n]], envir=styles[[style]])
            if (.default)
            	default <<- style
        }
        styles[[style]]
    }
})

getBibstyle <- function(all = FALSE) {
    if (all)
    	names(environment(bibstyle)$styles)
    else
    	environment(bibstyle)$default
}

toRd.bibentry <- function(obj, style=NULL, ...) {
    obj <- sort(obj, .bibstyle=style)
    style <- bibstyle(style, .default = FALSE)
    env <- new.env(hash = FALSE, parent = style)
    bib <- unclass(obj)
    result <- character(length(bib))
    for (i in seq_along(bib)) {
    	env$paper <- bib[[i]]
    	result[i] <- with(env,
    	    switch(attr(paper, "bibtype"),
    	    Article = formatArticle(paper),
    	    Book = formatBook(paper),
    	    InBook = formatInbook(paper),
    	    InCollection = formatIncollection(paper),
    	    InProceedings = formatInProceedings(paper),
    	    Manual = formatManual(paper),
    	    MastersThesis = formatMastersthesis(paper),
    	    Misc = formatMisc(paper),
    	    PhdThesis = formatPhdthesis(paper),
    	    Proceedings = formatProceedings(paper),
    	    TechReport = formatTechreport(paper),
    	    Unpublished = formatUnpublished(paper),
    	    paste("bibtype", attr(paper, "bibtype"),"not implemented") ))
    }
    gsub("(^|[^\\])((\\\\\\\\)*)%", "\\1\\2\\\\%", result)
}
