+++ /dev/null
-;;; citeproc-autoloads.el --- automatically extracted autoloads (do not edit) -*- lexical-binding: t -*-
-;; Generated by the `loaddefs-generate' function.
-
-;; This file is part of GNU Emacs.
-
-;;; Code:
-
-(add-to-list 'load-path (or (and load-file-name (directory-file-name (file-name-directory load-file-name))) (car load-path)))
-
-
-\f
-;;; Generated autoloads from citeproc.el
-
-(register-definition-prefixes "citeproc" '("citeproc-"))
-
-\f
-;;; Generated autoloads from citeproc-biblatex.el
-
-(register-definition-prefixes "citeproc-biblatex" '("citeproc-blt-"))
-
-\f
-;;; Generated autoloads from citeproc-bibtex.el
-
-(register-definition-prefixes "citeproc-bibtex" '("citeproc-bt-"))
-
-\f
-;;; Generated autoloads from citeproc-choose.el
-
-(register-definition-prefixes "citeproc-choose" '("citeproc-"))
-
-\f
-;;; Generated autoloads from citeproc-cite.el
-
-(register-definition-prefixes "citeproc-cite" '("citeproc-"))
-
-\f
-;;; Generated autoloads from citeproc-context.el
-
-(register-definition-prefixes "citeproc-context" '("citeproc-"))
-
-\f
-;;; Generated autoloads from citeproc-date.el
-
-(register-definition-prefixes "citeproc-date" '("citeproc-"))
-
-\f
-;;; Generated autoloads from citeproc-disamb.el
-
-(register-definition-prefixes "citeproc-disamb" '("citeproc-"))
-
-\f
-;;; Generated autoloads from citeproc-formatters.el
-
-(register-definition-prefixes "citeproc-formatters" '("citeproc-f"))
-
-\f
-;;; Generated autoloads from citeproc-generic-elements.el
-
-(register-definition-prefixes "citeproc-generic-elements" '("citeproc-"))
-
-\f
-;;; Generated autoloads from citeproc-itemdata.el
-
-(register-definition-prefixes "citeproc-itemdata" '("citeproc-itd-"))
-
-\f
-;;; Generated autoloads from citeproc-itemgetters.el
-
-(register-definition-prefixes "citeproc-itemgetters" '("citeproc-"))
-
-\f
-;;; Generated autoloads from citeproc-lib.el
-
-(register-definition-prefixes "citeproc-lib" '("citeproc-"))
-
-\f
-;;; Generated autoloads from citeproc-locale.el
-
-(register-definition-prefixes "citeproc-locale" '("citeproc-locale-"))
-
-\f
-;;; Generated autoloads from citeproc-macro.el
-
-(register-definition-prefixes "citeproc-macro" '("citeproc-"))
-
-\f
-;;; Generated autoloads from citeproc-name.el
-
-(register-definition-prefixes "citeproc-name" '("citeproc-"))
-
-\f
-;;; Generated autoloads from citeproc-number.el
-
-(register-definition-prefixes "citeproc-number" '("citeproc-"))
-
-\f
-;;; Generated autoloads from citeproc-prange.el
-
-(register-definition-prefixes "citeproc-prange" '("citeproc-prange-"))
-
-\f
-;;; Generated autoloads from citeproc-proc.el
-
-(register-definition-prefixes "citeproc-proc" '("citeproc-proc-"))
-
-\f
-;;; Generated autoloads from citeproc-rt.el
-
-(register-definition-prefixes "citeproc-rt" '("citeproc-rt-"))
-
-\f
-;;; Generated autoloads from citeproc-s.el
-
-(register-definition-prefixes "citeproc-s" '("citeproc-s-"))
-
-\f
-;;; Generated autoloads from citeproc-sort.el
-
-(register-definition-prefixes "citeproc-sort" '("citeproc-"))
-
-\f
-;;; Generated autoloads from citeproc-style.el
-
-(register-definition-prefixes "citeproc-style" '("citeproc-"))
-
-\f
-;;; Generated autoloads from citeproc-subbibs.el
-
-(register-definition-prefixes "citeproc-subbibs" '("citeproc-sb-"))
-
-\f
-;;; Generated autoloads from citeproc-term.el
-
-(register-definition-prefixes "citeproc-term" '("citeproc-term-"))
-
-\f
-;;; Generated autoloads from citeproc-test-human.el
-
-(register-definition-prefixes "citeproc-test-human" '("citeproc-test-human-"))
-\f
-;;; End of scraped data
-
-(provide 'citeproc-autoloads)
-
-;; Local Variables:
-;; version-control: never
-;; no-byte-compile: t
-;; no-update-autoloads: t
-;; no-native-compile: t
-;; coding: utf-8-emacs-unix
-;; End:
-
-;;; citeproc-autoloads.el ends here
+++ /dev/null
-;;; citeproc-biblatex.el --- convert biblatex entries to CSL -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2021 András Simonyi
-
-;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
-
-;; 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 3 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.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; Convert biblatex bibliography entries to CSL.
-
-;;; Code:
-
-(require 'parse-time)
-(require 'compat)
-
-(require 'citeproc-bibtex)
-
-(defvar citeproc-blt-to-csl-types-alist
- '((article . "article-journal")
- (book . "book")
- (periodical . "book")
- (booklet . "pamphlet")
- (bookinbook . "chapter")
- (misc . "article")
- (other . "article")
- (standard . "legislation")
- (collection . "book")
- (conference . "paper-conference")
- (dataset . "dataset")
- (electronic . "webpage")
- (inbook . "chapter")
- (incollection . "chapter")
- (inreference . "entry-encyclopedia")
- (inproceedings . "paper-conference")
- (manual . "book")
- (mastersthesis . "thesis")
- (mvbook . "book")
- (mvcollection . "book")
- (mvproceedings . "book")
- (mvreference . "book")
- (online . "webpage")
- (patent . "patent")
- (phdthesis . "thesis")
- (proceedings . "book")
- (reference . "book")
- (report . "report")
- (software . "software")
- (suppbook . "chapter")
- (suppcollection . "chapter")
- (techreport . "report")
- (thesis . "thesis")
- (unpublished . "manuscript")
- (www . "webpage")
- (artwork . "graphic")
- (audio . "song")
- (commentary . "book")
- (image . "figure")
- (jurisdiction . "legal_case")
- (legislation . "bill") ?
- (legal . "treaty")
- (letter . "personal_communication")
- (movie . "motion_picture")
- (music . "song")
- (performance . "speech")
- (review . "review")
- (standard . "legislation")
- (video . "motion_picture")
- (data . "dataset")
- (letters . "personal_communication")
- (newsarticle . "article-newspaper"))
- "Alist mapping biblatex item types to CSL item types.")
-
-(defun citeproc-blt--to-csl-type (type entrysubtype)
- "Return the CSL type corresponding to blt TYPE and ENTRYSUBTYPE."
- (pcase type
- ((or 'article 'periodical 'supperiodical)
- (pcase entrysubtype
- ("magazine" "article-magazine")
- ("newspaper" "article-newspaper")
- (_ "article-journal")))
- (_ (assoc-default type citeproc-blt-to-csl-types-alist))))
-
-(defvar citeproc-blt-reftype-to-genre
- '(("mastersthesis" . "Master's thesis")
- ("phdthesis" . "PhD thesis")
- ("mathesis" . "Master's thesis")
- ("resreport" . "research report")
- ("techreport" . "technical report")
- ("patreqfr" . "French patent request")
- ("patenteu" . "European patent")
- ("patentus" . "U.S. patent"))
- "Alist mapping biblatex reftypes to CSL genres.")
-
-(defvar citeproc-blt-article-types
- '(article periodical suppperiodical review)
- "Article-like biblatex types.")
-
-(defvar citeproc-blt-chapter-types
- '(inbook incollection inproceedings inreference bookinbook)
- "Chapter-like biblatex types.")
-
-(defvar citeproc-blt-collection-types
- '(book collection proceedings reference
- mvbook mvcollection mvproceedings mvreference
- bookinbook inbook incollection inproceedings
- inreference suppbook suppcollection)
- "Collection or collection part biblatex types.")
-
-(defvar citeproc-blt-to-csl-names-alist
- '((author . author)
- (editor . editor)
- (bookauthor . container-author)
- (translator . translator))
- "Alist mapping biblatex name fields to the corresponding CSL ones.")
-
-(defvar citeproc-blt-editortype-to-csl-name-alist
- '(("organizer" . organizer)
- ("director" . director)
- ("compiler" . compiler)
- ("editor" . editor)
- ("collaborator" . contributor))
- "Alist mapping biblatex editortypes to CSL fields.")
-
-(defvar citeproc-blt-to-csl-dates-alist
- '((eventdate . event-date)
- (origdate . original-date)
- (urldate . accessed))
- "Alist mapping biblatex date fields to the corresponding CSL ones.")
-
-(defconst citeproc-blt--publisher-fields
- '(school institution organization howpublished publisher)
- "Biblatex fields containing publisher-related information.")
-
-(defconst citeproc-blt--etype-to-baseurl-alist
- '(("arxiv" . "https://arxiv.org/abs/")
- ("jstor" . "https://www.jstor.org/stable/")
- ("pubmed" ."https://www.ncbi.nlm.nih.gov/pubmed/")
- ("googlebooks" . "https://books.google.com?id="))
- "Alist mapping biblatex date fields to the corresponding CSL ones.")
-
-(defvar citeproc-blt-to-csl-standard-alist
- '(;; locators
- (volume . volume)
- (part . part)
- (edition . edition)
- (version . version)
- (volumes . number-of-volumes)
- (pagetotal . number-of-pages)
- (chapter . chapter-number)
- (pages . page)
- ;; publisher
- (origpublisher . original-publisher)
- ;; places
- (venue . event-place)
- (origlocation . original-publisher-place)
- (address . publisher-place)
- ;; doi etcetera
- (doi . DOI)
- (isbn . ISBN)
- (issn . ISSN)
- (pmid . PMID)
- (pmcid . PMCID)
- (library . call-number)
- ;; notes
- (abstract . abstract)
- (annotation . annote)
- (annote . annote) ; alias for jurabib compatibility
- ;; else
- (pubstate . status)
- (language . language)
- (version . version)
- (keywords . keyword)
- (label . citation-label))
- "Alist mapping biblatex standard fields to the corresponding CSL ones.
-Only those fields are mapped that do not require further processing.")
-
-(defvar citeproc-blt-to-csl-title-alist
- '((eventtitle . event-title)
- (origtitle . original-title)
- (series . collection-title))
- "Alist mapping biblatex title fields to the corresponding CSL ones.
-Only those fields are mapped that do not require further
-processing.")
-
-(defun citeproc-blt--parse-date (d)
- "Parse single biblatex date-time expression D."
- ;; Remove time part, if present.
- (-when-let (time-sep-pos (cl-position ?T d))
- (setq d (substring d 0 time-sep-pos)))
- (--map (let ((converted (string-to-number it)))
- (if (not (= converted 0))
- converted
- (error "Couldn't parse '%s' as a date" d)))
- (split-string d "-")))
-
-(defun citeproc-blt--to-csl-date (d)
- "Return a CSL version of the biblatex date field given by D."
- (let* ((interval-strings (split-string d "/"))
- (interval-date-parts
- (mapcar #'citeproc-blt--parse-date interval-strings)))
- (list (cons 'date-parts interval-date-parts))))
-
-(defun citeproc-blt--get-standard (v b &optional with-nocase)
- "Return the CSL-normalized value of var V from item B.
-V is a biblatex var name as a string, B is a biblatex entry as an
-alist. If optional WITH-NOCASE is non-nil then convert BibTeX
-no-case brackets to the corresponding CSL XML spans. Return nil
-if V is undefined in B."
- (-when-let (blt-val (alist-get v b))
- (citeproc-bt--to-csl blt-val with-nocase)))
-
-(defun citeproc-blt--get-title (v b &optional with-nocase sent-case)
- "Return the CSL-normalized value of a title var V from item B.
-If optional WITH-NOCASE is non-nil then convert BibTeX no-case
-brackets to the corresponding CSL XML spans, and if optional
-SENT-CASE is non-nil the convert to sentence-case. Return nil if
-V is undefined in B."
- (-when-let (blt-val (alist-get v b))
- (citeproc-blt--to-csl-title blt-val with-nocase sent-case)))
-
-(defun citeproc-blt--to-csl-title (s with-nocase sent-case)
- "Return the CSL-normalized value of a title string S.
-If optional WITH-NOCASE is non-nil then convert BibTeX no-case
-brackets to the corresponding CSL XML spans, and if optional
-SENT-CASE is non-nil the convert to sentence-case."
- (if sent-case
- (citeproc-s-sentence-case-title (citeproc-bt--to-csl s t) (not with-nocase))
- (citeproc-bt--to-csl s with-nocase)))
-
-(defconst citeproc-blt--titlecase-langids
- '("american" "british" "canadian" "english" "australian" "newzealand"
- "USenglish" "UKenglish")
- "List of biblatex langids with title-cased title fields.")
-
-(defconst citeproc-blt--langid-to-lang-alist
- '(("english" . "en-US")
- ("USenglish" . "en-US")
- ("american" . "en-US")
- ("british" . "en-GB")
- ("UKenglish" . "en-GB")
- ("canadian" . "en-US")
- ("australian" . "en-GB")
- ("newzealand" . "en-GB")
- ("afrikaans" . "af-ZA")
- ("arabic" . "ar")
- ("basque" . "eu")
- ("bulgarian" . "bg-BG")
- ("catalan" . "ca-AD")
- ("croatian" . "hr-HR")
- ("czech" . "cs-CZ")
- ("danish" . "da-DK")
- ("dutch" . "nl-NL")
- ("estonian" . "et-EE")
- ("finnish" . "fi-FI")
- ("canadien" . "fr-CA")
- ("acadian" . "fr-CA")
- ("french" . "fr-FR")
- ("francais" . "fr-FR")
- ("austrian" . "de-AT")
- ("naustrian" . "de-AT")
- ("german" . "de-DE")
- ("germanb" . "de-DE")
- ("ngerman" . "de-DE")
- ("greek" . "el-GR")
- ("polutonikogreek" . "el-GR")
- ("hebrew" . "he-IL")
- ("hungarian" . "hu-HU")
- ("icelandic" . "is-IS")
- ("italian" . "it-IT")
- ("japanese" . "ja-JP")
- ("latvian" . "lv-LV")
- ("lithuanian" . "lt-LT")
- ("magyar" . "hu-HU")
- ("mongolian" . "mn-MN")
- ("norsk" . "nb-NO")
- ("nynorsk" . "nn-NO")
- ("farsi" . "fa-IR")
- ("polish" . "pl-PL")
- ("brazil" . "pt-BR")
- ("brazilian" . "pt-BR")
- ("portugues" . "pt-PT")
- ("portuguese" . "pt-PT")
- ("romanian" . "ro-RO")
- ("russian" . "ru-RU")
- ("serbian" . "sr-RS")
- ("serbianc" . "sr-RS")
- ("slovak" . "sk-SK")
- ("slovene" . "sl-SL")
- ("spanish" . "es-ES")
- ("swedish" . "sv-SE")
- ("thai" . "th-TH")
- ("turkish" . "tr-TR")
- ("ukrainian" . "uk-UA")
- ("vietnamese" . "vi-VN")
- ("latin" . "la"))
- "Alist mapping biblatex langids to CSL language codes.")
-
-(defun citeproc-blt-entry-to-csl (b &optional omit-nocase no-sentcase-wo-langid)
- "Return a CSL form of parsed biblatex entry B.
-If the optional OMIT-NOCASE is non-nil then no no-case XML
-markers are generated, and if the optional NO-SENTCASE-WO-LANGID
-is non-nil then title fields in items without a `langid' field
-are not converted to sentence-case.
-
-The processing logic follows the analogous
-function (itemToReference) in John MacFarlane's Pandoc, see
-<https://github.com/jgm/pandoc/blob/master/src/Text/Pandoc/Citeproc/BibTeX.hs>
-Many thanks to him.
-
-Note: in the code, var names starting with ~ refer to values of
-biblatex variables in B."
- (let* ((b (cl-remove-if (lambda (x) (equal "" (cdr x))) b))
- (b (mapcar (lambda (x) (cons (intern (downcase (car x))) (cdr x))) b))
- (~type (intern (downcase (alist-get '=type= b))))
- (~entrysubtype (alist-get 'entrysubtype b))
- (type (citeproc-blt--to-csl-type ~type ~entrysubtype))
- (is-article (memq ~type citeproc-blt-article-types))
- (is-periodical (eq ~type 'periodical))
- (is-chapter-like (memq ~type citeproc-blt-chapter-types))
- (~langid (alist-get 'langid b))
- (sent-case (or (member ~langid citeproc-blt--titlecase-langids)
- (and (null ~langid) (not no-sentcase-wo-langid))))
- (with-nocase (not omit-nocase))
- result)
- ;; language
- (when ~langid
- (push (cons 'language (cdr (assoc ~langid citeproc-blt--langid-to-lang-alist)))
- result))
- ;; set type and genre
- (push (cons 'type type) result)
- (when-let ((~reftype (alist-get 'type b)))
- (push (cons 'genre (or (assoc-default ~reftype citeproc-blt-reftype-to-genre)
- (citeproc-bt--to-csl ~reftype)))
- result))
- ;; We store the original bib(la)tex type for filtering purposes.
- (push (cons 'blt-type (symbol-name ~type)) result)
- ;; names
- ;; TODO: handle editorb and editorc as well...
- (when-let ((~editortype (alist-get 'editortype b))
- (~editor (alist-get 'editor b))
- (csl-var (assoc-default ~editortype
- citeproc-blt-editortype-to-csl-name-alist)))
- (push (cons csl-var (citeproc-bt--to-csl-names ~editor))
- result))
- (when-let ((~editoratype (alist-get 'editoratype b))
- (~editora (alist-get 'editora b))
- (csl-var (assoc-default ~editoratype
- citeproc-blt-editortype-to-csl-name-alist)))
- (push (cons csl-var (citeproc-bt--to-csl-names ~editora))
- result))
- ;; dates
- (-when-let (issued (-if-let (~issued (alist-get 'date b))
- (citeproc-blt--to-csl-date ~issued)
- (-when-let (~year (alist-get 'year b))
- (citeproc-bt--to-csl-date ~year
- (alist-get 'month b)))))
- (push (cons 'issued issued) result))
- ;; locators
- (-if-let (~number (alist-get 'number b))
- (cond ((memq ~type citeproc-blt-collection-types) ; collection
- (push `(collection-number . ,~number) result))
- (is-article ; article
- (push `(issue . ,(-if-let (~issue (alist-get 'issue b))
- (concat ~number ", " ~issue)
- ~number))
- result))
- (t (push `(number . ,~number) result))))
- ;; titles
- (let* ((~maintitle (citeproc-blt--get-title 'maintitle b with-nocase sent-case))
- (title
- (cond (is-periodical (citeproc-blt--get-title 'issuetitle b with-nocase sent-case))
- ((and ~maintitle (not is-chapter-like)) ~maintitle)
- (t (citeproc-blt--get-title 'title b with-nocase sent-case))))
- (subtitle (citeproc-blt--get-title
- (cond (is-periodical 'issuesubtitle)
- ((and ~maintitle (not is-chapter-like))
- 'mainsubtitle)
- (t 'subtitle))
- b with-nocase sent-case))
- (title-addon
- (citeproc-blt--get-title
- (if (and ~maintitle (not is-chapter-like))
- 'maintitleaddon 'titleaddon)
- b with-nocase sent-case))
- (volume-title
- (when ~maintitle
- (citeproc-blt--get-title
- (if is-chapter-like 'booktitle 'title) b with-nocase sent-case)))
- (volume-subtitle
- (when ~maintitle
- (citeproc-blt--get-title
- (if is-chapter-like 'booksubtitle 'subtitle) b with-nocase sent-case)))
- (volume-title-addon
- (when ~maintitle
- (citeproc-blt--get-title
- (if is-chapter-like 'booktitleaddon 'titleaddon) b with-nocase sent-case)))
- (container-title
- (or (and is-periodical (citeproc-blt--get-title 'title b with-nocase sent-case))
- (and is-chapter-like ~maintitle)
- (and is-chapter-like (citeproc-blt--get-title
- 'booktitle b with-nocase sent-case))
- (or (citeproc-blt--get-title 'journaltitle b with-nocase sent-case)
- ;; also accept `journal' for BibTeX compatibility
- (citeproc-blt--get-title 'journal b with-nocase sent-case))))
- (container-subtitle
- (or (and is-periodical (citeproc-blt--get-title
- 'subtitle b with-nocase sent-case))
- (and is-chapter-like (citeproc-blt--get-title
- 'mainsubtitle b with-nocase sent-case))
- (and is-chapter-like (citeproc-blt--get-title
- 'booksubtitle b with-nocase sent-case))
- (citeproc-blt--get-title 'journalsubtitle b with-nocase sent-case)))
- (container-title-addon
- (or (and is-periodical (citeproc-blt--get-title
- 'titleaddon b with-nocase sent-case))
- (and is-chapter-like (citeproc-blt--get-title
- 'maintitleaddon b with-nocase sent-case))
- (and is-chapter-like
- (citeproc-blt--get-title 'booktitleaddon b with-nocase sent-case))))
- (container-title-short
- (or (and is-periodical (not ~maintitle)
- (citeproc-blt--get-title 'titleaddon b with-nocase sent-case))
- (citeproc-blt--get-title 'shortjournal b with-nocase sent-case)))
- (title-short
- (or (and (or (not ~maintitle) is-chapter-like)
- (citeproc-blt--get-title 'shorttitle b with-nocase sent-case))
- (and (or subtitle title-addon)
- (not ~maintitle)
- title))))
- (when title
- (push (cons 'title
- (concat title
- (when subtitle (concat ": " subtitle))
- (when title-addon (concat ". " title-addon))))
- result))
- (when title-short
- (push (cons 'title-short title-short) result))
- (when volume-title
- (push (cons 'volume-title
- (concat volume-title
- (when volume-subtitle (concat ": " volume-subtitle))
- (when volume-title-addon (concat ". " volume-title-addon))))
- result))
- (when container-title
- (push (cons 'container-title
- (concat container-title
- (when container-subtitle (concat ": " container-subtitle))
- (when container-title-addon (concat ". " container-title-addon))))
- result))
- (when container-title-short
- (push (cons 'container-title-short container-title-short) result)))
- ;; publisher
- (-when-let (values (-non-nil (--map (citeproc-blt--get-standard it b)
- citeproc-blt--publisher-fields)))
- (push `(publisher . ,(mapconcat #'identity values "; ")) result))
- ;; places
- (let ((csl-place-var
- (if (eq ~type 'patent) 'jurisdiction 'publisher-place)))
- (-when-let (~location (or (citeproc-blt--get-standard 'location b)
- (citeproc-blt--get-standard 'address b)))
- (push (cons csl-place-var ~location) result)))
- ;; url
- (-when-let (url (or (let ((u (alist-get 'url b))) (and u (string-replace "\\" "" u)))
- (when-let ((~eprinttype (or (alist-get 'eprinttype b)
- (alist-get 'archiveprefix b)))
- (~eprint (alist-get 'eprint b))
- (base-url
- (assoc-default ~eprinttype
- citeproc-blt--etype-to-baseurl-alist)))
- (concat base-url ~eprint))))
- (push (cons 'URL url) result))
- ;; notes
- (-when-let (note (let ((~note (citeproc-blt--get-standard 'note b))
- (~addendum (citeproc-blt--get-standard 'addendum b)))
- (cond ((and ~note ~addendum) (concat ~note ". " ~addendum))
- (~note ~note)
- (~addendum ~addendum)
- (t nil))))
- (push (cons 'note note) result))
- ;; rest
- (let (rest)
- (pcase-dolist (`(,blt-key . ,blt-value) b)
- ;; remaining standard vars
- (-when-let (csl-key
- (alist-get blt-key citeproc-blt-to-csl-standard-alist))
- (unless (alist-get csl-key result)
- (push (cons csl-key (citeproc-bt--to-csl blt-value)) rest)))
- ;; remaining name vars
- (-when-let (csl-key
- (alist-get blt-key citeproc-blt-to-csl-names-alist))
- (unless (alist-get csl-key result)
- (push (cons csl-key (citeproc-bt--to-csl-names blt-value)) rest)))
- ;; remaining date vars
- (-when-let (csl-key
- (alist-get blt-key citeproc-blt-to-csl-dates-alist))
- (unless (alist-get csl-key result)
- (push (cons csl-key (citeproc-blt--to-csl-date blt-value)) rest)))
- ;; remaining title vars
- (-when-let (csl-key
- (alist-get blt-key citeproc-blt-to-csl-title-alist))
- (push (cons csl-key
- (citeproc-blt--to-csl-title blt-value with-nocase sent-case))
- rest)))
- (append result rest))))
-
-(provide 'citeproc-biblatex)
-
-;;; citeproc-biblatex.el ends here
+++ /dev/null
-;;; citeproc-bibtex.el --- convert BibTeX entries to CSL -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2017-2021 András Simonyi
-
-;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
-
-;; 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 3 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.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; Convert BibTeX bibliography entries to CSL.
-
-;;; Code:
-
-(require 'dash)
-(require 'subr-x)
-(require 'bibtex)
-(require 'cl-lib)
-(require 's)
-(require 'org)
-(require 'map)
-(require 'compat)
-;; Handle the fact that org-bibtex has been renamed to ol-bibtex -- for the time
-;; being we support both feature names.
-(or (require 'ol-bibtex nil t)
- (require 'org-bibtex))
-
-(require 'citeproc-s)
-
-;; Declare used ol-bibtex variables and functions to silence 'reference to free
-;; variable' and 'function is not known to be defined' warnings during
-;; compilation.
-(defvar org-bibtex-key-property)
-(defvar org-bibtex-type-property-name)
-(defvar org-bibtex-export-arbitrary-fields)
-(defvar org-bibtex-prefix)
-(defvar org-bibtex-types)
-(declare-function org-bibtex-get "ext:ol-bibtex")
-
-(defconst citeproc-bt--to-csl-types-alist
- '(("article" . "article-journal") ("book" . "book") ("proceedings" . "book")
- ("manual" . "book") ("periodical" . "book") ("booklet" . "pamphlet")
- ("inbook" . "chapter") ("incollection" . "chapter") ("inproceedings" . "paper-conference")
- ("conference" . "paper-conference") ("mastersthesis" . "thesis") ("phdthesis" . "thesis")
- ("techreport" . "report") ("patent" . "patent") ("electronic" . "webpage")
- ("misc" . "article") ("other" . "article") ("standard" . "legislation")
- ("unpublished" . "manuscript") ("online" . "article-journal"))
- "Alist mapping BibTeX item types to CSL item types.")
-
-(defconst citeproc-bt--to-csl-keys-alist
- '(("=key=" . citation-label) ("address" . publisher-place)
- ("booktitle" . container-title) ("journal" . container-title)
- ("chapter" . title) ("location" . event-place) ("series" . collection-title)
- ("keywords" . keyword) ("institution" . publisher) ("school" . publisher)
- ("pages" . page) ("organization" . publisher) ("url" . URL)
- ("doi" . DOI) ("pmid" . PMID) ("pmcid" . PMCID))
- "Alist mapping BibTeX keys to CSL keys with different names.")
-
-(defconst citeproc-bt--mon-to-num-alist
- '(("jan" . 1) ("feb" . 2) ("mar" . 3) ("apr" . 4) ("may" . 5) ("jun" . 6)
- ("jul" . 7) ("aug" . 8) ("sep" . 9) ("oct" . 10) ("nov" . 11) ("dec" . 12))
- "Alist mapping LaTeX abbreviated month names to ordinals.")
-
-(defconst citeproc-bt--pref-to-ucs-alist
- '(("'" . "ACUTE") ("`" . "GRAVE") ("^" . "CIRCUMFLEX") ("~" . "TILDE")
- ("=" . "MACRON") ("." . "WITH DOT ABOVE") ("\"" . "DIAERESIS")
- ("''" . "DIAERESIS") ("H" . "DOUBLE ACUTE") ("r" . "WITH RING ABOVE")
- ("u" . "BREVE") ("c" . "CEDILLA") ("k" . "OGONEK") ("v" . "CARON"))
- "Alist mapping LaTeX prefixes to unicode name endings.")
-
-(defconst citeproc-bt--comm-letter-to-ucs-alist
- '((("`" . "A") . "À")
- (("'" . "A") . "Á")
- (("^" . "A") . "Â")
- (("~" . "A") . "Ã")
- (("\"" . "A") . "Ä")
- (("r" . "A") . "Å")
- (("c" . "C") . "Ç")
- (("v" . "C") . "Č")
- (("'" . "C") . "Ć")
- (("`" . "E") . "È")
- (("'" . "E") . "É")
- (("^" . "E") . "Ê")
- (("\"" . "E") . "Ë")
- (("`" . "I") . "Ì")
- (("'" . "I") . "Í")
- (("^" . "I") . "Î")
- (("\"" . "I") . "Ï")
- (("~" . "N") . "Ñ")
- (("`" . "O") . "Ò")
- (("'" . "O") . "Ó")
- (("^" . "O") . "Ô")
- (("~" . "O") . "Õ")
- (("\"" . "O") . "Ö")
- (("c" . "S") . "Ş")
- (("v" . "S") . "Š")
- (("`" . "U") . "Ù")
- (("'" . "U") . "Ú")
- (("^" . "U") . "Û")
- (("\"" . "U") . "Ü")
- (("'" . "Y") . "Ý")
- (("`" . "a") . "à")
- (("'" . "a") . "á")
- (("^" . "a") . "â")
- (("~" . "a") . "ã")
- (("\"" . "a") . "ä")
- (("r" . "a") . "å")
- (("c" . "c") . "ç")
- (("v" . "c") . "č")
- (("'" . "c") . "ć")
- (("`" . "e") . "è")
- (("'" . "e") . "é")
- (("^" . "e") . "ê")
- (("\"" . "e") . "ë")
- (("`" . "i") . "ì")
- (("'" . "i") . "í")
- (("^" . "i") . "î")
- (("\"" . "i") . "ï")
- (("~" . "n") . "ñ")
- (("`" . "o") . "ò")
- (("'" . "o") . "ó")
- (("^" . "o") . "ô")
- (("~" . "o") . "õ")
- (("\"" . "o") . "ö")
- (("v" . "r") . "ř")
- (("c" . "s") . "ş")
- (("v" . "s") . "š")
- (("`" . "u") . "ù")
- (("'" . "u") . "ú")
- (("^" . "u") . "û")
- (("\"" . "u") . "ü")
- (("'" . "y") . "ý")
- (("\"" . "y") . "ÿ")
- (("H" . "o") . "ő")
- (("H" . "O") . "Ő")
- (("H" . "u") . "ű")
- (("H" . "U") . "Ű")
- (("v" . "z") . "ž")
- (("v" . "Z") . "Ž"))
- "Alist mapping LaTeX (SYMBOL-COMMAND . ASCII-CHAR) pairs to unicode characters.")
-
-(defconst citeproc-bt--to-ucs-alist
- '(("l" . "ł") ("L" . "Ł") ("o" . "ø") ("O" . "Ø") ("AA" . "Å") ("aa" . "å")
- ("AE" . "Æ") ("ae" . "æ") ("ss" . "ß") ("i" . "ı"))
- "Alist mapping LaTeX commands to characters.")
-
-(defun citeproc-bt--to-ucs (ltx char)
- "Return the unicode version of LaTeX command LTX applied to CHAR.
-LTX is a one-char LaTeX accenting command (e.g. \"'\"), CHAR is
-an ascii character. Return nil if no corresponding unicode
-character was found."
- (or (assoc-default (cons ltx char) citeproc-bt--comm-letter-to-ucs-alist)
- ;; If the combination is not in citeproc-bt--comm-letter-to-ucs-alist
- ;; then, as a last resort, we try to assemble the canonical unicode name
- ;; of the requested character and look it up in (usc-names). This process
- ;; can be *very slow* on older Emacs versions in which (usc-names) returns
- ;; an alist!
-
- ;; NOTE: Because of a nasty interaction bug between `ucs-names' and
- ;; `replace-regexp-in-string' we do the lookup only for Emacs versions
- ;; earlier than 28.
- (when-let* (((version< emacs-version "28" ))
- (case-name (if (s-lowercase-p char) "SMALL" "CAPITAL"))
- (combining-name (assoc-default ltx citeproc-bt--pref-to-ucs-alist))
- (name (concat "LATIN " case-name " LETTER "
- (upcase char) " " combining-name))
- (char-name (map-elt (ucs-names) name)))
- (char-to-string char-name))))
-
-(defconst citeproc-bt--decode-rx
- (rx (or
- (seq "{\\" (group-n 1 (in "'" "`" "^" "~" "=" "." "\"")) (0+ space)
- (group-n 2 letter) "}")
- (seq "{\\" (group-n 1 (in "H" "r" "u" "c" "k" "v")) (1+ space)
- (group-n 2 letter) "}")
- (seq "{\\" (group-n 1 (or "l" "L" "o" "O" "AA" "aa" "ae" "AE" "ss" "i"))
- (0+ space) "}")
- (seq "\\" (group-n 1 (in "'" "`" "^" "~" "=" "." "\"" "H" "r" "u" "c" "k" "v"))
- (0+ space) "{" (group-n 2 letter) "}")
- (seq "\\" (group-n 1 (in "H" "r" "u" "c" "k" "v")) (1+ space)
- (group-n 2 letter))
- (seq "\\" (group-n 1 (in "'" "`" "^" "~" "=" "." "\"")) (0+ space)
- (group-n 2 letter))
- (seq "\\" (group-n 1 (or "l" "L" "o" "O" "AA" "aa" "ae" "AE" "ss" "i"))
- word-boundary)))
- "Regular expression matching BibTeX special character commands.")
-
-(defun citeproc-bt--decode (s)
- "Decode a BibTeX encoded string."
- (replace-regexp-in-string
- citeproc-bt--decode-rx
- (lambda (x)
- (let ((command (match-string 1 x))
- (letter (match-string 2 x)))
- (if letter
- (or (citeproc-bt--to-ucs command letter) (concat "\\" x))
- (or (assoc-default command citeproc-bt--to-ucs-alist) x))))
- s t t))
-
-(defun citeproc-bt--decode-buffer ()
- "Decode BibTeX encoded characters in the current buffer."
- (goto-char (point-min))
- (while (re-search-forward citeproc-bt--decode-rx nil t)
- (replace-match
- (let ((replacement (let ((command (match-string 1))
- (letter (match-string 2)))
- (if letter
- (or (citeproc-bt--to-ucs command letter) (concat "\\" (match-string 0)))
- (assoc-default command citeproc-bt--to-ucs-alist)))))
- replacement))))
-
-(defconst citeproc-bt--command-rx
- (rx "\\" (1+ (any "a-z" "A-Z")) "{" ; \TEX-COMMAND{
- (group (*? anything)) ; ARGUMENT
- "}" ; }
- ))
-
-(defconst citeproc-bt--command-wo-arg-rx
- (rx "\\" (1+ (any "a-z" "A-Z")) word-end)) ; \TEX-COMMAND + word-end
-
-(defconst citeproc-bt--braces-rx
- (rx (group (or string-start (not "\\"))) "{" ; unescaped {
- (group (optional (seq (*? anything) (not "\\")))) ; TEXT
- "}")) ; unescaped }
-
-(defun citeproc-bt--process-brackets (s &optional lhb rhb)
- "Process LaTeX curly brackets in string S.
-Optional LHB and RHB specify what to substitute for left and
-right braces when they are not enclosing command arguments.
-The default is to remove them."
- (let* ((result s)
- (match t))
- (while match
- (cond ((string-match citeproc-bt--command-rx result)
- (setq result (replace-match "\\1" t nil result)
- match t))
- ((string-match citeproc-bt--command-wo-arg-rx result)
- (setq result (replace-match "" t nil result)
- match t))
- ((string-match citeproc-bt--braces-rx result)
- (setq result (replace-match
- (concat "\\1" lhb "\\2" rhb)
- t nil result)
- match t))
- (t (setq match nil))))
- (s-replace-all '(("\\{" . "{") ("\\}" . "}")) result)))
-
-(defun citeproc-bt--preprocess-for-decode (s)
- "Preprocess field S before decoding.
-Remove flanking dumb quotes from string S and make some
-replacements."
- (let ((wo-quotes (if (and (string= (substring s 0 1) "\"")
- (string= (substring s -1) "\""))
- (substring s 1 -1) s)))
- (string-replace "\\&" "&" wo-quotes)))
-
-(defun citeproc-bt--to-csl (s &optional with-nocase)
- "Convert a BibTeX field S to a CSL one.
-If optional WITH-NOCASE is non-nil then convert BibTeX no-case
-brackets to the corresponding CSL XML spans."
- (if (> (length s) 0)
- (--> s
- (citeproc-bt--preprocess-for-decode it)
- (citeproc-bt--decode it)
- (citeproc-bt--process-brackets
- it
- (when with-nocase "<span class=\"nocase\">")
- (when with-nocase "</span>"))
- (citeproc-s-replace-all-seq it '(("\n" . " ") ("~" . " ") ("--" . "–")))
- (s-trim it))
- s))
-
-(defun citeproc-bt--to-csl-names (n)
- "Return a CSL version of BibTeX names field N."
- (let ((name-fields (s-split "\\band\\b" n)))
- (mapcar
- (lambda (x)
- (let ((trimmed (s-trim x)))
- (cond
- ((string= trimmed "") '((family . "")))
- ;; Presence of equal sign signals extended specification.
- ((string-match "=" trimmed) (citeproc-bt--ext-desc-to-csl-name trimmed))
- ;; Brackets indicate corporate entities without name parts.
- ((and (string= "{" (substring trimmed 0 1))
- (string= "}" (substring trimmed -1)))
- `((literal . ,(citeproc-bt--to-csl (substring trimmed 1 -1)))))
- ;; Else standard bib(la)tex name field processing.
- (t (citeproc-bt--to-csl-name (citeproc-bt--to-csl trimmed))))))
- name-fields)))
-
-(defvar citeproc-bt-dropping-particles
- '("dela" "il" "sen" "z" "ze")
- "List containing dropping particles. Particles whose first word
-is not on this list are classified as non-dropping.")
-
-(defun citeproc-bt--parse-family (f)
- "Parse family name tokens F into a csl name-part alist."
- (let (family result particle)
- (-if-let (firsts (butlast f))
- (progn
- (while (and firsts (s-lowercase-p (car firsts)))
- (push (pop firsts) particle))
- (when particle
- (push (cons (if (member (car particle) citeproc-bt-dropping-particles)
- 'dropping-particle
- 'non-dropping-particle)
- (nreverse particle))
- result))
- (setq family (-concat firsts (last f))))
- (setq family f))
- (push `(family . ,family) result)
- result))
-
-(defun citeproc-bt--parse-attr-val-field (f)
- "Parse biblatex key-val field F into an alist."
- (let* ((bracketless (replace-regexp-in-string "[{}]" "" f))
- (equal-split (split-string bracketless "=" t " "))
- (first-attr (intern (string-trim (pop equal-split) "[ \"]+" "[ \"]+")))
- (reversed (nreverse equal-split))
- (result (list (string-trim (pop reversed) "[ \"]+" "[ \"]+"))))
- (dolist (elt reversed)
- (let ((pos (- (length elt) 2))
- found)
- (while (and (< 0 pos) (null found))
- (if (= (aref elt pos) ?,)
- (setq found t)
- (cl-decf pos)))
- (unless found (error "Could not parse biblatex key-value list \"%s\"" f))
- (let ((key (intern (s-trim (substring elt (1+ pos)))))
- (val (string-trim (substring elt 0 pos) "[ \"]+" "[ \"]+")))
- (push key (car result))
- (push val result))))
- (push first-attr (car result))
- result))
-
-(defun citeproc-bt--ext-desc-to-csl-name (name)
- "Return a CSL version of extended biblatex description NAME."
- (let* ((parsed (citeproc-bt--parse-attr-val-field name))
- (dropping (string= (alist-get 'useprefix parsed) "false")))
- (--keep (pcase (car it)
- ((or 'family 'given 'suffix) it)
- ('prefix (cons (if dropping 'dropping-particle 'non-dropping-particle)
- (cdr it)))
- (_ nil))
- parsed)))
-
-(defun citeproc-bt--to-csl-name (name)
- "Return a CSL version of BibTeX name string NAME."
- (let* (result
- family
- (tokens (-remove #'s-blank-str-p
- (citeproc-s-slice-by-matches name "\\(,\\|[[:space:]]+\\)")))
- (parts (-split-on "," tokens)))
- (pcase (length parts)
- ;; No commas in the name
- (1 (let ((name (car parts)))
- (-if-let (1st-downcased-idx (-find-index #'s-lowercase-p name))
- (progn (setq family (-slice name 1st-downcased-idx))
- (when (> 1st-downcased-idx 0)
- (push `(given . ,(-slice name 0 1st-downcased-idx)) result)))
- (setq family (last name))
- (when (> (length name) 1)
- (push `(given . ,(-slice name 0 -1)) result)))))
- ;; A single comma separates family and last name
- (2 (setq family (car parts))
- (push `(given . ,(cadr parts)) result))
- ;; More than one commas
- (_ (setq family (car parts))
- (push `(suffix . ,(cadr parts)) result)
- (push `(given . ,(cl-caddr parts)) result)))
- (setq result (nconc (citeproc-bt--parse-family family) result))
- (--map (cons (car it) (s-join " " (cdr it)))
- result)))
-
-(defun citeproc-bt--to-csl-date (year month)
- "Return a CSL version of the date given by YEAR and MONTH.
-YEAR and MONTH are the values of the corresponding BibTeX fields,
-MONTH might be nil."
- (condition-case nil
- (let ((csl-year (string-to-number (car (s-match "[[:digit:]]+" year))))
- (csl-month (when month
- (assoc-default (downcase month)
- citeproc-bt--mon-to-num-alist)))
- date)
- (when csl-year
- (when csl-month (push csl-month date))
- (push csl-year date))
- (list (cons 'date-parts (list date))))
- (error
- (error (concat "Couldn't parse year: '%s'"
- (when month " and month: '%s'")
- " as a date")
- year month))))
-
-(defun citeproc-bt-entry-to-csl (b)
- "Return a CSL form of normalized parsed BibTeX entry B."
- (let ((type (assoc-default (downcase (assoc-default "=type=" b))
- citeproc-bt--to-csl-types-alist))
- result year month)
- (cl-loop for (key . value) in b do
- (let ((key (downcase key))
- (value (citeproc-bt--to-csl value)))
- (-if-let (csl-key (assoc-default key citeproc-bt--to-csl-keys-alist))
- ;; Vars mapped simply to a differently named CSL var
- (push (cons csl-key value) result)
- (pcase key
- ((or "author" "editor") ; Name vars
- (push (cons (intern key) (citeproc-bt--to-csl-names value))
- result))
- ("=type=" (push (cons 'type type) result))
- ("number" (push (cons (if (string= type "article-journal") 'issue
- 'number)
- value)
- result))
- ;; Date vars that need further processing below
- ("year" (setq year value))
- ("month" (setq month value))
- ;; Remaining keys are mapped without change
- (_ (push (cons (intern key) value) result))))))
- (when year
- (push (cons 'issued (citeproc-bt--to-csl-date year month))
- result))
- result))
-
-;; This function is based on the function `org-bibtex-headline' in org-bibtex,
-;; written by Bastien Guerry <bzgNOSPAMgnu.org>, Carsten Dominik <carsten dot dominik
-;; at gmail dot com> and Eric Schulte <schulte dot eric at gmail dot com>.
-;; Copyright (C) 2007-2017 Free Software Foundation, Inc.
-(defun citeproc-bt-from-org-headline (&optional itemids)
- "Return a (KEY . BIBTEX-ENTRY) pair from the headline at point.
-The returned BibTeX entry has the same form as produced by
-`bibtex-parse-entry'. Return nil if the headline has no
-associated bibtex data. If optional ITEMIDS is given then also
-return nil if the entry's key is not in ITEMIDS."
- (letrec ((val (lambda (key lst) (cdr (assoc key lst))))
- (to (lambda (string) (intern (concat ":" string))))
- (from (lambda (key) (substring (symbol-name key) 1)))
- (flatten (lambda (&rest lsts)
- (apply #'append (mapcar
- (lambda (e)
- (if (listp e) (apply flatten e) (list e)))
- lsts))))
- (id (org-bibtex-get org-bibtex-key-property))
- (type (org-bibtex-get org-bibtex-type-property-name)))
- (when (and type (or (null itemids) (member id itemids)))
- `(,id .
- (("=type=" . ,type)
- ,@(remove
- nil
- (if (and org-bibtex-export-arbitrary-fields
- org-bibtex-prefix)
- (mapcar
- (lambda (kv)
- (let ((key (car kv)) (val0 (cdr kv)))
- (when (and
- (string-match org-bibtex-prefix key)
- (not (string=
- (downcase (concat org-bibtex-prefix
- org-bibtex-type-property-name))
- (downcase key))))
- (cons (downcase (replace-regexp-in-string
- org-bibtex-prefix "" key))
- val0))))
- (org-entry-properties nil 'standard))
- (mapcar
- (lambda (field)
- (let ((value (or (org-bibtex-get (funcall from field))
- (and (eq :title field)
- (nth 4 (org-heading-components))))))
- (when value (cons (funcall from field) value))))
- (funcall flatten
- (funcall val :required (funcall val (funcall to type) org-bibtex-types))
- (funcall val :optional (funcall val (funcall to type) org-bibtex-types)))))))))))
-
-(provide 'citeproc-bibtex)
-
-;;; citeproc-bibtex.el ends here
+++ /dev/null
-;; citeproc-choose.el --- conditionally rendered CSL elements -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2017 András Simonyi
-
-;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
-
-;; 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 3 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.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; CSL supports conditional rendering via the cs:choose rendering element, which
-;; can contain cs:if, cs:else-if and cs:else elements as children. This file
-;; contains functions corresponding to all these elements with some auxiliary
-;; functions.
-
-;; In order to support conditional rendering by cs:choose, the functions
-;; corresponding to cs:if, cs:else-if and cs:else (`citeproc--if',
-;; `citeproc--else-if', `citeproc--else') return the generalized boolean value
-;; of their condition in addition to their rendered content in the form of a
-;; (BOOLEAN . CONTENT) pair.
-
-;;; Code:
-
-(require 's)
-
-(require 'citeproc-lib)
-(require 'citeproc-context)
-(require 'citeproc-date)
-
-(defun citeproc-choose-eval-conditions (attrs context)
- "Eval (possibly complex) boolean conditions in ATTRS."
- (-let* ((conditions (citeproc-choose--elementary-conditions
- (--remove (eq (car it) 'match) attrs)))
- (match (or (alist-get 'match attrs) "all"))
- (values (--map (citeproc-choose--eval-elementary-condition (car it)
- (intern (cdr it))
- context)
- conditions)))
- (pcase match
- ("all" (--all? it values))
- ("any" (--any? it values))
- ("none" (--none? it values)))))
-
-(defun citeproc-choose--elementary-conditions (attrs)
- "Expand complex conditions in ATTRS into elementary ones.
-Return a list of elementary (CONDITION-TYPE . PARAM) pairs."
- (cl-mapcan (lambda (x)
- (--map (cons (car x) it)
- (s-split " " (cdr x))))
- attrs))
-
-(defun citeproc-choose--eval-elementary-condition (type param context)
- "Evaluate an elementary choose condition of TYPE with PARAM.
-TYPE is one of the symbols `variable', `type', `locator',
-`is-numeric', `is-uncertain-date', `position' and `disambiguate'.
-Return the result of evaluation, which is a generalized boolean."
- (pcase type
- ('variable (citeproc-var-value param context))
- ('type (string= param (citeproc-var-value 'type context)))
- ('locator (string= param (citeproc-var-value 'label context)))
- ('is-numeric (let ((val (citeproc-var-value param context)))
- (citeproc-lib-numeric-p val)))
- ;; We return t iff the first date is uncertain. A more complicated alternative
- ;; would be to test the second date of date ranges as well.
- ('is-uncertain-date (-when-let (dates (citeproc-var-value param context))
- (citeproc-date-circa (car dates))))
- ('position (and (eq (citeproc-context-mode context) 'cite)
- (or (and (eq param 'near-note) (citeproc-var-value 'near-note context))
- (let ((pos (citeproc-var-value 'position context)))
- (or (eq param pos)
- (and (eq param 'subsequent)
- (or (eq pos 'ibid) (eq pos 'ibid-with-locator)))
- (and (eq param 'ibid)
- (eq pos 'ibid-with-locator)))))))
- ('disambiguate (citeproc-var-value 'disambiguate context))))
-
-(defmacro citeproc--choose (_attrs _context &rest body)
- "Return the content of the first element in BODY with t boolean value.
-Return the empty (nil . `text-only') content if there is no such
-element."
- `(let ((first-true
- (--first (car it) (list ,@body))))
- (if first-true
- (cdr first-true)
- (cons nil (quote text-only)))))
-
-(defmacro citeproc--if (attrs context &rest body)
- "If conditions in ATTRS eval to t return t with rendered BODY.
-Return nil otherwise."
- `(if (citeproc-choose-eval-conditions ,attrs ,context)
- (cons t (citeproc-lib-add-splice-tag
- (citeproc-lib-splice-into (list ,@body) 'splice)
- 'splice))
- nil))
-
-(defalias 'citeproc--else-if 'citeproc--if)
-
-(defun citeproc--else (_attrs _context &rest body)
- "Always return t boolean plus rendered BODY"
- (let ((spliced-body (citeproc-lib-splice-into body 'splice)))
- (cons t (citeproc-lib-add-splice-tag spliced-body 'splice))))
-
-(provide 'citeproc-choose)
-
-;;; citeproc-choose.el ends here
+++ /dev/null
-;;; citeproc-cite.el --- cite and citation rendering -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2017-2024 András Simonyi
-
-;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
-
-;; 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 3 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.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; Functionality to render citations and the cites they contain. (Terminology
-;; from the CSL standard: "citations consist of one or more cites to individual
-;; items".)
-
-;;; Code:
-
-(require 'cl-lib)
-(require 'dash)
-(require 'queue)
-(require 's)
-
-(require 'citeproc-rt)
-(require 'citeproc-number)
-(require 'citeproc-itemdata)
-(require 'citeproc-style)
-(require 'citeproc-proc)
-(require 'citeproc-formatters)
-(require 'citeproc-sort)
-(require 'citeproc-subbibs)
-(require 'citeproc-date)
-(require 'citeproc-biblatex)
-
-
-(declare-function citeproc-style-category "citeproc-style" (style))
-
-(cl-defstruct (citeproc-citation (:constructor citeproc-citation-create))
- "A struct representing a citation.
-CITES is a list of alists describing individual cites,
-NOTE-INDEX is the note index of the citation if it occurs in a
- note,
-MODE is either nil (for the default citation mode) or one
- of the symbols `suppress-author', `textual', `author-only',
- `year-only', `title-only', `bib-entry', `locator-only',
-SUPPRESS-AFFIXES is non-nil if the citation affixes should be
- suppressed,
-CAPITALIZE-FIRST is non-nil if the first word of the rendered
- citation should be capitalized,
-IGNORE-ET-AL is non-nil if et-al settings should be ignored for
- the first cite.
-GROUPED is used internally to indicate whether the cites were
- grouped by the csl processor."
- cites note-index mode suppress-affixes capitalize-first
- ignore-et-al grouped)
-
-(defconst citeproc-cite--from-mode-alist
- '((textual . ((suppress-author . t)))
- (suppress-author . ((suppress-author . t)))
- (author-only . ((stop-rendering-at . names)))
- (year-only . ((stop-rendering-at . issued)))
- (title-only . ((stop-rendering-at . title) (bib-entry . t) (use-short-title . t)))
- (bib-entry . ((bib-entry . t)))
- (locator-only . ((locator-only . t))))
- "Alist mapping citation modes to corresponding cite-level
-key-value pair representations.")
-
-(defvar citeproc-citation-postprocess-functions nil
- "A list of functions to postprocess rendered citations.
-Each function takes a single argument, a rich-text, and returns a
-post-processed rich-text value. The functions are applied in the
-order they appear in the list.")
-
-(defun citeproc-cite--parse-locator-extra (s)
- "Parse extra locator text S into locator-date and locator-extra.
-Return a pair (LOCATOR-DATE . LOCATOR-EXTRA) where
-- LOCATOR-DATE is a `citeproc-date' struct or nil, and
-- LOCATOR-EXTRA is a string or nil."
- (let (locator-date locator-extra)
- (if (not (string-match-p "^[0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}" s))
- (setq locator-extra (and (not (s-blank-str-p s)) s))
- (setq locator-date (citeproc-date-parse (citeproc-blt--to-csl-date
- (substring s 0 10))))
- (let ((extra (substring s 10)))
- (unless (s-blank-str-p extra) (setq locator-extra extra))))
- (cons locator-date locator-extra)))
-
-(defun citeproc-cite--internalize-locator (cite)
- "Internalize a CITE struct's locator by parsing it into fields.
-If the \"|\" separator is present in the locator then parse it
-into `locator', `locator-extra' and `locator-date', and update
-CITE with these fields accordingly. Returns the possibly modified
-CITE."
- (when-let ((locator (alist-get 'locator cite))
- (separator-pos (cl-position ?| locator)))
- (setf (alist-get 'locator cite) (substring locator 0 separator-pos))
- (pcase-let ((`(,locator-date . ,locator-extra) (citeproc-cite--parse-locator-extra
- (substring locator (1+ separator-pos)))))
- (when locator-date (push (cons 'locator-date locator-date) cite))
- (when locator-extra (push (cons 'locator-extra locator-extra) cite))))
- cite)
-
-(defun citeproc-cite--varlist (cite)
- "Return the varlist belonging to CITE."
- (let* ((itd (alist-get 'itd cite))
- (item-vv (citeproc-itemdata-varvals itd))
- ;; OPTIMIZE: Should we do this filtering?
- (cite-vv
- (--filter (memq (car it)
- '(label locator suppress-author suppress-date
- stop-rendering-at position near-note
- first-reference-note-number ignore-et-al
- bib-entry locator-only use-short-title
- locator-extra locator-date))
- cite)))
- (nconc cite-vv item-vv)))
-
-(defun citeproc-cite--render (cite style &optional internal-links)
- "Render CITE in STYLE, together with its affixes.
-If the prefix or suffix in CITE don't contain trailing and
-leading spaces then they are added. If the optional
-INTERNAL-LINKS is `bib-links' then link cites to the bibliography
-regardless of the style type, if `no-links' then don't add
-internal links, if nil or `auto' then add internal links based on
-the style type (cite-cite links for note styles and cite-bib
-links else). For legacy reasons, any other value is treated as
-`no-links'."
- (-let* ((result nil)
- ((&alist 'suffix suff
- 'prefix pref
- 'bib-entry bib-entry
- 'locator-only locator-only
- 'stop-rendering-at stop-rendering-at)
- cite)
- (rt-pref (citeproc-rt-from-str pref))
- (plain-pref (citeproc-rt-to-plain rt-pref))
- (rt-suff (citeproc-rt-from-str suff))
- (plain-suff (citeproc-rt-to-plain rt-suff))
- (mode (if bib-entry 'bib 'cite))
- (varlist (citeproc-cite--varlist cite)))
- ;; Remove cite-number when cite is the full bibliography entry.
- (when (and (eq mode 'bib) (not stop-rendering-at))
- (push '(citation-number) varlist))
- (let ((rendered-varlist
- (citeproc-render-varlist-in-rt
- varlist style mode 'display
- ;; No link-targets for bib-entry based citations.
- (if (eq mode 'bib) 'no-links internal-links)
- ;; No external limking for title-only citations, since we link to the
- ;; corresponding bibliography entry.
- (eq stop-rendering-at 'title))))
- ;; Locator-only cites require extensive post-processing of full cite.
- (when locator-only
- (setq rendered-varlist (citeproc-rt-locator-w-label rendered-varlist)))
- ;; Title-only cites
- (when (eq stop-rendering-at 'title)
- (when-let* ((cite-no-attr
- (citeproc-context-int-link-attrval
- style internal-links 'cite (alist-get 'position varlist)))
- (cite-no-attr-val (cons cite-no-attr
- (alist-get 'citation-number varlist))))
- ;; Add cited-item-no attr to link to the bibliography entry
- (setf (car rendered-varlist)
- (-snoc (car rendered-varlist) cite-no-attr-val))))
- ;; Add cite prefix and suffix
- (when (s-present-p plain-suff)
- (push (citeproc-rt-from-str suff) result)
- (unless (memql (aref plain-suff 0) '(?, ?\s))
- (push " " result)))
- (push rendered-varlist result)
- (when (s-present-p plain-pref)
- (unless (= (aref plain-pref (1- (length plain-pref))) ?\s)
- (push " " result))
- (push rt-pref result))
- (citeproc-rt-join-formatted nil result nil))))
-
-(defun citeproc-cite-or-citegroup--render (c style internal-links top-dl gr-dl ys-dl ac-dl)
- "Render cite or cite-group C with STYLE.
-For the INTERNAL-LINKS argument see `citeproc-cite--render'.
-TOP-DL is the top-, GR-DL the group-, YS-DL the year-suffix- and
-AC-DL the after-collapse-delimiter to use."
- (cond ((and (car c) (memq (car c) '(top group year-suffix-collapsed)))
- (let ((delimiter (pcase (car c)
- ('top top-dl)
- ('group gr-dl)
- ('year-suffix-collapsed ys-dl))))
- (cons
- nil ; empty attribute list
- (nbutlast ; remove last delimiter
- (--mapcat (list (citeproc-cite-or-citegroup--render
- it style internal-links top-dl gr-dl ys-dl ac-dl)
- (if (and (car it) (memq (car it) '(group year-suffix-collapsed)))
- ac-dl
- delimiter))
- (cdr c))))))
- ((eq (car c) 'range)
- (list nil (citeproc-cite--render (cl-second c) style internal-links)
- "–" (citeproc-cite--render (cl-third c) style internal-links)))
- (t (citeproc-cite--render c style internal-links))))
-
-(defun citeproc-citation--render (c proc &optional internal-links)
- "Render citation C with CSL processor PROC.
-For the optional INTERNAL-LINKS argument see
-`citeproc-cite--render'."
- (let* ((style (citeproc-proc-style proc))
- (punct-in-quote
- (string= (alist-get 'punctuation-in-quote (citeproc-style-locale-opts style))
- "true"))
- (cites (citeproc-citation-cites c))
- (cite-attrs (citeproc-style-cite-layout-attrs style))
- (cite-layout-dl (alist-get 'delimiter cite-attrs)))
- ;; Remove delimiters from cite-attrs -- they are rendered 'manually' because of
- ;; the delimiter-after-collapse complications in rendering. Also remove affixes
- ;; if requested.
- (setq cite-attrs
- (if (citeproc-citation-suppress-affixes c)
- (--remove (memq (car it) '(delimiter prefix suffix)) cite-attrs)
- (--remove (eq (car it) 'delimiter) cite-attrs)))
- ;; Generate rendered cites
- (let ((rendered-cites
- (cond
- ((citeproc-citation-grouped c)
- (let ((gr-dl
- (alist-get 'cite-group-delimiter (citeproc-style-cite-opts style)))
- (ys-dl
- (alist-get 'year-suffix-delimiter (citeproc-style-cite-opts style)))
- (aft-coll-dl
- (alist-get
- 'after-collapse-delimiter (citeproc-style-cite-opts style))))
- (cdr (citeproc-cite-or-citegroup--render
- (cons 'top cites) ; indicate top level input
- style internal-links cite-layout-dl gr-dl ys-dl aft-coll-dl))))
- ((cdr cites)
- (cdr (--mapcat
- (list cite-layout-dl (citeproc-cite--render it style internal-links))
- cites)))
- (t
- (list (citeproc-cite--render (car cites) style internal-links))))))
- ;; Calculate inner and outer citation attrs (affixes go inside)
- (let* ((non-affixes (--remove (memq (car it) '(prefix suffix delimiter)) cite-attrs))
- (affixes (--filter (memq (car it) '(prefix suffix)) cite-attrs))
- (outer-attrs (and affixes non-affixes))
- (result
- (citeproc-rt-cull-spaces-puncts
- (citeproc-rt-finalize
- (citeproc-rt-render-affixes
- (citeproc-rt-join-formatted (if outer-attrs affixes cite-attrs)
- rendered-cites nil)
- t)
- punct-in-quote))))
- ;; Add outer (non-affix attrs) if needed
- (when outer-attrs
- (setq result (list outer-attrs result)))
- ;; Prepend author to textual citations
- (when (and (eq (citeproc-citation-mode c) 'textual)
- (not (member (citeproc-style-category style) '("numeric" "label"))))
- (let* ((first-elt (car cites)) ;; First elt is either a cite or a cite group.
- ;; If the latter then we need to locate the
- ;; first cite as the 2nd element of the first
- ;; cite group.
- (first-cite (if (eq 'group (car first-elt))
- (cadr first-elt)
- first-elt))
- (author-cite
- (append '((suppress-author . nil) (stop-rendering-at . names)
- (prefix) (suffix) (locator))
- first-cite))
- (rendered-author (citeproc-cite--render author-cite style 'no-links)))
- (when (listp rendered-author)
- (setq result `(nil ,rendered-author " " ,result)))))
- ;; Capitalize first
- (when (citeproc-citation-capitalize-first c)
- (setq result (citeproc-rt-change-case result #'citeproc-s-capitalize-first)))
- ;; Run the citation postprocessing hook
- (dolist (fn citeproc-citation-postprocess-functions)
- (setq result (funcall fn result)))
- result))))
-
-(defun citeproc-cites--collapse-indexed (cites index-getter no-span-pred)
- "Collapse continuously indexed cites in CITES.
-INDEX-GETTER is a function from cites to numeric indices,
-NO-SPAN-PRED is a predicate that returns non-nil for cites that
-cannot be part of a span. Return the collapsed cites list or nil
-if no cites were collapsed."
- (let (group-len start-cite prev-index end-cite result)
- (dolist (cite cites)
- (let* ((cur-index (funcall index-getter cite))
- (no-span-elt (funcall no-span-pred cite))
- (subsequent (and prev-index (= (1+ prev-index) cur-index))))
- ;; Process ending current group
- (when (and group-len (or no-span-elt (not subsequent)))
- (setq result (nconc (citeproc-cite-range--collapse
- start-cite end-cite
- group-len)
- result)))
- (cond (no-span-elt ; Not only cite-no
- (push cite result)
- (setq group-len nil))
- ((or (not group-len) (not subsequent)) ; New group starts
- (setq group-len 1
- start-cite cite
- prev-index cur-index))
- (t ; Group continues
- (cl-incf group-len)
- (setq end-cite cite
- prev-index cur-index)))))
- ;; Process the last group
- (when group-len
- (setq result (nconc (citeproc-cite-range--collapse
- start-cite end-cite group-len)
- result)))
- (if (/= (length cites) (length result))
- (nreverse result)
- nil)))
-
-(defun citeproc-cite-range--collapse (start-cite end-cite len)
- "Collapse cite span with START-CITE, END-CITE of LEN length.
-START-CITE end END-CITE is the first and last rendered cites of
-the span."
- (pcase len
- (1 (list start-cite))
- (2 (list end-cite start-cite))
- (_ (list (list 'range start-cite end-cite)))))
-
-(defun citeproc-citation--collapse-num-citeranges (citation)
- "Collapse numbered ranges in CITATION."
- (let* ((cites (citeproc-citation-cites citation))
- (cites-length (length cites)))
- (when (> cites-length 2)
- (-when-let (collapsed
- (citeproc-cites--collapse-indexed
- cites
- (lambda (x)
- (string-to-number
- (alist-get 'citation-number (citeproc-cite--varlist x))))
- (lambda (x) (alist-get 'locator (citeproc-cite--varlist x)))))
- (setf (citeproc-citation-cites citation) collapsed
- (citeproc-citation-grouped citation) t)))))
-
-(defun citeproc-cites--collapse-suff-citeranges (cites)
- "Collapse continuously year-suffixed CITES."
- (or (citeproc-cites--collapse-indexed
- cites
- (lambda (x)
- (string-to-char (alist-get 'year-suffix (citeproc-cite--varlist x) " ")))
- (lambda (_x) nil))
- cites))
-
-(defun citeproc-citation--render-formatted-citation (c proc format &optional internal-links)
- "Render citation C with csl processor PROC in FORMAT.
-For the optional INTERNAL-LINKS argument see
-`citeproc-cite--render'."
- (let ((fmt (citeproc-formatter-for-format format)))
- (funcall (citeproc-formatter-cite fmt)
- (funcall (citeproc-formatter-rt fmt)
- (citeproc-citation--render c proc internal-links)))))
-
-(defun citeproc-citation--sort-cites (citation proc)
- "Sort cites in CITATION for processor PROC."
- (let ((cites (citeproc-citation-cites citation)))
- (when (cdr cites)
- (let* ((style (citeproc-proc-style proc))
- (sort-orders (citeproc-style-cite-sort-orders style)))
- (setf (citeproc-citation-cites citation)
- (sort
- (--map (cons (cons 'key ; add keys to the cites as extra attr
- (citeproc-sort--render-keys style (citeproc-cite--varlist it) 'cite))
- it)
- cites)
- (lambda (x y) (citeproc-sort--compare-keylists (cdar x) (cdar y) sort-orders))))))))
-
-(defun citeproc-proc-sort-cites (proc)
- "Sort cites in all citations of PROC."
- (when (citeproc-style-cite-sort (citeproc-proc-style proc))
- (dolist (citation (queue-head (citeproc-proc-citations proc)))
- (citeproc-citation--sort-cites citation proc))))
-
-(defun citeproc-proc-apply-citation-modes (proc)
- "Apply mode to the first cite in each citation in PROC."
- (dolist (citation (queue-head (citeproc-proc-citations proc)))
- (let ((mode (citeproc-citation-mode citation))
- (cites (citeproc-citation-cites citation))
- (ignore-et-al (citeproc-citation-ignore-et-al citation)))
- (-when-let (mode-rep
- (alist-get mode citeproc-cite--from-mode-alist))
- (setf (car cites) (nconc (car cites) mode-rep)))
- (when ignore-et-al
- (push '(ignore-et-al . t) (car cites))))))
-
-(defun citeproc-proc-group-and-collapse-cites (proc)
- "Group and collapse cites in all citations of PROC."
- (let* ((cite-opts (citeproc-style-cite-opts (citeproc-proc-style proc)))
- (group-delim (alist-get 'cite-group-delimiter cite-opts))
- (collapse-type (alist-get 'collapse cite-opts))
- (collapse-year-type
- (when collapse-type
- (let ((cy (member collapse-type
- '("year" "year-suffix" "year-suffix-ranged"))))
- (and cy (car cy))))))
- ;; Collapse (and group) according to collapse type
- (cond ((or group-delim collapse-year-type)
- ;; Group and possibly collapse
- (dolist (citation (queue-head (citeproc-proc-citations proc)))
- (citeproc-citation--group-and-collapse-cites citation proc collapse-type)))
- ;; Collapse numeric cites
- ((string= collapse-type "citation-number")
- (dolist (citation (queue-head (citeproc-proc-citations proc)))
- (citeproc-citation--collapse-num-citeranges citation))))))
-
-(defun citeproc-citation--group-and-collapse-cites (c proc &optional collapse-type)
- "Divide items in citation C in place into groups for PROC.
-Apart from movement necessary for grouping, the relative
-positions of cites in C is kept. If optional COLLAPSE-TYPE is
-given then collapse the groups accordingly."
- (let ((cites (citeproc-citation-cites c)))
- (when (cdr cites)
- (let (groups)
- (dolist (cite cites)
- (let ((g-ind
- ;; Cites are in the same group iff the cdrs of the rendered cite's first
- ;; name-var are equal. The cdr is taken because we ignore attributes, in
- ;; particular the cited-item-no attribute which is added when the cite consists
- ;; entirely of the rendered name var
- (--find-index (equal (cdr (citeproc-cite--first-namevar-cont cite proc))
- (cdr (citeproc-cite--first-namevar-cont (car it) proc)))
- groups)))
- (if g-ind
- (push cite (nth g-ind groups))
- (push (list cite) groups))))
- (unless (= (length groups) (length cites))
- (setf (citeproc-citation-cites c)
- (nreverse
- (--map (if (cdr it)
- (cons 'group
- (pcase collapse-type
- ("year"
- (citeproc-citation-group--collapse-year (nreverse it)))
- ("year-suffix"
- (citeproc-citation-group--collapse-ys (nreverse it) proc nil))
- ("year-suffix-ranged"
- (citeproc-citation-group--collapse-ys (nreverse it) proc t))
- (_ (nreverse it))))
- (car it))
- groups))
- (citeproc-citation-grouped c) t))))))
-
-(defun citeproc-citation-group--collapse-year (cites)
- "Collapse year in group CITES."
- (cons (car cites)
- (--map (cons '(suppress-author . t) it)
- (cdr cites))))
-
-(defun citeproc-citation-group--collapse-ys (cites proc collapse-ranges)
- "Collapse year and suffix in group CITES using PROC.
-If optional COLLAPSE-RANGES is non-nil then collapse year-suffix
-ranges."
- (let ((first t) (groups (list (list (car cites))))
- prev-datevar-cont prev-locator)
- (dolist (cite cites)
- (let* ((varlist (citeproc-cite--varlist cite))
- (datevar-cont (cadr (citeproc-cite--first-datevar-cont cite proc)))
- (locator (alist-get 'locator varlist)))
- (cond (first
- (setq first nil))
- ((or prev-locator
- locator
- (not (alist-get 'year-suffix varlist))
- (not (equal datevar-cont prev-datevar-cont)))
- (push (list (cons '(suppress-author . t)
- cite))
- groups))
- (t
- (push (cons '(suppress-date . t)
- (cons '(suppress-author . t)
- cite))
- (car groups))))
- (setq prev-datevar-cont datevar-cont
- prev-locator locator))
- cites)
- (nreverse
- (--map (if (cdr it)
- (cons 'year-suffix-collapsed
- (if (and collapse-ranges (> (length cites) 2))
- (citeproc-cites--collapse-suff-citeranges (nreverse it))
- (nreverse it)))
- (car it))
- groups))))
-
-(defun citeproc-citations--itd-referred-p (itd citations)
- "Whether ITD is referred to in CITATIONS."
- (let ((cites (--mapcat (citeproc-citation-cites it) citations)))
- (--any-p (eq itd (alist-get 'itd it)) cites)))
-
-(defun citeproc-cite--update-nn-queue (q index nnd)
- "Remove too distant citations from near-notes queue Q.
-INDEX is the actual note-index, NND is the near-note-distance."
- (while (and (queue-head q)
- (< nnd (- index
- (citeproc-citation-note-index (queue-first q)))))
- (queue-dequeue q)))
-
-(defun citeproc-cite--loc-equal-p (s1 s2)
- "Whether locator strings S1 and S2 refer to the same location."
- (if (and (citeproc-lib-numeric-p s1) (citeproc-lib-numeric-p s2))
- (equal (citeproc-number-extract s1) (citeproc-number-extract s2))
- (string= (s-trim s1) (s-trim s2))))
-
-(defvar citeproc-disambiguation-cite-pos 'last
- "Which cite position should be the basis of cite disambiguation.
-Possible values are `last', `first' and `subsequent'.")
-
-(defun citeproc-proc-update-positions (proc)
- "Update all position-related fields in PROC."
- (citeproc-proc-delete-occurrence-info proc)
- (let* ((ctns (queue-head (citeproc-proc-citations proc)))
- (cite-opts (citeproc-style-cite-opts (citeproc-proc-style proc)))
- (nnd (string-to-number
- (or (alist-get 'near-note-distance cite-opts)
- "5")))
- (near-note-ctns (make-queue))
- prev-itd prev-loc prev-label)
- (unless (eq citeproc-disambiguation-cite-pos 'last)
- (dolist (itd (hash-table-values
- (citeproc-proc-itemdata proc)))
- (setf (citeproc-itemdata-disamb-pos itd) citeproc-disambiguation-cite-pos)))
- (dolist (ctn ctns)
- (let* ((note-ind (citeproc-citation-note-index ctn))
- (cites (citeproc-citation-cites ctn))
- (single-cite (not (cdr cites))))
- (when note-ind (citeproc-cite--update-nn-queue near-note-ctns note-ind nnd))
- (let (seen-itds)
- (while cites
- (let* ((cite (car cites))
- (itd (alist-get 'itd cite))
- (locator (alist-get 'locator cite))
- (label (alist-get 'label cite))
- (pos (if (citeproc-itemdata-occurred-before itd)
- (if (eq itd prev-itd)
- (if prev-loc
- (if locator
- (if (and (citeproc-cite--loc-equal-p prev-loc locator)
- (string= prev-label label))
- 'ibid
- 'ibid-with-locator)
- 'subsequent)
- (if locator 'ibid-with-locator 'ibid))
- 'subsequent)
- 'first)))
- (when (and note-ind
- (or (citeproc-citations--itd-referred-p itd (queue-head near-note-ctns))
- (memq itd seen-itds)))
- (setf (alist-get 'near-note (car cites)) t))
- (setf (alist-get 'position (car cites)) pos
- prev-itd itd
- prev-loc locator
- prev-label label)
- (when (eq citeproc-disambiguation-cite-pos 'last)
- (citeproc-itd-update-disamb-pos itd pos))
- (let ((prev-occurrence (citeproc-itemdata-occurred-before itd)))
- (if prev-occurrence
- (unless (eq t prev-occurrence)
- (setf (alist-get 'first-reference-note-number (car cites))
- (number-to-string prev-occurrence)))
- (setf (citeproc-itemdata-occurred-before itd) (or note-ind t))))
- (push itd seen-itds)
- (pop cites))))
- (unless single-cite
- (setq prev-itd nil prev-loc nil prev-label nil))
- (when note-ind (queue-append near-note-ctns ctn))))))
-
-(defun citeproc-proc-finalize (proc)
- "Finalize processor PROC by sorting and disambiguating items."
- (unless (citeproc-proc-finalized proc)
- (citeproc-proc-process-uncited proc)
- (citeproc-sb-add-subbib-info proc)
- (citeproc-sb-prune-unrendered proc)
- (citeproc-proc-update-sortkeys proc)
- (citeproc-proc-sort-itds proc)
- (citeproc-proc-update-positions proc)
- (citeproc-proc-disamb proc)
- (citeproc-proc-sort-cites proc)
- (citeproc-proc-apply-citation-modes proc)
- (citeproc-proc-group-and-collapse-cites proc)
- (setf (citeproc-proc-finalized proc) t)))
-
-(defun citeproc-cite--first-namevar-cont (cite proc)
- "Return the first raw name-var node of CITE rendered with PROC."
- (citeproc-rt-find-first-node
- (citeproc-itd-rt-cite (alist-get 'itd cite) (citeproc-proc-style proc))
- (lambda (x)
- (and (consp x) (memq (alist-get 'rendered-var (car x))
- citeproc--name-vars)))))
-
-(defun citeproc-cite--first-datevar-cont (cite proc)
- "Return the first raw date-var node of CITE rendered with PROC."
- (citeproc-rt-find-first-node
- (citeproc-itd-rt-cite (alist-get 'itd cite) (citeproc-proc-style proc))
- (lambda (x)
- (and (consp x) (memq (alist-get 'rendered-var (car x))
- citeproc--date-vars)))))
-(provide 'citeproc-cite)
-
-;;; citeproc-cite.el ends here
+++ /dev/null
-;;; citeproc-context.el --- rendering context for CSL elements -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2017-2021 András Simonyi
-
-;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
-
-;; 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 3 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.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; Provides the `citeproc-context' CL-structure type to represent rendering
-;; contexts for CSL elements, and functions for accessing context-dependent
-;; information (variable and term values etc.). Also contains some functions
-;; that perform context-dependent formatting (e.g., quoting).
-
-;;; Code:
-
-(require 'let-alist)
-(require 'subr-x)
-
-(require 'citeproc-lib)
-(require 'citeproc-rt)
-(require 'citeproc-term)
-(require 'citeproc-prange)
-(require 'citeproc-style)
-
-(cl-defstruct (citeproc-context (:constructor citeproc-context--create))
- "A struct representing the context for rendering CSL elements."
- vars macros terms date-text date-numeric opts locale-opts
- mode render-mode render-year-suffix no-external-links locale)
-
-(defun citeproc-context-create (var-alist style mode render-mode
- &optional no-external-links)
- "Create a citeproc-context struct from var-values VAR-ALIST and csl style STYLE.
-MODE is either `bib' or `cite', RENDER-MODE is `display' or `sort'."
- (citeproc-context--create
- :vars var-alist
- :macros (citeproc-style-macros style)
- :terms (citeproc-style-terms style)
- :date-text (citeproc-style-date-text style)
- :date-numeric (citeproc-style-date-numeric style)
- :opts (citeproc-style-global-opts style mode)
- :locale (citeproc-style-locale style)
- :locale-opts (citeproc-style-locale-opts style)
- :mode mode
- :render-mode render-mode
- :render-year-suffix (not (citeproc-style-uses-ys-var style))
- :no-external-links no-external-links))
-
-(defconst citeproc--short-long-var-alist
- '((title . title-short) (container-title . container-title-short))
- "Alist mapping the long form of variables names to their short form.")
-
-(defun citeproc-var-value (var context &optional form)
- "Return the value of csl variable VAR in CONTEXT.
-VAR is a symbol, CONTEXT is a `citeproc-context' struct, and the
-optional FORM can be nil, `short' or `long'."
- (let ((var-vals (citeproc-context-vars context)))
- (if (or (eq form 'short)
- ;; Also use the short form of title when the cite contains the
- ;; (use-short-title . t) pair. This is used for title-only citations.
- (and (eq var 'title) (alist-get 'use-short-title var-vals)))
- (-if-let* ((short-var (alist-get var citeproc--short-long-var-alist))
- (short-var-val (alist-get short-var var-vals)))
- short-var-val
- (alist-get var var-vals))
- (let ((var-val (alist-get var var-vals)))
- (if (and var-val (or (and (eq var 'locator)
- (string= (citeproc-var-value 'label context) "page"))
- (eq var 'page)))
- (let ((prange-format (citeproc-lib-intern (alist-get 'page-range-format
- (citeproc-context-opts context))))
- (sep (or (citeproc-term-text-from-terms "page-range-delimiter"
- (citeproc-context-terms context))
- "–")))
- (citeproc-rt-from-str (citeproc-prange-render var-val prange-format sep)))
- var-val)))))
-
-(defun citeproc-locator-label (context)
- "Return the current locator label variable from CONTEXT."
- (citeproc-var-value 'label context))
-
-(defun citeproc-rt-quote (rt context)
- "Return the quoted version of rich-text RT using CONTEXT."
- (let ((oq (citeproc-term-get-text "open-quote" context))
- (cq (citeproc-term-get-text "close-quote" context))
- (oiq (citeproc-term-get-text "open-inner-quote" context))
- (ciq (citeproc-term-get-text "close-inner-quote" context)))
- `(,oq ,@(citeproc-rt-replace-all-sim `((,oq . ,oiq) (,cq . ,ciq)
- (,oiq . ,oq) (,ciq . ,cq))
- (format "\\(%s\\|%s\\|%s\\|%s\\)" oq cq oiq ciq)
- rt)
- ,cq)))
-
-(defun citeproc-rt-textcased (rts case context)
- "Return rich-text content RTS in text-case CASE using CONTEXT.
-CASE is one of the following: `lowercase', `uppercase',
-`capitalize-first', `capitalize-all', `sentence', `title'."
- (pcase case
- ('uppercase
- (citeproc-rt-map-strings #'upcase rts t))
- ('lowercase
- (citeproc-rt-map-strings #'downcase rts t))
- ('capitalize-first
- (--map (citeproc-rt-change-case it #'citeproc-s-capitalize-first) rts))
- ('capitalize-all
- (--map (citeproc-rt-change-case it #'citeproc-s-capitalize-all) rts))
- ('sentence
- (--map (citeproc-rt-change-case it #'citeproc-s-sentence-case) rts))
- ('title
- (let ((locale (citeproc-context-locale context))
- (language (citeproc-var-value 'language context)))
- (if (or (and language (string-prefix-p "en" language))
- (and (null language)
- (or (and locale (string-prefix-p "en" locale))
- (null locale))))
- (--map (citeproc-rt-change-case it #'citeproc-s-title-case) rts)
- rts)))))
-
-(defun citeproc-rt-join-formatted (attrs rts context)
- "Join and format according to ATTRS the rich-texts in RTS."
- (let-alist attrs
- (let ((result (delq nil rts)))
- (when .text-case
- (setq result (citeproc-rt-textcased result (intern .text-case) context)))
- (when (string= .strip-periods "true") (setq result (citeproc-rt-strip-periods result)))
- (when (string= .quotes "true") (setq result (citeproc-rt-quote result context)))
- (push (citeproc-rt-select-attrs attrs citeproc-rt-ext-format-attrs) result)
- (if (and .delimiter
- (> (length result) 2))
- result
- (citeproc-rt-simplify-shallow result)))))
-
-(defun citeproc-rt-format-single (attrs rt context)
- "Format according to ATTRS rich-text RT using CONTEXT."
- (if (or (not rt) (and (char-or-string-p rt) (string= rt "")))
- nil
- (citeproc-rt-join-formatted attrs (list rt) context)))
-
-(defun citeproc-rt-typed-join (attrs typed-rts context)
- "Join and format according to ATTRS contents in list TYPED-RTS.
-TYPED RTS is a list of (RICH-TEXT . TYPE) pairs"
- (-let* ((types (--map (cdr it) typed-rts))
- (type (cond ((--all? (eq it 'text-only) types)
- 'text-only)
- ((--any? (eq it 'present-var) types)
- 'present-var)
- (t 'empty-vars))))
- (cons (citeproc-rt-join-formatted attrs
- (--map (car it) typed-rts)
- context)
- type)))
-
-(defun citeproc-term-get-text (term context)
- "Return the first text associated with TERM in CONTEXT."
- (citeproc-term-text-from-terms term (citeproc-context-terms context)))
-
-(defconst citeproc--term-form-fallback-alist
- '((verb-short . verb)
- (symbol . short)
- (verb . long)
- (short . long))
- "Alist containing the fallback form for each term form.")
-
-(defun citeproc-term-inflected-text (term form number context)
- "Return the text associated with TERM having FORM and NUMBER."
- (let ((matches
- (--select (string= term (citeproc-term-name it))
- (citeproc-context-terms context))))
- (if (not matches) nil
- (let (match)
- (while (and (not match) form)
- (setq match (--first (and (eq form (citeproc-term-form it))
- (or (not (citeproc-term-number it))
- (eq number (citeproc-term-number it))))
- matches))
- (unless match
- (setq form (alist-get form citeproc--term-form-fallback-alist))))
- (when match (citeproc-term-text match))))))
-
-(defun citeproc-term-get-gender (term context)
- "Return the gender of TERM or nil if none is given."
- (-if-let (match
- (--first (and (string= (citeproc-term-name it) term)
- (citeproc-term-gender it)
- (eq (citeproc-term-form it) 'long))
- (citeproc-context-terms context)))
- (citeproc-term-gender match)
- nil))
-
-(defun citeproc-context-int-link-attrval (style internal-links mode cite-pos)
- "Return an appropriate attribute to represent internal linking info.
-INTERNAL-LINKS is the internal linking mode, see the
-documentation of `citeproc-render-varlist-in-rt', while MODE is
-the rendering mode, `bib' or `cite', and CITE-POS is a cite
-position. Returns an appropriate attribute to be added or nil if
-no internal links should be produced."
- (let ((note-style (citeproc-style-cite-note style)))
- (unless (or (and internal-links (not (memq internal-links '(auto bib-links))))
- (and note-style (eq mode 'bib) (or (null internal-links)
- (eq internal-links 'auto))))
- (if (and note-style (not (eq internal-links 'bib-links)))
- ;; For note styles link subsequent cites to the first ones.
- (if (eq cite-pos 'first) 'bib-item-no 'cited-item-no)
- ;; Else link each cite to the corresponding bib item.
- (if (eq mode 'cite) 'cited-item-no 'bib-item-no)))))
-
-(defun citeproc-context-maybe-stop-rendering
- (trigger context result &optional var)
- "Stop rendering if a (`stop-rendering-at'. TRIGGER) pair is present in CONTEXT.
-In case of stopping return with RESULT. If the optional VAR
-symbol is non-nil then rendering is stopped only if VAR is eq to
-TRIGGER."
- (if (and (eq trigger (alist-get 'stop-rendering-at (citeproc-context-vars context)))
- (or (not var) (eq var trigger))
- (eq (cdr result) 'present-var))
- (let ((rt-result (car result)))
- (push '(stopped-rendering . t) (car rt-result))
- (throw 'stop-rendering (citeproc-rt-render-affixes rt-result)))
- result))
-
-(defun citeproc-render-varlist-in-rt (var-alist style mode render-mode &optional
- internal-links no-external-links)
- "Render an item described by VAR-ALIST with STYLE in rich-text.
-Does NOT finalize the rich-text rendering. MODE is either `bib'
-or `cite', RENDER-MODE is `display' or `sort'.
- If the optional INTERNAL-LINKS is `bib-links' then link cites
-to the bibliography regardless of the style type, if `no-links'
-then don't add internal links, if nil or `auto' then add internal
-links based on the style type (cite-cite links for note styles
-and cite-bib links else). For legacy reasons, any other value is
-treated as `no-links'.
- If the optional NO-EXTERNAL-LINKS is non-nil then don't add
-external links."
- (-if-let (unprocessed-id (alist-get 'unprocessed-with-id var-alist))
- ;; Itemid received no associated csl fields from the getter!
- (list nil (concat "NO_ITEM_DATA:" unprocessed-id))
- (let* ((context (citeproc-context-create var-alist style mode render-mode
- no-external-links))
- (layout-fun-accessor (if (eq mode 'cite) 'citeproc-style-cite-layout
- 'citeproc-style-bib-layout))
- (layout-fun (funcall layout-fun-accessor style)))
- (if (null layout-fun) "[NO BIBLIOGRAPHY LAYOUT IN CSL STYLE]"
- (let ((rendered (catch 'stop-rendering
- (funcall layout-fun context))))
- ;; Finalize external linking by linking the title if needed
- (when (and (eq mode 'bib) (not no-external-links))
- (-when-let ((var . val) (--any (assoc it var-alist)
- citeproc--linked-vars))
- (unless (cl-intersection (citeproc-rt-rendered-vars rendered)
- citeproc--linked-vars)
- (citeproc-rt-link-title rendered
- (concat (alist-get var citeproc--link-prefix-alist
- "")
- (alist-get var var-alist))))))
- ;; Add appropriate item-no information
- (when-let* ((cite-no-attr
- (citeproc-context-int-link-attrval
- style internal-links mode (alist-get 'position var-alist)))
- (cite-no-attr-val (cons cite-no-attr
- (alist-get 'citation-number var-alist))))
- (cond ((consp rendered) (setf (car rendered)
- (-snoc (car rendered) cite-no-attr-val)))
- ((stringp rendered) (setq rendered
- (list (list cite-no-attr-val) rendered)))))
- ;; Add year-suffix if needed
- (-if-let (year-suffix (alist-get 'year-suffix var-alist))
- (car (citeproc-rt-add-year-suffix
- rendered
- ;; year suffix is empty if already rendered by var just to delete the
- ;; suppressed date
- (if (citeproc-style-uses-ys-var style) "" year-suffix)))
- rendered))))))
-
-(provide 'citeproc-context)
-
-;;; citeproc-context.el ends here
+++ /dev/null
-;;; citeproc-date.el --- CSL date rendering -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2017 András Simonyi
-
-;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
-
-;; 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 3 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.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; Structure type and functions to render CSL date elements.
-
-;;; Code:
-
-(require 'subr-x)
-(require 'cl-lib)
-(require 'dash)
-(require 'let-alist)
-(require 's)
-
-(require 'citeproc-lib)
-(require 'citeproc-rt)
-(require 'citeproc-context)
-(require 'citeproc-number)
-
-(cl-defstruct (citeproc-date (:constructor citeproc-date-create))
- "Struct for representing dates.
-Slots YEAR, MONTH, DAY are integers, while SEASON and CIRCA are
-booleans. SEASON indicates whether the integer in slot MONTH is
-to be interpreted as a season number."
- (year nil) (month nil) (day nil) (season nil) (circa nil))
-
-(defun citeproc-date-parse (date-rep)
- "Parse CSL json date repr. DATE-REP into an internal one."
- (let-alist date-rep
- (--map (citeproc-date--conv it .season .circa) .date-parts)))
-
-(defun citeproc-date--conv (dates &optional season circa)
- "Convert date-part list DATES to a citeproc-date struct.
-Set the remaining slots to the values SEASON and CIRCA."
- (-let* ((numeric
- (--map (if (stringp it) (string-to-number it) it) dates))
- ((year month day) numeric))
- (citeproc-date-create :year year :month month :day day
- :season season :circa circa)))
-
-(defun citeproc-date--partattrs-for-sort (part-attrs)
- "Return a sort-key version of PART-ATTRS."
- (let (result)
- (when (assoc 'day part-attrs)
- (push '(day . ((form . "numeric-leading-zeros"))) result))
- (when (assoc 'month part-attrs)
- (push '(month . ((form . "numeric-leading-zeros"))) result))
- (when (assoc 'year part-attrs)
- (push '(year . ((form . "long"))) result))
- result))
-
-(defun citeproc--date (attrs context &rest body)
- "Function corresponding to the date CSL element."
- (-let* (((&alist 'variable var
- 'form form)
- attrs)
- (var-sym (intern var))
- (parsed-dates (citeproc-var-value var-sym context))
- ((d1 d2) parsed-dates)
- (result
- (if d1
- (progn
- (when form
- (let ((localized (citeproc-date--localized-attrs attrs body context)))
- (setq attrs (car localized)
- body (cdr localized))))
- (when (eq (citeproc-context-render-mode context) 'sort)
- (setq body (citeproc-date--partattrs-for-sort body)))
- (if (citeproc-date--renders-with-attrs-p d1 body)
- (progn
- (push `(rendered-var . ,(intern var)) attrs)
- (cons (if d2
- (citeproc-date--render-range d1 d2 attrs body context)
- (citeproc-date--render d1 attrs body context))
- 'present-var))
- (cons nil 'empty-vars)))
- (cons nil 'empty-vars))))
- ;; Handle `year' citation mode by stopping if needed
- (citeproc-context-maybe-stop-rendering 'issued context result var-sym)))
-
-(defun citeproc--date-part (attrs _context &rest _body)
- "Function corresponding to the date-part CSL element."
- (cons (intern (alist-get 'name attrs))
- attrs))
-
-(defun citeproc-date--renders-with-attrs-p (date part-attrs)
- "Whether DATE contains date-parts corresponding to PART-ATTRS."
- (let ((date-parts (mapcar #'car part-attrs)))
- (or (memq 'year date-parts) ; All dates contain a year
- (and (memq 'month date-parts) (citeproc-date-month date))
- (and (memq 'day date-parts) (citeproc-date-day date)))))
-
-(defun citeproc-date--localized-attrs (attrs part-attrs context)
- "Return the localized date attrs merged with date ATTRS and date PART-ATTRS."
- (-let* (((&alist 'form form
- 'date-parts date-parts)
- attrs)
- ((loc-attrs . loc-part-attrs)
- (if (string= form "text") (citeproc-context-date-text context)
- (citeproc-context-date-numeric context))))
- (pcase (citeproc-lib-intern date-parts)
- ('year
- (setq loc-part-attrs
- (--select (eq (car it) 'year) loc-part-attrs)))
- ('year-month
- (setq loc-part-attrs
- (--select (memq (car it) '(year month)) loc-part-attrs))))
- (cons (-concat attrs loc-attrs)
- (--map (cons (car it)
- (-concat (alist-get (car it) part-attrs) (cdr it)))
- loc-part-attrs))))
-
-(defun citeproc-date--render (d attrs part-attrs context)
- "Render citeproc-date D according to formatting in ATTRS and PART-ATTRS.
-Return a rich-text content."
- (if (citeproc-var-value 'suppress-date context)
- (citeproc-rt-format-single attrs "<suppressed-date>" context)
- (let ((rendered-date (citeproc-date--render-parts d part-attrs context)))
- (citeproc-rt-join-formatted attrs rendered-date context))))
-
-(defun citeproc-date--render-parts (d part-attrs context &optional no-last-suffix)
- "Render the parts of citeproc-date D according to PART-ATTRS.
-Return a list of rich-text contents. If optional NO-LAST-SUFFIX
-is non-nil then remove the suffix attribute of the last rendered
-element (used for date range rendering)."
- (let ((result (--map (pcase (car it)
- ('year (citeproc-date--render-year d (cdr it) context))
- ('month (citeproc-date--render-month d (cdr it) context))
- ('day (citeproc-date--render-day d (cdr it) context)))
- part-attrs)))
- (-if-let* ((n-l-s no-last-suffix)
- (last (car (last result)))
- (wo-suffix (and (consp last)
- (cons (--remove (eq 'suffix (car it)) (car last))
- (cdr last)))))
- (-snoc (butlast result) wo-suffix)
- result)))
-
-(defun citeproc-date--render-range-parts (d1 d2 part-attrs sep context)
- "Render the parts of citeproc-dates D1 and D2 according to PART-ATTRS.
-PART-ATTRS is a list containing either part-attrs or lists of part-attrs.
-The formers are only rendered for D1, while the latters are rendered for both
-D1 and D2. Return a list of rich-text contents."
- (--mapcat (pcase (car it)
- ('year (list (citeproc-date--render-year d1 (cdr it) context)))
- ('month (list (citeproc-date--render-month d1 (cdr it) context)))
- ('day (list (citeproc-date--render-day d1 (cdr it) context)))
- (_ (-concat (citeproc-date--render-parts d1 it context t)
- (list sep)
- (citeproc-date--render-parts d2 it context))))
- part-attrs))
-
-(defun citeproc-date--render-range (d1 d2 attrs part-attrs context)
- "Render the range given by dates D1 D2 according to attrs."
- (if (citeproc-var-value 'suppress-date context)
- (citeproc-rt-format-single attrs "" context)
- (let* ((gran (min (citeproc-date--gran d1)
- (citeproc-date--attrs-gran part-attrs)))
- (range-sep (or (alist-get 'range-delimiter
- (alist-get (elt '(year month day) gran)
- part-attrs))
- "–"))
- (range-p-attrs
- (cond ((/= (citeproc-date-year d1) (citeproc-date-year d2))
- (list part-attrs))
- ((/= (citeproc-date-month d1) (citeproc-date-month d2))
- (let ((year-part (--find (eq 'year (car it))
- part-attrs))
- (attrs-wo-year
- (--remove (eq 'year (car it))
- part-attrs)))
- (cond ((eq (caar part-attrs) 'year)
- (list year-part attrs-wo-year))
- ((eq (caar (last part-attrs)) 'year)
- (list attrs-wo-year year-part))
- (t (list attrs-wo-year)))))
- (t (--map (if (eq (car it) 'day) (list it) it)
- part-attrs))))
- (rendered-range (citeproc-date--render-range-parts d1 d2 range-p-attrs range-sep
- context)))
- (citeproc-rt-join-formatted attrs rendered-range context))))
-
-(defun citeproc-date--attrs-gran (d-attrs)
- "Return the granularity (smallest unit) of date-attrs alist D-ATTRS.
-The returned value is 0, 1 or 2, corresponding to a year, month
-or day granularity."
- (cond ((assoc 'day d-attrs) 2)
- ((assoc 'month d-attrs) 1)
- (t 0)))
-
-(defun citeproc-date--gran (date)
- "Return the granularity (smallest unit) in citeproc-date struct DATE.
-The returned value is 0, 1 or 2, corresponding to a year, month
-or day granularity."
- (cond ((citeproc-date-day date) 2)
- ((citeproc-date-month date) 1)
- (t 0)))
-
-(defun citeproc-date--render-year (d attrs context)
- "Render the year in date D according to formatting in ATTRS.
-D is a citeproc-date structure. Return a rich-text content."
- (-let* ((form (alist-get 'form attrs))
- (year (citeproc-date-year d))
- (s (number-to-string (abs year)))
- (era
- (cond ((> year 999) "")
- ((> year 0) (citeproc-term-get-text "ad" context))
- (t (citeproc-term-get-text "bc" context)))))
-
- (citeproc-rt-format-single attrs (concat (if (string= form "short")
- (s-right 2 s)
- s)
- era)
- context)))
-
-(defun citeproc-date--render-month (d attrs context)
- "Render the month in date D according to formatting in ATTRS.
-D is a citeproc-date structure. Return a rich-text content."
- (-if-let (month (citeproc-date-month d))
- (let ((form (alist-get 'form attrs))
- (term-pref (if (citeproc-date-season d)
- "season-" "month-")))
- (citeproc-rt-format-single
- attrs
- (pcase (citeproc-lib-intern form)
- ('numeric (number-to-string month))
- ('numeric-leading-zeros (format "%02d" month))
- ('short (citeproc-term-inflected-text
- (concat term-pref (format "%02d" month))
- 'short nil context))
- (_ (citeproc-term-inflected-text
- (concat term-pref (format "%02d" month))
- 'long nil context)))
- context))
- nil))
-
-(defun citeproc-date--render-day (d attrs context)
- "Render the day in date D according to formatting in ATTRS.
-D is a citeproc-date structure. Return a rich-text content."
- (-if-let (day (citeproc-date-day d))
- (let ((form (alist-get 'form attrs))
- (month (citeproc-date-month d)))
- (citeproc-rt-format-single
- attrs
- (cond
- ((string= form "numeric-leading-zeros")
- (format "%02d" day))
- ((and (string= form "ordinal")
- (or (= day 1)
- (not (string= "true"
- (alist-get 'limit-day-ordinals-to-day-1
- (citeproc-context-locale-opts context))))))
- (citeproc-number--format-as-ordinal (number-to-string day)
- (concat "month-" (format "%02d" month))
- context))
- (t (number-to-string day)))
- context))
- nil))
-
-(provide 'citeproc-date)
-
-;;; citeproc-date.el ends here
+++ /dev/null
-;;; citeproc-disamb.el --- disambiguate ambiguous cites -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2017 András Simonyi
-
-;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
-
-;; 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 3 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.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; Functions to disambiguate cites of different bibliography items that would
-;; have the same rendering. Disambiguation steps (e.g., adding more names,
-;; expanding names, adding year-suffixes) are performed according to the
-;; disambiguation rules specified by the CSL style in use.
-
-;;; Code:
-
-(require 'dash)
-(require 'cl-lib)
-(require 'subr-x)
-
-(require 'citeproc-itemdata)
-
-(defun citeproc-itd-inc-disamb-level (key itd type)
- "Increment the disambiguation level of KEY in itemdata ITD.
-TYPE is either `add-names' or `show-given-names.'"
- (let ((vv (citeproc-itemdata-varvals itd)))
- (if (alist-get type vv)
- (let* ((cur-level (alist-get key (alist-get type vv)))
- (new-level (if cur-level (1+ cur-level) 1)))
- (setf (alist-get key (alist-get type vv)) new-level))
- (push `(,type . ((,key . 1))) (citeproc-itemdata-varvals itd))))
- (setf (citeproc-itemdata-rc-uptodate itd) nil))
-
-(defun citeproc-itd-add-name (itd style &optional _first-step)
- "Perform an add-name disambig. step on itemdata ITD with STYLE.
-FIRST-STEP is ignored -- it is there to get the same signature as
-the other two disamb. step functions. Return nil if no disambiguation
-could be performed and t otherwise. Disambiguation is performed
-from left to right: an item is attempted to be expanded only if
-no previous items to the left could be."
- (let* ((vars (citeproc-itd-namevars itd style))
- (cite (citeproc-itd-plain-cite itd style))
- (vv (citeproc-itemdata-varvals itd))
- (levels (alist-get 'add-names vv))
- (remaining-vars (if levels (memq (caar levels) vars) vars))
- (success nil))
- (while (and (not success) remaining-vars)
- (citeproc-itd-inc-disamb-level (car remaining-vars) itd 'add-names)
- (if (string= cite (citeproc-itd-plain-cite itd style))
- (pop remaining-vars)
- (setq success t)))
- success))
-
-(defun citeproc-itd-add-given (itd style &optional first-step)
- "Perform an add-given disambig. step on itemdata ITD with STYLE.
-Unless FIRST-STEP is non-nil, remove the last previously added
-given name if the last added given name is shown in its entirety.
-Return nil if no disambig. step could be performed and t
-otherwise."
- (let* ((nids (citeproc-itd-nameids itd style))
- (cite (citeproc-itd-plain-cite itd style))
- (vv (citeproc-itemdata-varvals itd))
- (levels (alist-get 'show-given-names vv))
- (remaining-nids (if levels (memq (caar levels) nids) nids))
- (success nil))
- (while (and (not success) remaining-nids)
- (let* ((current-nid (car remaining-nids))
- (vv (citeproc-itemdata-varvals itd))
- (levels (alist-get 'show-given-names vv))
- (current-level (alist-get current-nid levels)))
- (if (and current-level (>= current-level 2))
- (pop remaining-nids)
- (citeproc-itd-inc-disamb-level current-nid itd 'show-given-names)
- (unless (string= cite (citeproc-itd-plain-cite itd style))
- (setq success t)
- (unless (or first-step current-level)
- (let ((ls (alist-get 'show-given-names vv)))
- (setf (alist-get 'show-given-names vv)
- (cons (car ls) (cddr ls))))
- (setf (citeproc-itemdata-rc-uptodate itd) nil))))))
- success))
-
-(defun citeproc-itd-addgiven-with-addname (itd style &optional first-step)
- "Perform a combined disambig. step on itemdata ITD with STYLE.
-If FIRST-STEP is non-nil then (i) add a new name even if the last
-add-given step showed only initials, (ii) don't remove the
-previously added given name. Return nil if no disambig. step
-could be performed and t otherwise."
- (let* ((vv (citeproc-itemdata-varvals itd))
- (gn (alist-get 'show-given-names vv))
- (success nil)
- (remaining-names t))
- (if (and (not first-step) gn (= 1 (cdar gn)) (citeproc-itd-add-given itd style))
- t
- (while (and (not success) remaining-names)
- (let ((nids (citeproc-itd-nameids itd style)))
- (if (citeproc-itd-add-name itd style)
- (let* ((new-nids (citeproc-itd-nameids itd style))
- (new-nid (car (cl-set-difference new-nids nids))))
- ;;next sexp is to direct the add-given function to the just added name
- (when first-step
- (setf (alist-get new-nid
- (alist-get 'show-given-names
- (citeproc-itemdata-varvals itd)))
- 0))
- (when (citeproc-itd-add-given itd style first-step)
- (setq success t)))
- (setq remaining-names nil))))
- success)))
-
-(defun citeproc-disamb--different-cites-p (itds style)
- "Whether some itemdata in ITDS have different cites with STYLE."
- (--any-p (not (string= (citeproc-itd-plain-cite it style)
- (citeproc-itd-plain-cite (car itds) style)))
- (cdr itds)))
-
-(defun citeproc-disamb--with-method (itds style disamb-fun)
- "Disambiguate itemdatas in ITDS for STYLE with DISAMB-FUN.
-Return t if the disambiguation was (at least partially)
-successful and nil otherwise."
- (let ((orig-settings (copy-tree (citeproc-disamb--settings itds)))
- success
- (first-step t))
- (while (and (not success)
- (--all-p (funcall disamb-fun it style first-step) itds))
- (setq first-step nil)
- (when (citeproc-disamb--different-cites-p itds style)
- (setq success t)))
- (unless success
- (citeproc-disamb--restore-settings itds orig-settings))
- success))
-
-(defun citeproc-disamb--settings (itds)
- "Return a list with the disamb settings of ITDS."
- (--map (cons (citeproc-itd-getvar it 'add-names)
- (citeproc-itd-getvar it 'show-given-names))
- itds))
-
-(defun citeproc-disamb--restore-settings (itds settings)
- "Restore the disamb settings of ITDS from SETTINGS.
-SETTINGS should have the structure produced by citeproc--disamb-settings."
- (cl-loop for itd in itds
- for (add-names-val . show-given-val) in settings do
- (citeproc-itd-setvar itd 'add-names add-names-val)
- (citeproc-itd-setvar itd 'show-given-names show-given-val)))
-
-(defun citeproc-disamb--num-to-yearsuffix (n)
- "Return year-suffix no. N (starting from 0)."
- (cond ((< n 26)
- (char-to-string (+ 97 n)))
- ((< n 702)
- (let* ((rem (% n 26))
- (d (/ (- n rem) 26)))
- (concat (char-to-string (+ 96 d))
- (char-to-string (+ 97 rem)))))
- (t (error "Number too large to convert into a year-suffix"))))
-
-(defun citeproc-disamb--add-yearsuffix (itds _style)
- "Disambiguate itemdata in ITDS by adding year suffices.
-Return t (for the sake of consistency with other disamb methods)."
- (--each-indexed (--sort (< (string-to-number (citeproc-itd-getvar it 'citation-number))
- (string-to-number (citeproc-itd-getvar other 'citation-number)))
- itds)
- (citeproc-itd-setvar it 'year-suffix (citeproc-disamb--num-to-yearsuffix it-index))
- (setf (citeproc-itemdata-rc-uptodate it) nil))
- t)
-
-(defun citeproc-disamb--set-fields (itds)
- "Disambiguate ITDS by setting their disambiguate fields."
- (--each itds
- (citeproc-itd-setvar it 'disambiguate t)))
-
-(defun citeproc-disamb-amb-itds (itds style name given yearsuff)
- "Disambiguate ITDS ambigous for STYLE with the given methods.
-NAME, GIVEN and YEARSUFF are generalized booleans specifying
-whether or not the add-name, show-given or add-year-suffix
-disambiguation methods should be used. Return t if the
-disambiguation was (at least partially) successful, nil
-otherwise."
- (or (and name (citeproc-disamb--with-method itds style 'citeproc-itd-add-name))
- (and given (citeproc-disamb--with-method itds style 'citeproc-itd-add-given))
- (and name given
- (citeproc-disamb--with-method itds style 'citeproc-itd-addgiven-with-addname))
- (progn
- (citeproc-disamb--set-fields itds)
- (citeproc-disamb--different-cites-p itds style))
- (and yearsuff
- (citeproc-disamb--add-yearsuffix itds style)
- (citeproc-disamb--different-cites-p itds style))))
-
-(defun citeproc-amb-itds (itds style)
- "Return a list of ambigous sets in ITDS for STYLE.
-The returned value is a (possibly empty) list of lists."
- (let* ((sorted (-sort (lambda (x y)
- (string< (citeproc-itd-plain-cite x style)
- (citeproc-itd-plain-cite y style)))
- itds))
- (result nil)
- (remaining (cdr sorted))
- (act (car sorted))
- (act-list (list act))
- (ambig nil))
- (while remaining
- (let ((next (car remaining)))
- (if (string= (citeproc-itd-plain-cite act style)
- (citeproc-itd-plain-cite next style))
- (progn
- (push next act-list)
- (setq ambig t))
- (when ambig (push act-list result))
- (setq act-list (list next)
- act next
- ambig nil))
- (pop remaining)))
- (when ambig (push act-list result))
- result))
-
-(defun citeproc-disamb-itds (itds style name given yearsuff)
- "Disambiguate itemdatas in list ITDS for STYLE.
-NAME, GIVEN and YEARSUFF are generalized booleans specifying
-whether or not the add-name, show-given or add-year-suffix
-disambiguation methods should be used."
- (let ((amb-itds (citeproc-amb-itds itds style)))
- (while amb-itds
- (let ((act-set (pop amb-itds)))
- (citeproc-disamb-amb-itds act-set style name given yearsuff)
- (when (citeproc-disamb--different-cites-p act-set style)
- (-when-let (new-ambs (citeproc-amb-itds act-set style))
- (setq amb-itds (nconc new-ambs amb-itds))))))))
-
-(provide 'citeproc-disamb)
-
-;;; citeproc-disamb.el ends here
+++ /dev/null
-;; citeproc-formatters.el --- output formatters -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2017-2021 András Simonyi
-
-;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
-
-;; 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 3 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.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; Provides a general framework for defining citeproc-el output formatters, and,
-;; using this framework, defines formatters for the formats `raw' (the rich-text
-;; internal representation), `plain' (plain-text), `html', `org' and `latex'.
-;; Further output formatters can easily be added.
-
-;;; Code:
-
-(require 'let-alist)
-(require 'subr-x)
-(require 's)
-(require 'cl-lib)
-
-(require 'citeproc-s)
-(require 'citeproc-rt)
-
-(cl-defstruct (citeproc-formatter (:constructor citeproc-formatter-create))
- "Output formatter struct with slots RT, CITE, BIB-ITEM and BIB.
-RT is a one-argument function mapping a rich-text to its
- formatted version,
-CITE is a one-argument function mapping the output of RT for a
- citation rich-text to a fully formatted citation,
-BIB-ITEM is a two-argument function mapping the output of RT for
- a bibliography-item rich-text and a BIB-FORMAT alist (see
- below) to a fully formatted bibliography item,
-BIB is a two-argument function mapping a list of formatted
- bibliography items and a FORMATTING-PARAMETERS alist (see
- `citeproc-render-bib' for details) to a fully formatted
- bibliography,
-NO-EXTERNAL-LINKS is non-nil if the formatter doesn't support
- external linking."
- rt (cite #'identity) (bib-item (lambda (x _) x))
- (bib (lambda (x _) (mapconcat #'identity x "\n\n")))
- (no-external-links nil))
-
-(defun citeproc-formatter-fun-create (fmt-alist)
- "Return a rich-text formatter function based on FMT-ALIST.
-FMT-ALIST is an alist with some or all of the following symbols
-as keys:
-- `unformatted',
-- `font-style-italic', `font-style-oblique', `font-style-normal',
-- `font-variant-small-caps', `font-variant-normal',
-- `font-weight-bold', `font-weight-light', `font-weight-normal',
-- `text-decoration-underline', `text-decoration-normal',
-- `vertical-align-sub', `vertical-align-sup', `vertical-align-baseline',
-- `display-block', `display-left-margin', `display-right-inline',
- `display-indent',
-- `href',
-- `cited-item-no', `bib-item-no'.
-
-With the exceptions listed below the values should be
-one-argument formatting functions that format the input string
-according to the attribute-value pair specified by the key.
-
-The exceptions are the keys
-`unformatted', for which the value should be a one-argument
- function converting unformatted text into the required
- format (e.g., by escaping);
-`href', here the value should be a two-argument function
- mapping the first argument as anchor text and the second as
- target URI to a hyperlink representation; and
-`cited-item-no' and `bib-item-no' whose associated values
- should be two-argument functions, which are called with the
- already formatted cites/bibliography item text and the number of
- the bibliography item as a string."
- (cl-labels
- ((rt-fmt
- (rt)
- (pcase rt
- ((pred stringp) (funcall (alist-get 'unformatted fmt-alist) rt))
- ((pred consp)
- (let ((attrs (car rt))
- (result (mapconcat #'rt-fmt (cdr rt) "")))
- (dolist (attr attrs)
- (let ((key (car attr)))
- (if (memq key '(href cited-item-no bib-item-no))
- (when-let ((fmt-fun (alist-get key fmt-alist)))
- (setq result (funcall fmt-fun result (cdr attr))))
- (when-let
- ((fmt-fun
- (alist-get
- (pcase attr
- ('(font-style . "italic") 'font-style-italic)
- ('(font-weight . "bold") 'font-weight-bold)
- ('(display . "indent") 'display-indent)
- ('(display . "left-margin") 'display-left-margin)
- ('(display . "right-inline") 'display-right-inline)
- ('(display . "block") 'display-block)
- ('(vertical-align . "sup") 'vertical-align-sup)
- ('(vertical-align . "baseline") 'vertical-align-baseline)
- ('(font-variant . "small-caps") 'font-variant-small-caps)
- ('(text-decoration . "underline") 'text-decoration-underline)
- ('(font-style . "oblique") 'font-style-oblique)
- ('(font-style . "normal") 'font-style-normal)
- ('(font-variant . "normal") 'font-variant-normal)
- ('(font-weight . "light") 'font-weight-light)
- ('(font-weight . "normal") 'font-weight-normal)
- ('(text-decoration . "normal") 'text-decoration-normal)
- ('(vertical-align . "sub") 'vertical-align-sub))
- fmt-alist)))
- (setq result (funcall fmt-fun result))))))
- result))
- (_ rt))))
- #'rt-fmt))
-
-;;;; Specific formatters
-
-;; Org
-
-(defun citeproc-fmt--org-link (anchor target)
- "Return an Org link with ANCHOR and TARGET.
-If ANCHOR is string= to TARGET then return ANCHOR."
- (if (string= anchor target)
- anchor
- (concat "[[" target "][" anchor "]]")))
-
-(defconst citeproc-fmt--org-alist
- `((unformatted . identity)
- (href . ,#'citeproc-fmt--org-link)
- (cited-item-no . ,(lambda (x y) (concat "[[citeproc_bib_item_" y "][" x "]]")))
- (bib-item-no . ,(lambda (x y) (concat "<<citeproc_bib_item_" y ">>" x)))
- ;; Warning: The next four formatter lines put protective zero-width spaces
- ;; around the Org format characters ('/' etc.).
- (font-style-italic . ,(lambda (x) (concat "/" x "/")))
- (font-style-oblique . ,(lambda (x) (concat "/" x "/")))
- (font-weight-bold . ,(lambda (x) (concat "*" x "*")))
- (text-decoration-underline . ,(lambda (x) (concat "_" x "_")))
- ;; End of zero-width space protected formatters.
- (font-variant-small-caps . ,(lambda (x) (upcase x)))
- (vertical-align-sub . ,(lambda (x) (concat "_{" x "}")))
- (vertical-align-sup . ,(lambda (x) (concat "^{" x "}")))
- (display-left-margin . ,(lambda (x) (concat x " ")))))
-
-(defvar citeproc-fmt--org-format-rt-1
- (citeproc-formatter-fun-create citeproc-fmt--org-alist)
- "Recursive rich-text Org formatter.
-Doesn't do finalization by removing zero-width spaces.")
-
-(defun citeproc-fmt--org-format-rt (rt)
- "Convert rich-text RT into Org format.
-Performs finalization by removing unnecessary zero-width spaces."
- (let ((result (funcall citeproc-fmt--org-format-rt-1 rt)))
- (when (> (length result) 2)
- ;; First we remove z-w spaces around spaces and before punctuation.
- (setq result (citeproc-s-replace-all-seq
- result '((" " . " ") (" " . " ") ("," . ",") (";" . ";")
- (":" . ":") ("." . "."))))
- ;; Starting and ending z-w spaces are also removed, but not before an asterisk
- ;; to avoid creating an Org heading.
- (when (and (= (aref result 0) 8203)
- (not (= (aref result 1) ?*)))
- (setq result (substring result 1)))
- (when (= (aref result (- (length result) 1)) 8203)
- (setq result (substring result 0 -1)))
- ;; Prepend a zero width no-break space when the text starts with
- ;; superscript to make Org parse it correctly.
- ;; NOTE: This is a workaround, ideally should be fixed in Org.
- (when (= (aref result 0) ?^)
- (setq result (concat "" result))))
- result))
-
-;; HTML
-
-(defun citeproc-fmt--xml-escape (s)
- "Return the xml-escaped version of string S.
-Only '&', '<' and '>' are escaped to keep compatibility with the
-CSL tests."
- (citeproc-s-replace-all-seq s '(("&" . "&") ("<" . "<") (">" . ">"))))
-
-(defconst citeproc-fmt--html-alist
- `((unformatted . citeproc-fmt--xml-escape)
- (href . ,(lambda (x y) (concat "<a href=\"" y "\">" x "</a>")))
- (cited-item-no . ,(lambda (x y) (concat "<a href=\"#citeproc_bib_item_" y "\">"
- x "</a>")))
- (bib-item-no . ,(lambda (x y) (concat "<a id=\"citeproc_bib_item_" y "\"></a>"
- x)))
- (font-style-italic . ,(lambda (x) (concat "<i>" x "</i>")))
- (font-style-oblique . ,(lambda (x)
- (concat "<span style=\"font-style:oblique;\"" x "</span>")))
- (font-variant-small-caps . ,(lambda (x)
- (concat
- "<span style=\"font-variant:small-caps;\">" x "</span>")))
- (font-weight-bold . ,(lambda (x) (concat "<b>" x "</b>")))
- (text-decoration-underline .
- ,(lambda (x)
- (concat
- "<span style=\"text-decoration:underline;\">" x "</span>")))
- (vertical-align-sub . ,(lambda (x) (concat "<sub>" x "</sub>")))
- (vertical-align-sup . ,(lambda (x) (concat "<sup>" x "</sup>")))
- (vertical-align-baseline . ,(lambda (x) (concat "<span style=\"baseline\">" x "</span>")))
- (display-left-margin . ,(lambda (x) (concat "\n <div class=\"csl-left-margin\">"
- x "</div>")))
- (display-right-inline . ,(lambda (x) (concat "<div class=\"csl-right-inline\">"
- x "</div>\n ")))
- (display-block . ,(lambda (x) (concat "\n\n <div class=\"csl-block\">"
- x "</div>\n")))
- (display-indent . ,(lambda (x) (concat "<div class=\"csl-indent\">" x "</div>\n ")))))
-
-(defconst citeproc-fmt--csl-test-alist
- `((unformatted . citeproc-fmt--xml-escape)
- (cited-item-no . ,(lambda (x y) (concat "<a href=\"#citeproc_bib_item_" y "\">"
- x "</a>")))
- (bib-item-no . ,(lambda (x y) (concat "<a id=\"citeproc_bib_item_" y "\"></a>"
- x)))
- (font-style-italic . ,(lambda (x) (concat "<i>" x "</i>")))
- (font-style-oblique . ,(lambda (x)
- (concat "<span style=\"font-style:oblique;\"" x "</span>")))
- (font-variant-small-caps . ,(lambda (x)
- (concat
- "<span style=\"font-variant:small-caps;\">" x "</span>")))
- (font-weight-bold . ,(lambda (x) (concat "<b>" x "</b>")))
- (text-decoration-underline .
- ,(lambda (x)
- (concat
- "<span style=\"text-decoration:underline;\">" x "</span>")))
- (vertical-align-sub . ,(lambda (x) (concat "<sub>" x "</sub>")))
- (vertical-align-sup . ,(lambda (x) (concat "<sup>" x "</sup>")))
- (vertical-align-baseline . ,(lambda (x) (concat "<span style=\"baseline\">" x "</span>")))
- (display-left-margin . ,(lambda (x) (concat "\n <div class=\"csl-left-margin\">"
- x "</div>")))
- (display-right-inline . ,(lambda (x) (concat "<div class=\"csl-right-inline\">"
- x "</div>\n ")))
- (display-block . ,(lambda (x) (concat "\n\n <div class=\"csl-block\">"
- x "</div>\n")))
- (display-indent . ,(lambda (x) (concat "<div class=\"csl-indent\">" x "</div>\n ")))))
-
-(defun citeproc-fmt--html-bib-formatter (items _bib-format)
- "Return a html bibliography from already formatted ITEMS."
- (concat "<div class=\"csl-bib-body\">\n"
- (mapconcat (lambda (i)
- (concat " <div class=\"csl-entry\">" i "</div>\n"))
- items
- "")
- "</div>"))
-
-;; LaTeX
-
-(defconst citeproc-fmt--latex-esc-regex
- (regexp-opt '("_" "&" "#" "%" "$" "{" "}" ))
- "Regular expression matching characters to be escaped in LaTeX output.")
-
-(defun citeproc-fmt--latex-escape (s)
- "Return the LaTeX-escaped version of string S."
- (replace-regexp-in-string citeproc-fmt--latex-esc-regex "\\\\\\&" s))
-
-(defconst citeproc-fmt--latex-uri-esc-regex
- (regexp-opt '("#" "%"))
- "Regular expression matching characters to be escaped in URIs for LaTeX output.")
-
-(defun citeproc-fmt--latex-href (text uri)
- (let ((escaped-uri (replace-regexp-in-string
- citeproc-fmt--latex-uri-esc-regex "\\\\\\&" uri)))
- (if (string-prefix-p "http" text)
- (concat "\\url{" escaped-uri "}")
- (concat "\\href{" escaped-uri "}{" text "}"))))
-
-(defconst citeproc-fmt--latex-alist
- `((unformatted . ,#'citeproc-fmt--latex-escape)
- (href . ,#'citeproc-fmt--latex-href)
- (font-style-italic . ,(lambda (x) (concat "\\textit{" x "}")))
- (font-weight-bold . ,(lambda (x) (concat "\\textbf{" x "}")))
- (cited-item-no . ,(lambda (x y) (concat "\\citeprocitem{" y "}{" x "}")))
- (bib-item-no . ,(lambda (x y) (concat "\\hypertarget{citeproc_bib_item_" y "}{"
- x "}")))
- (font-variant-small-caps . ,(lambda (x) (concat "\\textsc{" x "}")))
- (text-decoration-underline . ,(lambda (x) (concat "\\underline{" x "}")))
- (vertical-align-sup . ,(lambda (x) (concat "\\textsuperscript{" x "}")))
- (display-left-margin . ,(lambda (x) (concat x " ")))
- (vertical-align-sub . ,(lambda (x) (concat "\\textsubscript{" x "}")))
- (font-style-oblique . ,(lambda (x) (concat "\\textsl{" x "}")))))
-
-;; Org-LaTeX
-
-(defconst citeproc-fmt--org-latex-alist
- `((unformatted . ,#'citeproc-fmt--latex-escape)
- (href . ,#'citeproc-fmt--latex-href)
- (font-style-italic . ,(lambda (x) (concat "\\textit{" x "}")))
- (font-weight-bold . ,(lambda (x) (concat "\\textbf{" x "}")))
- (cited-item-no . ,(lambda (x y) (concat "\\cslcitation{" y "}{" x "}")))
- (bib-item-no . ,(lambda (x y) (concat "\\cslbibitem{" y "}{" x "}")))
- (font-variant-small-caps . ,(lambda (x) (concat "\\textsc{" x "}")))
- (text-decoration-underline . ,(lambda (x) (concat "\\underline{" x "}")))
- (vertical-align-sup . ,(lambda (x) (concat "\\textsuperscript{" x "}")))
- (display-left-margin . ,(lambda (x) (concat "\\cslleftmargin{" x "}")))
- (display-right-inline . ,(lambda (x) (concat "\\cslrightinline{" x "}")))
- (display-block . ,(lambda (x) (concat "\\cslblock{" x "}")))
- (display-indent . ,(lambda (x) (concat "\\cslindent{" x "}")))
- (vertical-align-sub . ,(lambda (x) (concat "\\textsubscript{" x "}")))
- (font-style-oblique . ,(lambda (x) (concat "\\textsl{" x "}")))))
-
-(defun citeproc-fmt--org-latex-bib-formatter (items bib-format)
- "Return an Org LaTeX bibliography of ITEMS formatted in BIB-FORMAT."
- (let-alist bib-format
- (let ((hanging-indent (if .hanging-indent "1" "0"))
- (entry-spacing (if (and .entry-spacing (<= 1 .entry-spacing))
- (number-to-string (- .entry-spacing 1))
- "0")))
- (concat "\\begin{cslbibliography}{" hanging-indent "}{" entry-spacing "}\n"
- (mapconcat #'identity items "\n\n")
- "\n\n\\end{cslbibliography}\n"))))
-
-;; Org-ODT
-
-(defconst citeproc-fmt--org-odt-alist
- `((unformatted . citeproc-fmt--xml-escape)
- (href . ,(lambda (x y) (concat "<text:a xlink:type=\"simple\" xlink:href=\""
- y "\">" x "</text:a>")))
- (cited-item-no
- . ,(lambda (x y) (concat "<text:a xlink:type=\"simple\" xlink:href=\"#citeproc_bib_item_"
- y "\">" x "</text:a>")))
- (bib-item-no
- . ,(lambda (x y)
- (concat "<text:bookmark-start text:name=\"OrgXref.citeproc_bib_item_" y "\"/>"
- "<text:bookmark text:name=\"citeproc_bib_item_" y "\"/>"
- "<text:bookmark-end text:name=\"OrgXref.citeproc_bib_item_" y "\"/>" x)))
- (font-style-italic
- . ,(lambda (x) (concat "<text:span text:style-name=\"Emphasis\">" x "</text:span>")))
- (font-style-oblique
- . ,(lambda (x) (concat "<text:span text:style-name=\"Emphasis\">" x "</text:span>")))
- ;; NOTE: small caps support requires the availability of the OrgSmallcaps ODT style
- ;; this requires an addition to or replacement of the default OrgOdtStyles.xml
- (font-variant-small-caps
- . ,(lambda (x) (concat "<text:span text:style-name=\"OrgSmallCaps\">" x "</text:span>")))
- (font-weight-bold
- . ,(lambda (x) (concat "<text:span text:style-name=\"Bold\">" x "</text:span>")))
- (text-decoration-underline
- . ,(lambda (x) (concat "<text:span text:style-name=\"Underline\">" x "</text:span>")))
- (vertical-align-sub
- . ,(lambda (x) (concat "<text:span text:style-name=\"OrgSubscript\">" x "</text:span>")))
- (vertical-align-sup
- . ,(lambda (x)
- (concat "<text:span text:style-name=\"OrgSuperscript\">" x "</text:span>")))
- ;; TODO:
- ;; - display-left-margin
- ;; - display-right-inline
- ;; - display-block
- ;; - display-indent
- ))
-
-(defun citeproc-fmt--org-odt-bib-formatter (items _bib-format)
- "Return a html bibliography from already formatted ITEMS."
- (mapconcat (lambda (i)
- (concat "<text:p text:style-name=\"Text_20_body\">" i "</text:p>"))
- items
- "\n"))
-
-;; Define the formatters alist
-
-(defvar citeproc-fmt--formatters-alist
- `((org-odt . ,(citeproc-formatter-create
- :rt (citeproc-formatter-fun-create citeproc-fmt--org-odt-alist)
- :bib #'citeproc-fmt--org-odt-bib-formatter
- ))
- (html . ,(citeproc-formatter-create
- :rt (citeproc-formatter-fun-create citeproc-fmt--html-alist)
- :bib #'citeproc-fmt--html-bib-formatter))
- (csl-test . ,(citeproc-formatter-create
- :rt (citeproc-formatter-fun-create citeproc-fmt--csl-test-alist)
- :bib #'citeproc-fmt--html-bib-formatter
- :no-external-links t))
- (raw . ,(citeproc-formatter-create :rt #'identity :bib (lambda (x _) x)))
- (org . ,(citeproc-formatter-create :rt #'citeproc-fmt--org-format-rt))
- (org-latex . ,(citeproc-formatter-create
- :rt (citeproc-formatter-fun-create citeproc-fmt--org-latex-alist)
- :bib #'citeproc-fmt--org-latex-bib-formatter))
- (latex . ,(citeproc-formatter-create
- :rt (citeproc-formatter-fun-create citeproc-fmt--latex-alist)
- :bib (lambda (x _) (concat (mapconcat #'identity x "\n\n")
- "\\bigskip"))))
- (plain . ,(citeproc-formatter-create :rt #'citeproc-rt-to-plain
- :no-external-links t)))
- "Alist mapping supported output formats to formatter structs.")
-
-(defun citeproc-formatter-for-format (format)
- "Return the formatter struct belonging to FORMAT.
-FORMAT is a symbol"
- (if-let ((formatter (alist-get format citeproc-fmt--formatters-alist)))
- formatter
- (error "No formatter for citeproc format `%s'" format)))
-
-(provide 'citeproc-formatters)
-
-;;; citeproc-formatters.el ends here
+++ /dev/null
-;;; citeproc-generic-elements.el --- render generic CSL elements -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2017-2021 András Simonyi
-
-;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
-
-;; 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 3 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.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; Functions corresponding to the generic CSL rendering elements cs:layout,
-;; cs:group and cs:text. With the exception of `citeproc--layout' they return a
-;; (CONTENT . CONTENT-TYPE) pair, where CONTENT is the rendered rich-text output
-;; and CONTENT-TYPE is one of the symbols `text-only', `empty-vars' and
-;; `present-var.' In contrast, `citeproc--layout' returns only the rendered
-;; rich-text content.
-
-;;; Code:
-
-(require 'dash)
-(require 'let-alist)
-(require 's)
-
-(require 'citeproc-rt)
-(require 'citeproc-context)
-(require 'citeproc-macro)
-
-(defun citeproc--layout (attrs context &rest body)
- "Render the content of a layout element with ATTRS and BODY."
- (let* ((attrs (if (eq (citeproc-context-mode context) 'bib) attrs
- nil)) ; No attrs if mode is cite -- they are used for citations
- (spliced-body (citeproc-lib-splice-into body 'splice))
- (suffix (alist-get 'suffix attrs))
- (attrs-wo-suffix (--remove (eq (car it) 'suffix) attrs))
- (rendered-body (--map (car it) spliced-body)))
- ;; Handle second-field align
- (when (and (alist-get 'second-field-align (citeproc-context-opts context))
- (> (length rendered-body) 1))
- (setq rendered-body `((((display . "left-margin")) ,(car rendered-body))
- (((display . "right-inline")) ,@(cdr rendered-body)))))
- (let* ((affix-rendered (citeproc-rt-render-affixes
- (citeproc-rt-dedup (citeproc-rt-join-formatted attrs-wo-suffix rendered-body
- context))))
- (last-elt (and (listp affix-rendered) (-last-item affix-rendered)))
- (last-display (and (consp last-elt) (car last-elt)
- (--any-p (eq (car it) 'display) (car last-elt)))))
- (when suffix
- (if last-display
- ;; If the last element has a display attribute then we have to append the
- ;; suffix string to this last element
- (setf (nth (1- (length affix-rendered)) affix-rendered)
- (-snoc (-last-item affix-rendered) suffix))
- ;; Else we simply append it to the already rendered content
- (setq affix-rendered (if (listp affix-rendered)
- (-snoc affix-rendered suffix)
- (concat affix-rendered suffix)))))
- affix-rendered)))
-
-(defun citeproc--group (attrs context &rest body)
- "Render the content of a group element with ATTRS and BODY."
- (-let* ((spliced-body (citeproc-lib-splice-into body 'splice))
- (types (--map (cdr it) spliced-body))
- (type (cond ((--all? (eq it 'text-only) types)
- 'text-only)
- ((--any? (eq it 'present-var) types)
- 'present-var)
- (t 'empty-vars))))
- (cons (if (or (eq type 'text-only)
- (eq type 'present-var))
- (citeproc-rt-join-formatted attrs (--map (car it) spliced-body) context)
- nil)
- type)))
-
-(defconst citeproc-generic-elements--url-prefix-re "https?://\\S *\\'"
- "Regex matching an URL prefix at the end of a string.")
-
-(defun citeproc--text (attrs context &rest _body)
- "Render the content of a text element with ATTRS and BODY."
- (let-alist attrs
- (let ((content nil)
- (type 'text-only)
- (no-external-links (citeproc-context-no-external-links context)))
- (cond (.value (setq content .value))
- (.variable
- (let ((val (citeproc-var-value (intern .variable) context (citeproc-lib-intern
- .form))))
- (setq content val)
- (cond
- (val (let ((var (intern .variable)))
- (setq type 'present-var)
- (push `(rendered-var . ,var) attrs)
- (when (and (not no-external-links)
- (memq var citeproc--linked-vars))
- (let ((target
- (concat
- (alist-get var citeproc--link-prefix-alist
- "")
- content)))
- (-when-let (match-pos
- (and .prefix (s-matched-positions-all
- citeproc-generic-elements--url-prefix-re
- .prefix)))
- ;; If the prefix ends with an URL then it is moved
- ;; from the prefix to the rendered variable
- ;; content.
- (let ((start (caar match-pos)))
- (setq content (concat (substring .prefix start) content))
- (push (cons 'prefix (substring .prefix 0 start))
- attrs)))
- (push (cons 'href target) attrs)))))
- ;; Don't report empty var for year-suffix, see issue #70.
- ((not (string= .variable "year-suffix")) (setq type 'empty-vars)))))
- (.term (setq .form (if .form (intern .form) 'long)
- .plural (if (or (not .plural)
- (string= .plural "false"))
- 'single 'multiple)
- content (let ((cont (citeproc-term-inflected-text
- .term .form .plural context)))
- ;; Annotate the 'no date' term as if it'd be
- ;; the value of the 'issue' variable to
- ;; handle implicit year suffix addition and
- ;; suppression issues.
- (if (string= .term "no date")
- (progn
- (setq type 'present-var)
- `(((rendered-var . issued)) ,cont))
- cont))))
- (.macro (let ((macro-val (citeproc-macro-output .macro context)))
- (setq content (car macro-val))
- (setq type (cdr macro-val)))))
- ;; We stop if only the title had to be rendered.
- (let ((result (cons (citeproc-rt-format-single attrs content context) type)))
- (citeproc-context-maybe-stop-rendering
- 'title context result (or (and .variable (intern .variable)) t))))))
-
-(provide 'citeproc-generic-elements)
-
-;;; citeproc-generic-elements.el ends here
+++ /dev/null
-;;; citeproc-itemdata.el --- represent and access bibliography items -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2017 András Simonyi
-
-;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
-
-;; 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 3 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.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; Structure type and functions to handle data about bibliography items.
-
-;;; Code:
-
-(require 'citeproc-rt)
-(require 'citeproc-context)
-
-(cl-defstruct (citeproc-itemdata (:constructor citeproc-itemdata-create))
- "Struct for storing bibliography item data.
-VARVALS is an alist containg variable-name symbols as keys and
- their values for the item as values,
-RAWCITE is the cached cite of the item in internal rich-text
- format,
-RC-UPTODATE is t iff the RAWCITE field is up-to-date,
-RAWBIBITEM is the cached bibliograhy item in internal rich-text
- format.
-SORT-KEY is the bibliography sort-key of the item,
-OCCURRED-BEFORE is used during bibliography generation to
- indicate whether the item was referred to earlier. If the first
- occurrence is in a note then the actual value is the
- note-number,
-DISAMB-POS contains the position on which cite disambiguation is
- based. Possible values are 'first, 'ibid and 'subsequent,
-SUBBIB-NOS is a list of numeric indexes of sub-bibliographies
- in which the item occurs,
-UNCITED is t iff the item has no associated citation."
- varvals rawcite rawbibitem rc-uptodate sort-key occurred-before
- disamb-pos subbib-nos uncited)
-
-(defun citeproc-itd-getvar (itd var)
- "Return itemdata ITD's value for VAR ."
- (alist-get var (citeproc-itemdata-varvals itd)))
-
-(defun citeproc-itd-setvar (itd var val)
- "Set itemdata ITD's value for VAR to VAL."
- (setf (alist-get var (citeproc-itemdata-varvals itd) nil t) val
- (citeproc-itemdata-rc-uptodate itd) nil))
-
-(defun citeproc-itd-rt-cite (itd style)
- "Return the rich-text cite of itemdata ITD using STYLE."
- (if (citeproc-itemdata-rc-uptodate itd)
- (citeproc-itemdata-rawcite itd)
- (let ((rc (citeproc-render-varlist-in-rt
- (cons (cons 'position (citeproc-itemdata-disamb-pos itd))
- (citeproc-itemdata-varvals itd))
- style
- 'cite 'display 'no-links t)))
- (setf (citeproc-itemdata-rawcite itd) rc
- (citeproc-itemdata-rc-uptodate itd) t)
- rc)))
-
-(defun citeproc-itd-plain-cite (itd style)
- "Return the plain text cite of itemdata ITD using STYLE."
- (citeproc-rt-to-plain (citeproc-itd-rt-cite itd style)))
-
-(defun citeproc-itd-namevars (itd style)
- "Rendered namevars in the cite of itemdata ITD using STYLE."
- (citeproc-rt-rendered-name-vars (citeproc-itd-rt-cite itd style)))
-
-(defun citeproc-itd-nameids (itd style)
- "Rendered name ids in the cite of itemdata ITD using STYLE."
- (citeproc-rt-rendered-name-ids (citeproc-itd-rt-cite itd style)))
-
-(defun citeproc-itd-update-disamb-pos (itd pos)
- "Update the highest position of ITD with position POS."
- (let ((old (citeproc-itemdata-disamb-pos itd)))
- (unless (eq old 'subsequent)
- (let ((new (pcase pos
- ('first 'first)
- ((or 'ibid 'ibid-with-locator) 'ibid)
- (_ 'subsequent))))
- (setf (citeproc-itemdata-disamb-pos itd)
- (cond ((memq old '(nil first)) new)
- ((eq new 'subsequent) 'subsequent)
- (t 'ibid)))))))
-
-(provide 'citeproc-itemdata)
-
-;;; citeproc-itemdata.el ends here
+++ /dev/null
-;; citeproc-itemgetters.el --- functions for constructing itemgetters -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2017-2021 András Simonyi
-
-;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
-
-;; 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 3 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.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; Functions for constructing various types of bibliographic itemgetter
-;; functions. The returned itemgetter functions can, in turn, be used to create
-;; `citeproc-style' and `citeproc-proc' structures.
-
-;;; Code:
-
-(require 'dash)
-(require 'org)
-;; Handle the fact that org-bibtex has been renamed to ol-bibtex -- for the time
-;; being we support both feature names.
-(or (require 'ol-bibtex nil t)
- (require 'org-bibtex))
-(require 'json)
-(require 'bibtex)
-(require 'parsebib)
-
-(require 'citeproc-bibtex)
-(require 'citeproc-biblatex)
-
-(defun citeproc-itemgetters--parsebib-buffer (entries strings)
- "Parse a BibTeX/biblatex buffer with Parsebib."
- ;; Note: this is needed to support different Parsebib versions in use.
- (cond ((fboundp 'parsebib-parse-buffer)
- (parsebib-parse-buffer entries strings t t))
- ((fboundp 'parsebib-parse-bib-buffer)
- (parsebib-parse-bib-buffer :entries entries :strings strings
- :expand-strings t :inheritance t))
- (t (error "No Parsebib buffer parsing function is available"))))
-
-(defun citeproc-hash-itemgetter-from-csl-json (file)
- "Return a hash-based getter for csl json bibliography FILE."
- (let* ((json-array-type 'list)
- (json-key-type 'symbol)
- (item-list (json-read-file file))
- (hash (make-hash-table :test 'equal)))
- (--each item-list
- (puthash (alist-get 'id it) it hash))
- (lambda (itemids) (--map (cons it (gethash it hash))
- itemids))))
-
-(defun citeproc-itemgetter-from-csl-json (file)
- "Return an item-getter for csl json bibliography FILE."
- (lambda (itemids)
- (let* ((json-array-type 'list)
- (json-key-type 'symbol)
- (item-list (json-read-file file))
- result)
- (dolist (item item-list result)
- (let ((id (alist-get 'id item)))
- (when (member id itemids)
- (push (cons id item) result)))))))
-
-(defun citeproc-itemgetter-from-bibtex (file-or-files)
- "Return a getter for BibTeX bibliography FILE-OR-FILES."
- (if (listp file-or-files)
- (lambda (itemids)
- (let (result
- (remaining-ids (cl-copy-list itemids))
- (remaining-files file-or-files))
- (while (and remaining-ids remaining-files)
- (let ((file (pop remaining-files)))
- (with-temp-buffer
- (insert-file-contents file)
- (goto-char (point-min))
- (bibtex-set-dialect 'BibTeX t)
- (bibtex-map-entries
- (lambda (key _beg _end)
- (when (member key itemids)
- (push (cons key (citeproc-bt-entry-to-csl (bibtex-parse-entry)))
- result)
- (setq remaining-ids (delete key remaining-ids))))))))
- result))
- (lambda (itemids)
- (let (result)
- (with-temp-buffer
- (insert-file-contents file-or-files)
- (goto-char (point-min))
- (bibtex-set-dialect 'BibTeX t)
- (bibtex-map-entries
- (lambda (key _beg _end)
- (when (member key itemids)
- (push (cons key (citeproc-bt-entry-to-csl (bibtex-parse-entry)))
- result)))))
- result))))
-
-(defun citeproc-itemgetter-from-org-bibtex (file-or-files)
- "Return a getter for org-bibtex bibliography FILE-OR-FILES."
- (let ((files (if (listp file-or-files)
- file-or-files
- (list file-or-files))))
- (lambda (itemids)
- (let (result)
- (org-map-entries
- (lambda ()
- (-when-let (key-w-entry (citeproc-bt-from-org-headline itemids))
- (push (cons (car key-w-entry)
- (citeproc-bt-entry-to-csl (cdr key-w-entry)))
- result)))
- t files)
- result))))
-
-(defun citeproc-hash-itemgetter-from-any (file-or-files &optional no-sentcase-wo-langid)
- "Return a getter for FILE-OR-FILES in any supported format.
-The format is determined on the basis of file extensions.
-Supported formats:
-- CSL-JSON (.json extension) the recommended native format;
-- BibTeX/biblatex (.bib or .bibtex extension),
-- org-bibtex (.org extension).
-If NO-SENTCASE-WO-LANGID is non-nil then title fields in items
-without a `langid' field are not converted to sentence-case."
- (let ((files (if (listp file-or-files)
- file-or-files
- (list file-or-files)))
- (cache (make-hash-table :test #'equal))
- (bt-entries (make-hash-table :test #'equal))
- (bt-strings (make-hash-table :test #'equal)))
- (dolist (file files)
- (pcase (file-name-extension file)
- ("json"
- (let ((json-array-type 'list)
- (json-key-type 'symbol))
- (dolist (item (json-read-file file))
- (puthash (cdr (assq 'id item)) item cache))))
- ((and (or "bib" "bibtex") ext)
- (with-temp-buffer
- (insert-file-contents file)
- (bibtex-set-dialect (if (string= ext "bib") 'biblatex 'BibTeX) t)
- (citeproc-itemgetters--parsebib-buffer bt-entries bt-strings)))
- ("org"
- (org-map-entries
- (lambda ()
- (-when-let (key-w-entry (citeproc-bt-from-org-headline))
- (condition-case err
- (puthash (car key-w-entry) (citeproc-blt-entry-to-csl
- (cdr key-w-entry))
- cache)
- (error
- (user-error
- "Couldn't parse the bib(la)tex entry with key '%s', the error was: %s"
- (car key-w-entry) err)))))
- t (list file)))
- (ext
- (user-error "Unknown bibliography extension: %S" ext))))
- (maphash
- (lambda (key entry)
- (condition-case err
- (puthash key (citeproc-blt-entry-to-csl entry nil no-sentcase-wo-langid)
- cache)
- (error
- (user-error
- "Couldn't parse the bib(la)tex entry with key '%s', the error was: %s"
- key err))))
- bt-entries)
- (lambda (x)
- (pcase x
- ('itemids
- (hash-table-keys cache))
- ((pred listp) (mapcar (lambda (id)
- (cons id (gethash id cache)))
- x))
- (_ (error "Unsupported citeproc itemgetter retrieval method"))))))
-
-(provide 'citeproc-itemgetters)
-
-;;; citeproc-itemgetters.el ends here
+++ /dev/null
-;;; citeproc-lib.el --- misc functions and variables for citeproc-el -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2017-2021 András Simonyi
-
-;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
-
-;; 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 3 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.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; General utility functions used in citeproc-el.
-
-;;; Code:
-
-(require 'dash)
-(require 's)
-
-(defconst citeproc--number-vars
- '(chapter-number citation-number collection-number edition first-reference-note-number
- issue number number-of-pages number-of-volumes page page-first
- part-number printing-number section supplement-number version volume)
- "CSL number variables."
- ;; Note: `locator', which is also on the official list, is omitted because
- ;; it's treated specially in the code.
- )
-
-(defconst citeproc--date-vars
- '(accessed available-date event-date issued original-date submitted locator-date)
- "CSL date variables.")
-
-(defconst citeproc--name-vars
- '(author chair collection-editor compiler composer container-author contributor
- curator director editor editorial-director editor-translator executive-producer
- guest host illustrator interviewer narrator organizer original-author
- performer producer recipient reviewed-author script-writer series-creator
- translator)
- "CSL name variables.")
-
-(defconst citeproc--linked-vars
- '(DOI PMCID PMID URL)
- "Variables whose rendered content should be linked.
-The ordering is according to priority ")
-
-(defconst citeproc--link-prefix-alist
- '((DOI . "https://doi.org/")
- (PMID . "https://www.ncbi.nlm.nih.gov/pubmed/")
- (PMCID . "https://www.ncbi.nlm.nih.gov/pmc/articles/"))
- "Alist mapping variable names to uri prefixes.")
-
-(defun citeproc-lib-parse-xml-file (file)
- "Return the parsed xml representation of FILE."
- (with-temp-buffer
- (insert-file-contents file)
- (libxml-parse-xml-region (point-min) (point-max))))
-
-(defun citeproc-lib-remove-xml-comments (tree)
- "Remove comments from xml TREE."
- (let ((head (car tree))
- (attrs (cadr tree))
- (body (cddr tree))
- result)
- (while body
- (pcase (car body)
- ((pred atom) (push (pop body) result))
- (`(comment . ,_) (pop body))
- (_ (push (citeproc-lib-remove-xml-comments (pop body)) result))))
- (let ((full-result (cons head (cons attrs (nreverse result)))))
- ;; Handle the problem of the top element added by the libxml parser when
- ;; there is a comment after the xml declaration.
- (if (eq (car full-result) 'top)
- (caddr full-result)
- full-result))))
-
-(defun citeproc-lib-parse-html-frag (s)
- "Return the parsed representation of html in string S."
- (with-temp-buffer
- (insert s)
- (libxml-parse-html-region (point-min) (point-max))))
-
-(defun citeproc-lib-intern (s)
- "Intern S if it is a string, return nil if it is nil."
- (cond ((not s) nil)
- ((stringp s) (intern s))
- (t (error "Function citeproc-lib-intern was called with an argument that is neither string nor nil"))))
-
-(defun citeproc-lib-named-parts-to-alist (e)
- "Collect the attrs of parsed xml element E's enclosed elements.
-The attributes are collected into an alist consisting
-of (PARTNAME . ATTRS) pairs, where PARTNAME is the value of the
-enclosed element's `name' attr"
- (--map (cons (intern (alist-get 'name it))
- (assq-delete-all 'name it))
- (mapcar #'cadr (-remove #'stringp (cddr e)))))
-
-(defun citeproc-lib-lex-compare (l1 l2 cmp-fun sort-orders)
- "Whether list L1 lexicographically precedes list L2.
-CMP-FUN is a three-valued (1, 0, -1) comparator function,
-SORT-ORDERS is a list of sort orders (see the bib- and
-cite-sort-orders slots of `citeproc-style' for details). Return t
-iff L1 is strictly ordered before L2, nil otherwise."
- (unless sort-orders
- (setq sort-orders (make-list (length l1) t)))
- (let (result)
- (while (and l1 (not result))
- (let ((comp
- (funcall cmp-fun (pop l1) (pop l2) (not (pop sort-orders)))))
- (unless (= comp 0)
- (setq result comp))))
- (equal result 1)))
-
-(defun citeproc-lib-splice-into (list tag)
- "Splice elements with car TAG into LIST."
- (let (result)
- (dolist (elt list)
- (if (and (consp elt) (eq tag (car elt)))
- (dolist (e (cdr elt))
- (push e result))
- (push elt result)))
- (nreverse result)))
-
-(defun citeproc-lib-add-splice-tag (list tag)
- "Add TAG as car if LIST is not a singleton.
-Return the first element if LIST is singleton."
- (if (cdr list) (cons tag list) (car list)))
-
-(defun citeproc-lib-numeric-p (val)
- "Return whether VAL is numeric content.
-VAL has numeric content if it is a number or a string containing
-numeric content."
- (or (numberp val)
- (and (stringp val)
- (s-matches-p "\\`[[:alpha:]]?[[:digit:]]+[[:alpha:]]*\\(\\( *\\([,&-]\\|--\\) *\\)?[[:alpha:]]?[[:digit:]]+[[:alpha:]]*\\)?\\'"
- val))))
-
-(provide 'citeproc-lib)
-
-;;; citeproc-lib.el ends here
+++ /dev/null
-;; citeproc-locale.el --- CSL locale related functions -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2017-2022 András Simonyi
-
-;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
-
-;; 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 3 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.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; In addition to some locale handling helpers, this file provides the function
-;; `citeproc-locale-getter-from-dir', which constructs locale getter functions
-;; that retrieve locales from a given directory.
-
-;;; Code:
-
-(require 'dash)
-(require 'f)
-(require 's)
-
-(require 'citeproc-lib)
-(require 'citeproc-term)
-
-(defconst citeproc-locale--default-variants-alist
- '(("af" . "ZA") ("ca" . "AD") ("cs" . "CZ") ("cy" . "GB")
- ("da" . "DK") ("en" . "US") ("el" . "GR") ("et" . "EE")
- ("fa" . "IR") ("he" . "IR") ("ja" . "JP") ("km" . "KH")
- ("ko" . "KR") ("nb" . "NO") ("nn" . "NO") ("sl" . "SI")
- ("sr" . "RS") ("sv" . "SE") ("uk" . "UA") ("vi" . "VN")
- ("zh" . "CN"))
- "Alist mapping locales to their default variants.
-Only those locales are given for which the default variant is not
-simply the result of upcasing.")
-
-(defconst citeproc-locale--simple-locales
- '("la" "eu" "ar")
- "List of simple locale names (without dash).")
-
-(defun citeproc-locale--extend (loc)
- "Extend simple locale LOC to default variant."
- (let ((variant (assoc-default loc citeproc-locale--default-variants-alist)))
- (concat loc "-" (or variant (s-upcase loc)))))
-
-(defun citeproc-locale--compatible-p (l1 l2)
- "Whether locales L1 and L2 are compatible."
- (or (not (and l1 l2))
- (s-prefix-p l1 l2)
- (s-prefix-p l2 l1)))
-
-(defun citeproc-locale-getter-from-dir (dir)
- "Return a locale getter getting parsed locales from a local DIR.
-If the requested locale couldn't be read then return the parsed
-en-US locale, which must exist, and warn the user."
- (let ((default-loc-file (f-join dir "locales-en-US.xml")))
- (lambda (loc)
- (let* ((ext-loc (if (or (member loc citeproc-locale--simple-locales)
- (s-contains-p "-" loc))
- loc
- (citeproc-locale--extend loc)))
- (loc-file (concat dir "/locales-" ext-loc ".xml"))
- (loc-available (f-readable-p loc-file)))
- (citeproc-lib-remove-xml-comments
- (citeproc-lib-parse-xml-file
- (if loc-available loc-file
- (if (not (f-readable-p default-loc-file))
- (error
- "The default CSL locale file %s doesn't exist or is unreadable"
- default-loc-file)
- (display-warning
- 'citeproc
- (format
- "Could not read CSL locale file %s, using the fallback en-US locale"
- loc-file))
- default-loc-file))))))))
-
-(defun citeproc-locale-termlist-from-xml-frag (frag)
- "Transform xml FRAG representing citeproc--terms into a citeproc-term list."
- (--mapcat (if (eq 'term (car it))
- (citeproc-term--from-xml-frag (cdr it))
- nil)
- frag))
-
-(provide 'citeproc-locale)
-
-;;; citeproc-locale.el ends here
+++ /dev/null
-;; citeproc-macro.el --- functions to render CSL macros -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2017 András Simonyi
-
-;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
-
-;; 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 3 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.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; Functions to render the output of CSL macros.
-
-;;; Code:
-
-(require 'citeproc-lib)
-(require 'citeproc-rt)
-(require 'citeproc-context)
-
-;;; For macro evaluation
-(defun citeproc--macro (attrs context &rest body)
- "Render the content of a macro element with ATTRS and BODY."
- (let* ((spliced-body (citeproc-lib-splice-into body 'splice))
- (val (citeproc-rt-typed-join attrs spliced-body context)))
- (if (eq 'empty-vars (cdr val))
- (cons nil 'text-only)
- val)))
-
-(defun citeproc-macro-output (macro context)
- "Return the output of MACRO.
-MACRO is the macro's name as a string and the returned value is a
-(RICH-TEXT-CONTENT . CONTENT-TYPE) cons cell."
- (let ((macro-fun (assoc-default macro (citeproc-context-macros context))))
- (if macro-fun
- (funcall macro-fun context)
- (error "There is no macro called `%s' in style" macro))))
-
-(defun citeproc-macro-output-as-text (macro context)
- "Return the output of MACRO as plain text.
-MACRO is the macro's name as a string."
- (citeproc-rt-to-plain (citeproc-rt-render-affixes
- (car (citeproc-macro-output macro context)))))
-
-(provide 'citeproc-macro)
-
-;;; citeproc-macro.el ends here
+++ /dev/null
-;;; citeproc-name.el --- CSL name and label rendering -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2017 András Simonyi
-
-;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
-
-;; 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 3 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.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; Functions to render CSL name and label elements.
-
-;;; Code:
-
-(require 'subr-x)
-(require 'let-alist)
-(require 'dash)
-(require 's)
-
-(require 'citeproc-lib)
-(require 'citeproc-s)
-(require 'citeproc-rt)
-(require 'citeproc-context)
-(require 'citeproc-term)
-
-(defvar citeproc-name-postprocess-functions nil
- "A list of functions to postprocess rendered names.
-Each function takes three arguments:
-- the rich-text rendering of a name to be post-processed,
-- the rendered name as an alist with CSL name-part
- keys (`family', `given' etc.), and
-- the rendering context, as a `citeproc-context' structure.
-The output of each function should be the post-processed
-rich-text, and the functions are applied in the order they appear
-in the list.")
-
-;; OPTIMIZE: Name count could be sped up by only counting the names to be
-;; rendered without actually rendering them
-(defun citeproc-name-render-vars
- (varstring attrs name-attrs name-part-attrs et-al-attrs with-label
- label-before-names label-attrs context)
- "Render namevars contained in VARSTRING according to the given attrs.
-VARSTRING is a string containing variable names separated by
-spaces. Labels are also rendered (with formatting according to
-LABEL-ATTRS) if WITH-LABEL is t."
- (let* ((vars (-map 'intern (s-split " " varstring)))
- (present-vars (--filter (citeproc-var-value it context) vars))
- ed-trans)
- (when (and (memq 'editor present-vars)
- (memq 'translator present-vars)
- (= 2 (length present-vars))
- (equal (--map (alist-get 'name-id it)
- (citeproc-var-value 'editor context))
- (--map (alist-get 'name-id it)
- (citeproc-var-value 'translator context))))
- (setq present-vars '(editor)
- ed-trans t))
- (unless (alist-get 'delimiter attrs)
- (-when-let (names-delim (alist-get 'names-delimiter (citeproc-context-opts context)))
- (push (cons 'delimiter names-delim) attrs)))
- (if present-vars
- (cons (citeproc-rt-join-formatted
- attrs
- (--map (citeproc-name--render-var it name-attrs name-part-attrs
- et-al-attrs with-label
- label-before-names
- label-attrs
- context
- ed-trans)
- present-vars)
- context)
- 'present-var)
- (cons nil 'empty-vars))))
-
-(defun citeproc-name--render-var (var attrs name-part-attrs et-al-attrs with-label
- label-before-names
- label-attrs context &optional ed-trans)
- "Render the value of csl name variable VAR according to given attrs.
-VAR is a symbol.
-
-Note: The label (if there is one) is prepended to the name(s) if
-the form is verb and also when the label element was before the
-names element in the style. The latter is not allowed in the
-standard, so can be considered an extension. It's supported
-because some styles rely on it, notably that of the journal
-Nature."
- ;; Push the current add-names offset for VAR to the ATTRS
- (-when-let (add-names-alist (citeproc-var-value 'add-names context))
- (-when-let (add-names-val (alist-get var add-names-alist))
- (push `(add-names . ,add-names-val) attrs)))
- (let* ((var-value (citeproc-var-value var context))
- (rendered-names (citeproc-name--render-names
- var-value attrs et-al-attrs name-part-attrs
- context)))
- (when (atom rendered-names) (setq rendered-names (list nil rendered-names)))
- (push (list 'rendered-names) (car rendered-names))
- (push `(variable . ,(if ed-trans "editortranslator" (symbol-name var)))
- label-attrs)
- (let ((plural-val (alist-get 'plural label-attrs)))
- (when (or (not plural-val) (string= plural-val "contextual"))
- (push `(plural . ,(if (> (length var-value) 1) "always" "never"))
- label-attrs)))
- (if with-label
- (let ((rendered-label (car (citeproc--label label-attrs context))))
- (citeproc-rt-join-formatted `((rendered-var . ,var))
- (if label-before-names
- (list rendered-label rendered-names)
- (list rendered-names rendered-label))
- context))
- (push (cons 'rendered-var var) (car rendered-names))
- rendered-names)))
-
-(defun citeproc-name--render-names (names attrs et-al-attrs name-part-attrs context)
- "Render NAMES according to the given attrs."
- (let* ((all-attrs (-concat attrs (citeproc-context-opts context)))
- (rmode (citeproc-context-render-mode context))
- (sort-o (if (eq rmode 'sort) "all" ;; special setting for sort mode
- (alist-get 'name-as-sort-order all-attrs)))
- (names-count (length names))
- (formatted-first (citeproc-name--render (car names) attrs name-part-attrs
- sort-o context)))
- (if (= 1 names-count) formatted-first
- (let-alist all-attrs
- (let ((delimiter (or .delimiter .name-delimiter ", "))
- (add-names (or .add-names 0))
- (position (citeproc-var-value 'position context)))
- (unless (or (null position) (eq position 'first))
- (setq .et-al-min (or .et-al-subsequent-min .et-al-min)
- .et-al-use-first (or .et-al-subsequent-use-first .et-al-use-first)))
- (setq .et-al-min (or .names-min .et-al-min)
- .et-al-use-first (or .names-use-first .et-al-use-first)
- .et-al-use-last (or (string= .names-use-last "true")
- (string= .et-al-use-last "true")))
- (let* ((et-al-min-val
- ;; If et-al should be ignored then we set this to an unreachable number.
- (if (alist-get 'ignore-et-al (citeproc-context-vars context))
- 100
- (citeproc-s-nil-or-s-to-num .et-al-min)))
- (et-al-use-first-val (+ add-names
- (citeproc-s-nil-or-s-to-num .et-al-use-first)))
- (et-al (and .et-al-min .et-al-use-first
- (>= names-count et-al-min-val)
- (< et-al-use-first-val names-count)))
- (middle-end-pos (if et-al et-al-use-first-val (- names-count 1)))
- (sort-o-latters (string= sort-o "all"))
- (formatted-middle
- (if (< middle-end-pos 2)
- nil
- (citeproc-rt-join-formatted
- `((delimiter . ,delimiter) (prefix . ,delimiter))
- (--map (citeproc-name--render it attrs name-part-attrs
- sort-o-latters context)
- (-slice names 1 middle-end-pos))
- context)))
- (last-after-inverted (or sort-o-latters
- (and (string= sort-o "first")
- (null formatted-middle))))
- (last-delim (citeproc-lib-intern (if et-al .delimiter-precedes-et-al
- .delimiter-precedes-last)))
- (last-pref (if (or (and (or (not last-delim) (eq last-delim 'contextual))
- (> middle-end-pos 1))
- (eq last-delim 'always)
- (and (eq last-delim 'after-inverted-name)
- last-after-inverted))
- delimiter
- " "))
- (formatted-last
- (cond (et-al (if .et-al-use-last
- (citeproc-rt-join-formatted
- nil
- (list
- delimiter "… "
- (citeproc-name--render (-last-item names)
- attrs name-part-attrs
- sort-o-latters context))
- context)
- (citeproc-name--render-et-al (cons `(prefix . ,last-pref)
- et-al-attrs)
- context)))
- (.and
- (let ((and-str (if (string= .and "text")
- (citeproc-term-get-text "and" context)
- "&")))
- (citeproc-rt-join-formatted
- `((prefix . ,last-pref))
- (list and-str " "
- (citeproc-name--render
- (-last-item names) attrs
- name-part-attrs sort-o-latters context))
- context)))
- (t
- (citeproc-rt-join-formatted
- nil
- (list delimiter
- (citeproc-name--render (-last-item names)
- attrs name-part-attrs
- sort-o-latters context))
- context)))))
- (citeproc-rt-join-formatted
- (--remove (eq 'delimiter (car it)) attrs)
- (list formatted-first formatted-middle formatted-last)
- context)))))))
-
-(defun citeproc-name--render (name attrs name-part-attrs sort-o context)
- "Render NAME according to the given attributes."
- (let* ((format-attrs
- (--filter (memq (car it) (-concat '(prefix suffix) citeproc-rt-format-attrs))
- attrs))
- (result (citeproc-rt-format-single
- (cons `(name-id . ,(alist-get 'name-id name)) format-attrs)
- (citeproc-name--render-formatted
- (citeproc-name--format-nameparts name name-part-attrs context)
- attrs sort-o context)
- context)))
- (dolist (fn citeproc-name-postprocess-functions)
- (setq result (funcall fn result name context)))
- result))
-
-(defun citeproc-name--parts-w-sep (c1 c2 sep context)
- "Join name-parts in lists C1 C2 with spaces and then with SEP."
- (let ((joined-c1 (citeproc-rt-join-formatted '((delimiter . " ")) c1 context)))
- (if (-none-p 'cadr c2)
- joined-c1
- (citeproc-rt-join-formatted
- `((delimiter . ,sep))
- (list joined-c1
- (citeproc-rt-join-formatted '((delimiter . " ")) c2 context))
- context))))
-
-(defun citeproc-name--render-formatted (name-alist attrs sort-o context)
- "Render formatted name described by NAME-ALIST according to ATTRS.
-NAME-ALIST is an alist with symbol keys corresponding to
-name-parts like `family' etc. and values are simple rich-text
-contents of the form (ATTRS CONTENT) where content must be a
-single string. SORT-O is a boolean determining whether to use
-sort order."
- (-let* ((global-opts (citeproc-context-opts context))
- ((&alist 'family f
- 'given g-uninited
- 'suffix s
- 'dropping-particle d
- 'non-dropping-particle n
- 'name-id nid)
- name-alist)
- ((&alist 'sort-separator sort-sep
- 'initialize init
- 'initialize-with init-with
- 'form form
- 'name-form name-form)
- (-concat attrs global-opts))
- (sort-sep (or sort-sep ", "))
- (init (not (string= init "false")))
- (d-n-d (intern (alist-get 'demote-non-dropping-particle global-opts)))
- (id (cadr nid))
- (show-given (citeproc-name-show-givenname-level id context))
- (form (if show-given 'long
- (intern (or form name-form "long"))))
- (rmode (citeproc-context-render-mode context)))
- (if (citeproc-name--lat-cyr-greek-p name-alist)
- (let ((g
- (cond ((or (null g-uninited)
- (and show-given (= show-given 2)))
- g-uninited)
- ((and init-with init)
- (list (citeproc-rt-attrs g-uninited)
- (citeproc-name--initialize
- (citeproc-rt-first-content g-uninited)
- init-with
- (string= "false"
- (alist-get 'initialize-with-hyphen
- global-opts)))))
- (init-with
- (list (citeproc-rt-attrs g-uninited)
- (citeproc-name--initials-add-suffix
- init-with
- (citeproc-rt-first-content g-uninited))))
- (t g-uninited))))
- (if (eq form 'long)
- (if sort-o
- (if (or (eq d-n-d 'never)
- (and (eq d-n-d 'sort-only) (eq rmode 'display)))
- (citeproc-name--parts-w-sep
- (citeproc-name--conc-nps n f) (list g d s) sort-sep
- context)
- (citeproc-name--parts-w-sep (list f) (list g d n s) sort-sep context))
- (citeproc-rt-join-formatted
- '((delimiter . " ")) `(,g ,@(citeproc-name--conc-nps
- d n f) ,s)
- context))
- (citeproc-rt-join-formatted
- '((delimiter . " ")) (citeproc-name--conc-nps n f) context)))
- (if (eq form 'long)
- (citeproc-rt-join-formatted '((delimiter . " ")) (list f g-uninited) context)
- f))))
-
-(defun citeproc-name--conc-nps (&rest nps)
- "Concatenate particles in name-parts NPS if they end with apostrophe."
- (let ((nonnils (delq nil nps)))
- (if (cdr nonnils)
- (let* ((len (length nonnils))
- (particle (nth (- len 2) nonnils))
- (particle-str (if (listp particle) (cadr particle) particle)))
- (if (string= "ʼ" (substring particle-str -1))
- (let* ((family (car (last nonnils)))
- (result (list (list nil particle family))))
- (when (> 2 len) (push (car nonnils) result))
- result)
- nonnils))
- nonnils)))
-
-(defun citeproc-name--lat-cyr-greek-p (name-alist)
- "Return t if NAME-ALIST is cyrillic/latin/greek and nil otherwise.
-NAME-ALIST is like in `citeproc-name--render-formatted'"
- (--all-p (or (not (stringp it)) (string-match "^\\(\\cl\\|\\cy\\|\\cg\\|ʼ\\)*$"
- it))
- (-map (lambda (x)
- (if (listp (cdr x)) (cl-caddr x)
- (cdr x)))
- name-alist)))
-
-(defun citeproc-name--initialize (names suffix &optional remove-hyphens)
- "Initialize NAMES and add SUFFIX.
-NAMES is a string containing one or more space-separated names,
-while SUFFIX is either nil or a string (e.g. \".\"). If the
-optional REMOVE-HYPHENS is non-nil then don't keep hyphens
-between initalized given names, e.g., initialize Jean-Paul to
-J.P. instead of the default J.-P."
- (let ((trimmed-suffix (s-trim suffix)))
- (concat (s-join
- suffix
- (--map
- (if (s-match "-" it)
- (citeproc-name--initialize-hyphenated it suffix remove-hyphens)
- (s-left 1 it))
- (s-split " +" names)))
- trimmed-suffix)))
-
-(defun citeproc-name--initialize-hyphenated (name suffix &optional remove-hyphens)
- "Initialize space-less but hyphenated NAME with SUFFIX.
-If the optional REMOVE-HYPHENS is non-nil then don't keep hyphens
-between the initalized given names, e.g., initialize Jean-Paul to
-J.P. instead of the default J.-P."
- (let ((inner-suffix (s-trim suffix)))
- (s-join (if remove-hyphens inner-suffix
- (concat inner-suffix "-"))
- (--map (s-left 1 it)
- (s-split "-" name)))))
-
-(defun citeproc-name--initials-add-suffix (suffix names)
- "Add SUFFIX to initials in NAMES.
-NAMES is a string containing one or more space-separated names,
-while SUFFIX is a string (e.g. \".\")."
- (let ((suffix (s-trim suffix)))
- (mapconcat (lambda (x)
- (if (and (cdr x) (s-match "^[[:alpha:]]$" (car x)))
- (concat (car x) suffix)
- (car x)))
- (citeproc-s-slice-by-matches names "[ \\-]" 0 t)
- "")))
-
-(defun citeproc-name--format-nameparts (name-alist name-part-attrs context)
- "Format nameparts in NAME-ALIST according to NAME-PART-ATTRS.
-Return a new name alist containg the same keys with formatted
-contents."
- (-let (((&alist 'given given-attrs
- 'family family-attrs)
- name-part-attrs))
- (--map (-let (((n-part . content) it))
- (cons n-part
- (cond ((and given-attrs
- (memq n-part '(given dropping-particle)))
- (citeproc-rt-format-single given-attrs content context))
- ((and family-attrs
- (memq n-part '(family non-dropping-particle)))
- (citeproc-rt-format-single family-attrs content context))
- (t (list nil content)))))
- name-alist)))
-
-(defun citeproc-name--render-et-al (attrs context)
- "Render the `et al' part of a name acc. to ATTRS."
- (let ((rmode (citeproc-context-render-mode context)))
- (if (eq rmode 'sort) ""
- (let ((term (or (alist-get 'term attrs)
- "et-al")))
- (citeproc-rt-format-single attrs
- (citeproc-term-get-text term context)
- context)))))
-
-(defun citeproc-name-show-givenname-level (id context)
- "Return the disambiguation level of name with ID."
- (alist-get id (alist-get 'show-given-names (citeproc-context-vars context))))
-
-(defun citeproc--var-plural-p (var context)
- "Return whether the content of variable VAR is plural.
-VAR is a symbol."
- (let ((content (citeproc-rt-to-plain (citeproc-var-value var context))))
- (if (or (string= var "number-of-pages")
- (string= var "number-of-volumes"))
- (> (string-to-number content) 1)
- (string-match-p
- (concat "[[:digit:]] *\\([-,;–&—―]+\\|[,;]? *"
- (citeproc-term-get-text "and" context)
- "\\) *[a-zA-Z]?[[:digit:]]")
- content))))
-
-(defun citeproc--label (attrs context &rest _body)
- "Render a CSL label element with the given ATTRS in CONTEXT."
- (-let* (((&alist 'variable variable
- 'form form
- 'plural plural)
- attrs)
- (label (intern variable))
- (number nil))
- (if (or (eq label 'editortranslator)
- (and label (citeproc-var-value label context)))
- (progn
- (if form (setq form (intern form))
- (setq form 'long))
- (when (string= variable "locator")
- (setq variable (citeproc-locator-label context)))
- (cond ((string= plural "never") (setq number 'single))
- ((string= plural "always") (setq number 'multiple))
- (t (setq number
- (if (citeproc--var-plural-p label context)
- 'multiple
- 'single))))
- ;; Add rendered locator label info in cite mode.
- (when (and (eq label 'locator)
- (eq (citeproc-context-mode context) 'cite))
- (push '(rendered-locator-label . t) attrs))
- (cons (citeproc-rt-format-single attrs (citeproc-term-inflected-text
- variable form number context)
- context)
- 'text-only))
- (cons nil 'text-only))))
-
-(provide 'citeproc-name)
-
-;;; citeproc-name.el ends here
+++ /dev/null
-;;; citeproc-number.el --- render CSL number elements -*- lexical-binding: t; -*-
-
-;; Copyright "(C) 2017 András Simonyi
-
-;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
-
-;; 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 3 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.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; Functions to render CSL number elements.
-
-;;; Code:
-
-(require 'subr-x)
-(require 'rst)
-(require 's)
-
-(require 'citeproc-context)
-(require 'citeproc-lib)
-(require 'citeproc-s)
-(require 'citeproc-rt)
-
-(defun citeproc-number-extract (val)
- "Return the parse of string VAL holding numeric content."
- (cdr (s-match
- "\\`\\([[:alpha:]]?[[:digit:]]+[[:alpha:]]*\\)\\(?:\\(?: *\\([,&-–—―]\\|--\\) *\\)\\([[:alpha:]]?[[:digit:]]+[[:alpha:]]*\\)\\)?\\'"
- val)))
-
-(defun citeproc--number (attrs context &rest _body)
- "Render a cs:number element with the given ATTRS in CONTEXT."
- (-let* (((&alist 'variable var
- 'form form)
- attrs)
- (variable (intern var))
- (value (citeproc-var-value variable context))
- (form (citeproc-lib-intern form)))
- (if (not value)
- (cons nil 'empty-var)
- (let ((result-attrs
- (cons `(rendered-var . ,variable) attrs))
- (result-cont
- (citeproc-number-var-value value variable form context)))
- (cons (citeproc-rt-format-single result-attrs result-cont context)
- 'present-var)))))
-
-(defconst citeproc--format-numsep-alist
- '(("&" . " & ")
- ("," . ", ")
- ("-" . "-")
- ("--" . "-")
- ("—" . "-")
- ("―" . "-"))
- "Alist specifying the proper formatting of number-pair separators.")
-
-(defun citeproc-number-var-value (value variable form context)
- "Return the numeric VALUE of VARIABLE formatted in FORM.
-VARIABLE is a symbol."
- (cond ((not value) nil)
- ((numberp value) (number-to-string value))
- (t (--if-let (citeproc-number-extract value)
- (let ((formatted-first
- (citeproc-number--format (car it) form variable context)))
- (if (> (length it) 1)
- (concat
- formatted-first
- (assoc-default (cadr it) citeproc--format-numsep-alist)
- (citeproc-number--format (cl-caddr it) form variable context))
- formatted-first))
- value))))
-
-(defun citeproc-number--format (s form term context)
- "Render the number in string S for TERM in format FORM."
- (if (s-matches-p "[[:alpha:]]" s) s
- (pcase form
- ('roman (downcase (rst-arabic-to-roman (string-to-number s))))
- ('ordinal (citeproc-number--format-as-ordinal s term context))
- ('long-ordinal (citeproc-number--format-as-long-ordinal s term context))
- (_ s))))
-
-(defun citeproc-number--format-as-ordinal (s term context)
- "Format numeric string S as ordinal agreeing with TERM."
- (let* ((terms (citeproc-context-terms context))
- (padded (if (= 1 (length s))
- (concat "0" s)
- s))
- (gender (citeproc-term-get-gender term context))
- (matches
- (--filter (and (string= (s-left 8 (citeproc-term-name it)) "ordinal-")
- (citeproc-number--ordinal-matches-p padded gender it))
- terms))
- (suffix
- (citeproc-term-text
- (if (not matches)
- (-when-let (ordinal-matches
- (--filter (string= (citeproc-term-name it) "ordinal")
- terms))
- (-if-let (match (--first (eq (citeproc-term-gender-form it) gender)
- ordinal-matches))
- match
- (car ordinal-matches)))
- (let ((first-term (car matches)))
- (-if-let (second-term (cadr matches))
- (if (= (elt (citeproc-term-name first-term) 8) ?0)
- second-term
- first-term)
- first-term))))))
- (concat s suffix)))
-
-(defconst citeproc-number--ordinal-match-alist
- '((last-two-digits . 2)
- (last-digit . 1)
- (whole-number . nil))
- "Alist mapping ordinal match attributes to the required match lengths.")
-
-(defun citeproc-number--ordinal-matches-p (s gender ord-term)
- "Whether S term with GENDER matches ordinal-term ORD-TERM."
- (and (eq gender (citeproc-term-gender-form ord-term))
- (let ((match (citeproc-term-match ord-term))
- (term-num (s-right 2 (citeproc-term-name ord-term))))
- (unless match
- (setq match
- (if (= (elt (citeproc-term-name ord-term) 8) ?0)
- 'last-digit
- 'last-two-digits)))
- (let ((l (assoc-default match citeproc-number--ordinal-match-alist)))
- (string= (citeproc-s-tail s l)
- (citeproc-s-tail term-num l))))))
-
-(defun citeproc-number--format-as-long-ordinal (s term context)
- "Format numeric string S as a long ordinal agreeing with TERM."
- (let ((num-val (string-to-number s)))
- (if (> num-val 10)
- (citeproc-number--format-as-ordinal s term context)
- (when (= 1 (length s)) (setq s (concat "0" s)))
- (let* ((name (concat "long-ordinal-" s))
- (gender (citeproc-term-get-gender term context))
- (match (--first (and (string= (citeproc-term-name it) name)
- (eq (citeproc-term-gender-form it) gender))
- (citeproc-context-terms context))))
- (if match
- (citeproc-term-text match)
- (citeproc-term-get-text name context))))))
-
-(provide 'citeproc-number)
-
-;;; citeproc-number ends here
+++ /dev/null
-;; -*- no-byte-compile: t; lexical-binding: nil -*-
-(define-package "citeproc" "20251103.716"
- "A CSL 1.0.2 Citation Processor."
- '((emacs "26")
- (dash "2.13.0")
- (s "1.12.0")
- (f "0.18.0")
- (queue "0.2")
- (string-inflection "1.0")
- (org "9")
- (parsebib "2.4")
- (compat "28.1"))
- :url "https://github.com/andras-simonyi/citeproc-el"
- :commit "a3d62ab8e40a75fcfc6e4c0c107e3137b4db6db8"
- :revdesc "a3d62ab8e40a"
- :keywords '("bib")
- :authors '(("András Simonyi" . "andras.simonyiNOSPAMgmail.com"))
- :maintainers '(("András Simonyi" . "andras.simonyiNOSPAMgmail.com")))
+++ /dev/null
-;;; citeproc-prange.el --- page-range rendering -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2017 András Simonyi
-
-;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
-
-;; 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 3 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.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; Functions to render CSL page-ranges.
-
-;;; Code:
-
-(require 'citeproc-s)
-
-(defun citeproc-prange--end-significant (start end len)
- "Return the significant digits of the end in page range START END.
-START and END are strings of equal length containing integers. If
-the significant part of END is shorter than LEN then add
-insignificant digits from END until the string is LEN long or
-there are no more digits left."
- (let ((first (min (max 1 (1+ (- (length end) len)))
- (abs (compare-strings start nil nil end nil nil)))))
- (substring end (1- first))))
-
-(defun citeproc-prange--end-complete (start end len)
- "Complete the closing form of a START END pagerange to LEN."
- (citeproc-prange--end-significant start (citeproc-s-fill-copy end start) len))
-
-(defun citeproc-prange--end-expanded (_start end end-pref)
- "Render the end of range _START END in `expanded' format.
-END-PREF is an optional non-numeric prefix preceding END. All
-arguments are strings, END has the same length as START."
- (concat end-pref end))
-
-(defun citeproc-prange--end-minimal (start end _end-pref)
- "Render the end of range START END in `minimal' format.
-END-PREFIX is an optional non-numeric prefix preceding END. All
-arguments are strings, END has the same length as START."
- (citeproc-prange--end-significant start end 1))
-
-(defun citeproc-prange--end-minimal-two (start end _end-pref)
- "Render the end of range START END in `minimal-two' format.
-END-PREFIX is an optional non-numeric prefix preceding END. All
-arguments are strings, END has the same length as START."
- (citeproc-prange--end-significant start end 2))
-
-(defun citeproc-prange--end-chicago (start end _end-pref &optional 15th-ed)
- "Render the end of range START END in `chicago' format.
-END-PREFIX is an optional non-numeric prefix preceding END. All
-arguments are strings, END has the same length as START. If
-optional 15TH-ED is non-nil then use the special 4digit rule of
-the 15th edition."
- (let ((len (length start)))
- (cond ((or (< len 3) (string= (substring start -2) "00"))
- end)
- ((string= (substring start -2 -1) "0")
- (citeproc-prange--end-significant start end 1))
- ((and 15th-ed (= 4 (length start)))
- (let ((min-two (citeproc-prange--end-significant start end 2)))
- (if (> (length min-two) 2) end min-two)))
- (t (citeproc-prange--end-significant start end 2)))))
-
-(defconst citeproc-prange-formatters-alist
- `((chicago . ,(lambda (start end end-pref)
- (citeproc-prange--end-chicago start end end-pref t)))
- (chicago-15 . ,(lambda (start end end-pref)
- (citeproc-prange--end-chicago start end end-pref t)))
- (chicago-16 . citeproc-prange--end-chicago)
- (minimal . citeproc-prange--end-minimal)
- (minimal-two . citeproc-prange--end-minimal-two)
- (expanded . citeproc-prange--end-expanded))
- "Alist mapping page range formats to formatter functions.")
-
-(defun citeproc-prange-render (p format sep)
- "Render page range P in FORMAT with separator SEP."
- (with-temp-buffer
- (insert p)
- (goto-char 0)
- (while (search-forward-regexp
- "\\([[:digit:]]*[[:alpha:]]\\)?\\([[:digit:]]+\\)\\( ?\\)\\([-–—]+\\)\\( ?\\)\\([[:digit:]]*[[:alpha:]]\\)?\\([[:digit:]]+\\)"
- nil t)
- (let* ((start-pref (match-string 1))
- (start-num (match-string 2))
- (orig-dash (match-string 4))
- (orig-sep (concat (match-string 3) orig-dash (match-string 5)))
- (end-pref (match-string 6))
- (end-num (match-string 7))
- (end (concat end-pref end-num))
- (old-sep-w-end (concat orig-sep end))
- ;; Note: To conform with the official CSL tests we don't replace the separating
- ;; dash with SEP if collapse cannot be applied because of incompatible prefixes
- ;; but we still remove spaces surrounding the dash. It would make far more
- ;; sense to replace the dash as well.
- (new-sep-w-end (cond ((not (string= start-pref end-pref))
- (concat orig-dash end))
- ;; Deal with degenerate single page "ranges"
- ((string= start-num end-num)
- "")
- ((or (not format) (> (length end-num) (length start-num)))
- (concat sep end))
- (t (concat
- sep
- (funcall (alist-get format
- citeproc-prange-formatters-alist)
- start-num
- (citeproc-s-fill-copy end-num start-num)
- end-pref))))))
- (unless (string-equal new-sep-w-end old-sep-w-end)
- (delete-char (- (length old-sep-w-end)))
- (insert new-sep-w-end))))
- (buffer-string)))
-
-(provide 'citeproc-prange)
-
-;;; citeproc-prange.el ends here
+++ /dev/null
-;;; citeproc-proc.el --- construct and manage citation processors -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2017 András Simonyi
-
-;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
-
-;; 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 3 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.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; Structure type and functions to construct citation processor objects, add or
-;; clear stored bibliography items, and disambiguate and finalize the rendering
-;; of the stored items.
-
-;;; Code:
-
-(require 'subr-x)
-(require 'dash)
-(require 'cl-lib)
-(require 'queue)
-(require 's)
-
-(require 'citeproc-date)
-(require 'citeproc-itemdata)
-(require 'citeproc-disamb)
-
-(cl-defstruct (citeproc-proc (:constructor citeproc-proc--create))
- "Citation processor struct.
-STYLE is a `citeproc-style' struct,
-GETTER is a bibliography item getter,
-ITEMDATA is a hash table that maps itemids to `citeproc-itemdata'
- structs,
-CITATIONS is a queue containing citations,
-NAMES is hash table that maps name alists to ids,
-FINALIZED is non-nil iff the processor is finalized
- (bibliography items are properly sorted, citation positions are
- updated etc),
-UNCITED is a list of lists of uncited itemids to be added during
- finalization,
-BIB-FILTERS is a list of filters defining sub-bibliographies."
- style getter itemdata citations names finalized uncited bib-filters)
-
-(defun citeproc-proc--internalize-name (name proc)
- "Find or add name-alist NAME in/to the names stored in PROC.
-Return an internalized version which contains the name-id, and is
-sorted."
- (let* ((sorted (sort name (lambda (x y)
- (string< (car x) (car y)))))
- (names (citeproc-proc-names proc))
- (val (gethash sorted names)))
- (cons (cons 'name-id
- (or val (puthash sorted (hash-table-count names) names)))
- sorted)))
-
-(defconst citeproc-proc--nonstd-csl-vars-alist
- '((shortTitle . title-short) (journalAbbreviation . container-title-short))
- "Alist mapping non-standard citeproc.js vars to their standard CSL peers.")
-
-(defun citeproc-proc--internalize-item (proc item)
- "Return the internal form of a CSL json ITEM for PROC."
- (let* (label
- page-first
- (result
- (--map
- (let* ((orig-var (car it))
- (var (-if-let (mapped (alist-get orig-var
- citeproc-proc--nonstd-csl-vars-alist))
- mapped
- orig-var))
- (value (citeproc-proc--parse-csl-var-val (cdr it) var proc)))
- (pcase var
- ('page (-when-let (page-first-match (s-match "[[:digit:]]+" value))
- (setq page-first (car page-first-match))))
- ('label (setq label t)))
- (cons var value))
- item)))
- (when page-first (push (cons 'page-first page-first) result))
- (unless label (push (cons 'label "page") result))
- ;; Generate the editor-translator variable if needed
- ;; (required by CSL 1.02)
- (when-let* (((null (alist-get 'editor-translator result)))
- (editor (alist-get 'editor result))
- (translator (alist-get 'translator result))
- ((string= (alist-get 'name-id editor)
- (alist-get 'name-id translator))))
- (push (cons 'editor-translator editor) result))
- result))
-
-(defun citeproc-proc--put-item (proc item itemid &optional uncited)
- "Put parsed csl-json ITEM with ITEMID into PROC.
-Return the added itemdata structure."
- (let* ((int-vars (citeproc-proc--internalize-item proc item))
- (itemdata (citeproc-itemdata-create :varvals int-vars :uncited uncited)))
- (citeproc-proc-put-itd-put itemid itemdata proc)
- (citeproc-itd-setvar itemdata 'citation-number
- (number-to-string (hash-table-count
- (citeproc-proc-itemdata proc))))
- (setf (citeproc-proc-finalized proc) nil)
- itemdata))
-
-(defun citeproc-proc-put-item-by-id (proc itemid)
- "Put item with ITEMID into the itemlist of PROC.
-Return the itemdata struct that was added."
- (let ((item (cdar (funcall (citeproc-proc-getter proc)
- (list itemid)))))
- (citeproc-proc--put-item proc
- (or item `((unprocessed-with-id . ,itemid)))
- itemid)))
-
-(defun citeproc-proc-put-items-by-id (proc itemids)
- "Add items with ITEMIDS into the itemlist of PROC."
- (let* ((received (funcall (citeproc-proc-getter proc) itemids))
- ;; OPTIMIZE: putting the received items into the original order could/should be
- ;; made more efficient
- (items (--map (cons it (assoc-default it received))
- itemids)))
- (cl-loop for (itemid . item) in items do
- (citeproc-proc--put-item proc
- (or item `((unprocessed-with-id . ,itemid)))
- itemid))))
-
-(defun citeproc-proc-put-itd-put (id data proc)
- "Put the DATA of item with ID in processor PROC."
- (let ((itemdata (citeproc-proc-itemdata proc)))
- (puthash id data itemdata)))
-
-(defun citeproc-proc-process-uncited (proc)
- "Add uncited items to the itemdata in PROC."
- (when-let ((unciteds (citeproc-proc-uncited proc)))
- (let* ((itemids (cl-delete-duplicates (apply #'append unciteds))))
- (when (member "*" itemids)
- (setq itemids (funcall (citeproc-proc-getter proc) 'itemids)))
- (let* ((itemdata (citeproc-proc-itemdata proc))
- (new-ids (--remove (gethash it itemdata) itemids))
- (id-items (funcall (citeproc-proc-getter proc) new-ids)))
- (pcase-dolist (`(,id . ,item) id-items)
- (citeproc-proc--put-item
- proc
- (or item `((unprocessed-with-id . ,id)))
- id t))))))
-
-(defun citeproc-proc-delete-occurrence-info (proc)
- "Remove all itemdata occurrence info from PROC."
- (maphash (lambda (_ itd)
- (setf (citeproc-itemdata-occurred-before itd) nil))
- (citeproc-proc-itemdata proc)))
-
-(defun citeproc-proc--parse-csl-json-name (rep)
- "Parse the json representation REP of a csl name variable."
- (if-let ((literal (alist-get 'literal rep)))
- (list (cons 'family (citeproc-s-smart-apostrophes literal)))
- (let ((filtered (-remove (lambda (x) (eq (car x) 'isInstitution)) rep)))
- (--map (cons
- (car it)
- (let ((text-field (cdr it)))
- (if (stringp text-field)
- (citeproc-s-smart-apostrophes text-field)
- text-field)))
- filtered))))
-
-(defun citeproc-proc--parse-csl-var-val (rep var proc)
- "Parse the json representation REP of csl variable VAR.
-VAR is a csl variable as symbol;
-REP is its value in standard csl json representation as parsed by
- the Emacs `json' library;
-PROC is the target citeproc-processor of the internal representation.
-Return the PROC-internal representation of REP."
- (cond ((memq var citeproc--name-vars)
- (--map (citeproc-proc--internalize-name
- (citeproc-proc--parse-csl-json-name it)
- proc)
- rep))
- ((memq var citeproc--date-vars)
- (citeproc-date-parse rep))
- ;;FIXME: We handle here the id... do we need it in the itemdata at all?
- ((or (memq var citeproc--number-vars) (eq 'id var))
- (citeproc-s-from-num-or-s rep))
- ((stringp rep)
- (let* ((w-aposts (citeproc-s-smart-apostrophes rep))
- (rt (citeproc-rt-from-str w-aposts)))
- (if (s-contains-p "\"" rep)
- (let* ((terms (citeproc-style-terms (citeproc-proc-style proc)))
- (oq (citeproc-term-text-from-terms "open-quote" terms))
- (cq (citeproc-term-text-from-terms "close-quote" terms)))
- (citeproc-rt-change-case
- rt (lambda (x) (citeproc-s-smart-quotes x oq cq))))
- rt)))
- (t rep)))
-
-(defun citeproc-proc-disamb (proc)
- "Disambiguate the items stored in PROC."
- (let* ((cite-opts (citeproc-style-cite-opts (citeproc-proc-style proc)))
- (name (string= "true" (alist-get 'disambiguate-add-names cite-opts)))
- (given (string= "true" (alist-get 'disambiguate-add-givenname cite-opts)))
- (yearsuff (string= "true" (alist-get 'disambiguate-add-year-suffix cite-opts))))
- (citeproc-disamb-itds (hash-table-values (citeproc-proc-itemdata proc))
- (citeproc-proc-style proc)
- name given yearsuff)))
-
-(defun citeproc-proc-byte-compile (proc)
- "Byte-compile all lambdas in PROC."
- (let* ((style (citeproc-proc-style proc))
- (bib-sort (citeproc-style-bib-sort style))
- (cite-sort (citeproc-style-cite-sort style)))
- (setf (citeproc-style-macros style)
- (--map (cons (car it) (byte-compile (cdr it)))
- (citeproc-style-macros style))
- (citeproc-style-cite-layout style)
- (byte-compile (citeproc-style-cite-layout style))
- (citeproc-style-bib-layout style)
- (byte-compile (citeproc-style-bib-layout style)))
- (when bib-sort (setf (citeproc-style-bib-sort style) (byte-compile bib-sort)))
- (when cite-sort (setf (citeproc-style-cite-sort style) (byte-compile cite-sort)))))
-
-(defun citeproc-proc-filtered-bib-p (proc)
- "Return whether PROC has nontrivial filters"
- (let ((filters (citeproc-proc-bib-filters proc)))
- (and filters (not (equal filters '(nil))))))
-
-(defun citeproc-proc-max-offset (itds)
- "Return the maximal first field width of bibitems in ITDS.
-ITDS should be the value of the itemdata field of a citeproc-proc
-structure."
- (cl-loop for itd being the hash-values of itds
- when (listp (citeproc-itemdata-rawbibitem itd)) maximize
- (length (citeproc-rt-to-plain (cadr (citeproc-itemdata-rawbibitem itd))))))
-
-(provide 'citeproc-proc)
-
-;;; citeproc-proc.el ends here
+++ /dev/null
-;; citeproc-rt.el --- citeproc-el rich-text functions -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2017-2021 András Simonyi
-
-;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
-
-;; 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 3 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.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; Functions operating on rich-text contents. In citeproc-el, rich-texts are
-;; represented either by strings or by lists of the form (ATTRS RT_1 RT_2...)
-;; where ATTRS is an alist consisting of (FORMAT-ATTR . VALUE) pairs and RT_1,
-;; RT_2... are all rich-texts. The constants `citeproc-rt-format-attrs' and
-;; `citeproc-rt-ext-format-attrs' define the list of normal and extended format
-;; attributes, respectively. As a degenerate case, nil is also a legitimate
-;; rich-text.
-
-;;; Code:
-
-(require 'subr-x)
-(require 'dash)
-(require 'cl-lib)
-(require 'let-alist)
-(require 's)
-(require 'compat)
-
-(require 'citeproc-s)
-(require 'citeproc-lib)
-
-(defconst citeproc-rt-format-attrs
- '(font-variant font-style font-weight text-decoration vertical-align font-variant
- display rendered-var name-id quotes cited-item-no bib-item-no
- rendered-names href stopped-rendering rendered-locator-label)
- "The rich-text content format attributes (used in raw output).")
-
-(defconst citeproc-rt-ext-format-attrs
- (-concat '(prefix suffix delimiter subst quotes) citeproc-rt-format-attrs)
- "The list of extended format attributes.")
-
-(defun citeproc-rt-to-plain (rt)
- "Return the plain-text content of rich-text RT."
- (if (listp rt)
- (mapconcat 'citeproc-rt-to-plain
- (cdr rt)
- "")
- rt))
-
-(defun citeproc-rt-attrs (rt)
- "Return the attrs of rich content RT."
- (if (listp rt) (car rt) nil))
-
-(defun citeproc-rt-first-content (rt)
- "Return the first content element of rich content RT."
- (if (listp rt) (cadr rt) rt))
-
-(defun citeproc-rt-select-attrs (attrs keep)
- "Select attr-val pairs from alist ATTRS whose attr is in KEEP."
- (--filter (memq (car it) keep)
- attrs))
-
-(defun citeproc-rt-join-strings (rt)
- "Concatenate consecutive strings in rich-text RT."
- (cond ((< (length rt) 2)
- rt)
- ((and (char-or-string-p (car rt))
- (char-or-string-p (cadr rt)))
- (citeproc-rt-join-strings (cons (concat (car rt)
- (cadr rt))
- (cddr rt))))
- (t (cons (car rt)
- (citeproc-rt-join-strings (cdr rt))))))
-
-(defun citeproc-rt-splice-unformatted (rt)
- "Splice the body of its unformatted elements into rich-text RT."
- (if (and (consp rt) (not (alist-get 'delimiter (car rt))))
- (cons (car rt)
- (--mapcat (if (citeproc-rt-formatting-empty-p it)
- (cdr it)
- (list it))
- (cdr rt)))
- rt))
-
-(defun citeproc-rt-formatting-empty-p (rt)
- "Is the formatting of rich-text RT empty/redundant?"
- (and (consp rt) (or (not (caar rt))
- (and (eq (cl-caaar rt) 'delimiter)
- (= (length (car rt)) 1)
- (= (length rt) 2)))))
-
-(defun citeproc-rt-reduce-content (rt)
- "Reduce rich-text RT if it has no attributes or body.
-Return the original RT if it has non-empty attrs and content."
- (cond ((not (cdr rt)) nil)
- ((and (not (car rt)) (= (length rt) 2)) (cadr rt))
- (t rt)))
-
-(defun citeproc-rt-simplify-shallow (rt)
- "Simplify the first level of rich-text RT."
- (citeproc-rt-reduce-content (citeproc-rt-join-strings
- (citeproc-rt-splice-unformatted rt))))
-
-(defun citeproc-rt-simplify-deep (rt)
- "Simplify all levels of rich-text RT."
- (if (not (consp rt)) rt
- (-let* (((attrs . conts) rt)
- (simplifieds (--map (citeproc-rt-simplify-deep it)
- conts)))
- (citeproc-rt-reduce-content
- (citeproc-rt-join-strings
- (citeproc-rt-splice-unformatted (cons attrs simplifieds)))))))
-
-(defun citeproc-rt-map-strings (fun rts &optional skip-nocase)
- "Map through FUN all strings in rich-texts RTS.
-Return a new rich-text with all S content strings replaced by the
-value of FUN applied to S. No formatting is changed. If optional
-SKIP-NOCASE is non-nil then skip spans with the `nocase'
-attribute set to non-nil."
- (--map (citeproc-rt-format it fun skip-nocase) rts))
-
-(defun citeproc-rt-format (rt fun &optional skip-nocase)
- "Format all plain text in RT with FUN.
-If optional SKIP-NOCASE is non-nil then skip spans with the
-`nocase' attribute set to non-nil."
- (pcase rt
- (`nil nil)
- ((pred listp) (if (and skip-nocase (alist-get 'nocase (car rt)))
- rt
- (cons (car rt) (citeproc-rt-map-strings fun (cdr rt) skip-nocase))))
- (_ (funcall fun rt))))
-
-(defun citeproc-rt-replace-all-sim (replacements regex rts)
- "Make all REPLACEMENTS simultaneously in the strings of rich-texts RTS."
- (citeproc-rt-map-strings (lambda (x) (citeproc-s-replace-all-sim x regex replacements))
- rts))
-
-(defun citeproc-rt-strip-periods (rts)
- "Remove all periods from rich-texts RTS."
- (citeproc-rt-map-strings (lambda (x) (string-replace "." "" x)) rts))
-
-(defun citeproc-rt-length (rt)
- "Return the length of rich-text RT as a string."
- (if (listp rt)
- (-sum (mapcar #'citeproc-rt-length (cdr rt)))
- (length rt)))
-
-(defun citeproc-rt--update-from-plain-1 (rt p start &optional skip-nocase)
- "Update rich-text RT from plain text P from position START in P.
-The length of the plain text content of RT must not be less than
-the length of P. If optional SKIP-NOCASE is non-nil then skip
-spans with the `nocase' attribute set to non-nil.
- Return an (UPDATED . NEXT) pair where UPDATED is the updated
-rich-text and NEXT is the first position in P which was not used
-for the update."
- (pcase rt
- (`nil nil)
- ((pred listp)
- (if (and skip-nocase (alist-get 'nocase (car rt)))
- (cons rt (+ start (citeproc-rt-length rt)))
- (let ((act-start start))
- (cons (cons (car rt)
- (--map (-let (((updated . next)
- (citeproc-rt--update-from-plain-1
- it p act-start skip-nocase)))
- (setq act-start next)
- updated)
- (cdr rt)))
- act-start))))
- (_ (let ((end (+ start (length rt))))
- (cons (substring p start end) end)))))
-
-(defun citeproc-rt-update-from-plain (rt p &optional skip-nocase)
- "Update rich-text RT from plain text P.
-The length of the plain text content of RT must not be less than
-the length of P. Return the updated rich-text. If optional
-SKIP-NOCASE is non-nil then skip spans with the `nocase'
-attribute set to non-nil."
- (car (citeproc-rt--update-from-plain-1 rt p 0 skip-nocase)))
-
-(defun citeproc-rt-change-case (rt case-fun)
- "Change the case of rich text RT with CASE-FUN.
-CASE-FUN is a function taking a string as its argument and
-returning a string of the same length."
- (let ((plain (citeproc-rt-to-plain rt)))
- (citeproc-rt-update-from-plain rt (funcall case-fun plain) t)))
-
-(defun citeproc-rt-pred-counts-tree (rt pred)
- "Return a dominated count tree for rich text RT based on PRED.
-The returned tree has the same structure as RT but the car of
-each subtree is a number indicating the maximal number of nodes
-on any dominated branch for which PRED holds."
- (if (consp rt)
- (let ((children-vals (--map (citeproc-rt-pred-counts-tree it pred)
- (cdr rt))))
- (cons (-max (cl-mapcar (lambda (rich count)
- (+ (if (listp count) (car count) count)
- (if (funcall pred rich) 1 0)))
- (cdr rt)
- children-vals))
- children-vals))
- 0))
-
-(defun citeproc-rt-flip-italics (rt)
- "Flip the italic attribute of rich text RT."
- (if (listp rt)
- (cons (if (citeproc-rt-in-italics-p rt)
- (--remove (eq (car it) 'font-style) (car rt))
- (cons '(font-style . "italic") (car rt)))
- (cdr rt))
- `(((font-style . "italic")) ,rt)))
-
-(defun citeproc-rt-in-italics-p (rt)
- "Whether rich text RT has italic font style as attribute."
- (and (listp rt)
- (string= (alist-get 'font-style (car rt)) "italic")))
-
-(defun citeproc-rt-italics-flipflop (rt)
- "Return a flipflopped italics version of rich text RT."
- (if (and rt (listp rt))
- (let ((italics-counts-tree
- (citeproc-rt-pred-counts-tree rt 'citeproc-rt-in-italics-p)))
- (if (> (+ (car italics-counts-tree)
- (if (citeproc-rt-in-italics-p rt) 1 0))
- 1)
- (citeproc-rt--italics-flipflop-1 rt italics-counts-tree)
- rt))
- rt))
-
-(defun citeproc-rt--italics-flipflop-1 (rt italics-counts-tree)
- "Flipflop italics in RT using info from ITALICS-COUNTS-TREE."
- (let ((rt-italic (citeproc-rt-in-italics-p rt)))
- (if (or (not (listp rt))
- (not (listp italics-counts-tree))
- (< (+ (car italics-counts-tree)
- (if rt-italic 1 0))
- 2)) rt
- (if rt-italic
- (cons (--remove (eq (car it) 'font-style) (car rt))
- (cl-mapcar (lambda (r i)
- (citeproc-rt--italics-flipflop-1
- (citeproc-rt-flip-italics r) i))
- (cdr rt)
- (cdr italics-counts-tree)))
- (cons (car rt)
- (cl-mapcar (lambda (r i) (citeproc-rt--italics-flipflop-1 r i))
- (cdr rt)
- (cdr italics-counts-tree)))))))
-
-(defun citeproc-rt-from-str (s)
- "Parse a html or plain text string S into rich text."
- (if (and s (s-matches-p "</[[:alnum:]]+>" s))
- (let* ((parsed (citeproc-lib-parse-html-frag s))
- (body (cddr (cl-caddr parsed)))
- (stripped (if (and (consp (car body)) (eq (caar body) 'p))
- (cl-cddar body)
- body)))
- (if (= 1 (length stripped))
- (citeproc-rt-from-html (car stripped))
- (cons nil (mapcar 'citeproc-rt-from-html stripped))))
- s))
-
-(defconst citeproc-rt-from-html-alist
- '(((i . nil) . (font-style . "italic"))
- ((b . nil) . (font-weight . "bold"))
- ((span . ((style . "font-variant:small-caps;"))) . (font-variant . "small-caps"))
- ((sc . nil) . (font-variant . "small-caps"))
- ((sup . nil) . (vertical-align . "sup"))
- ((sub . nil) . (vertical-align . "sub"))
- ((span . ((class . "nocase"))) . (nocase . t))
- ((span . ((class . "underline"))) . (text-decoration . "underline")))
- "A mapping from html tags and attrs to rich text attrs.")
-
-(defun citeproc-rt-from-html (h)
- "Convert simple html H to rich text."
- (if (listp h)
- (cons (-if-let (attr (assoc-default (cons (car h) (cadr h))
- citeproc-rt-from-html-alist))
- (list attr)
- '(nil))
- (mapcar #'citeproc-rt-from-html (cddr h)))
- h))
-
-(defun citeproc-rt--cquote-pstns-1 (rt offset)
- "Return closing quote positions in rich text RT with OFFSET.
-The positions are in the plain text of RT and only those
-positions are returned which are associated with a CSL
-`quotes'=\"yes\" attribute."
- (if (listp rt)
- (let ((inner (let ((act-offset offset)
- pstns)
- (--each (cdr rt)
- (-let (((p . next)
- (citeproc-rt--cquote-pstns-1 it act-offset)))
- (setq pstns (nconc pstns p)
- act-offset next)))
- (cons pstns act-offset))))
- (if (string= (alist-get 'quotes (car rt)) "true")
- (-let (((inner-pstns . inner-offset) inner))
- (cons (cons (1- inner-offset) inner-pstns)
- inner-offset))
- inner))
- (cons nil (+ offset (length rt)))))
-
-(defun citeproc-rt--cquote-pstns (rt)
- "Return a list of closing quote positions in RT.
-The positions are in the plain text of RT and only those
-positions are returned which are associated with a CSL
-`quotes'=\"yes\" attribute. Numbering starts from 1.
-The positions are in decreasing order."
- (sort (car (citeproc-rt--cquote-pstns-1 rt 1)) '>))
-
-(defun citeproc-rt-punct-in-quote (rt)
- "Put commas and periods inside quotes in rich text RT."
- (-if-let (pstns (citeproc-rt--cquote-pstns rt))
- (let ((plain (citeproc-rt-to-plain rt)))
- (citeproc-rt-update-from-plain
- rt
- (with-temp-buffer
- (insert plain)
- (dolist (pos pstns)
- (goto-char (1+ pos))
- (when (memq (char-after) '(?, ?.))
- (call-interactively 'transpose-chars)))
- (buffer-string))))
- rt))
-
-(defun citeproc-rt-find-first-node (rt pred)
- "Return the first node of RT for which PRED holds.
-Return nil if no such node was found."
- (if (funcall pred rt) rt
- (pcase rt
- ;; process further if internal node with content
- (`(,_ . ,body)
- (let (found)
- (while (and (not found) body)
- (setq found (citeproc-rt-find-first-node (car body) pred))
- (pop body))
- found))
- ;; leaf or node with no content
- (_ nil))))
-
-(defun citeproc-rt-transform-first (rt pred transform)
- "Apply TRANSFORM to the first node of RT for which PRED is non-nil.
-PRED and TRANSFORM are functions taking a rich-text node as their
-sole argument. Return a (RESULT . SUCCESS) pair where RESULT is
-the resulting rich-text and SUCCESS is non-nil iff the
-transformation was successfully carried out (i.e., a node
-satisfying PRED was found)."
- (if (funcall pred rt) (cons (funcall transform rt) t)
- (pcase rt
- ;; process further if internal node with content
- (`(,attrs . ,body)
- (let* (success
- (new-body
- (--map (if success it
- (-let (((it-res . it-success)
- (citeproc-rt-transform-first it pred transform)))
- (setq success it-success)
- it-res))
- body)))
- (cons (cons attrs new-body) success)))
- ;; leaf or node with no content
- (_ (cons rt nil)))))
-
-(defun citeproc-rt-add-year-suffix (rt ys)
- "Attempt to add year suffix YS to rich-text RT.
-Return an (RT . SUCCESS) pair, where RT is the resulting
-rich-text, and SUCCESS is non-nil iff the year-suffix has been
-successfully added."
- (cl-flet ((rendered-date-var-p
- (node)
- (and (consp node)
- (memq (alist-get 'rendered-var (car node)) citeproc--date-vars)))
- (add-suffix
- (node)
- (let ((content (cadr node)))
- (if (equal content "<suppressed-date>")
- (list (car node) ys)
- (let ((full-ys (if (or (not (stringp content))
- (s-matches-p "[[:digit:]]$" content))
- ys
- (concat "-" ys))))
- (-snoc node `(((rendered-var . year-suffix)) ,full-ys)))))))
- (citeproc-rt-transform-first rt #'rendered-date-var-p #'add-suffix)))
-
-(defun citeproc-rt-replace-first-names (rt replacement)
- "Replace RT's first name-var content with REPLACEMENT.
-Return an (RT . SUCCESS) pair, where RT is the resulting
-rich-text, and SUCCESS is non-nil iff the replacement has been
-successful."
- (cl-flet ((rendered-name-var-p
- (node)
- (and (consp node)
- (assoc 'rendered-names (car node))))
- (replace (_node) replacement))
- (citeproc-rt-transform-first rt #'rendered-name-var-p #'replace)))
-
-(defun citeproc-rt-count-names (rt)
- "Return a count of the rendered names in RT."
- (if (consp rt)
- (if (alist-get 'name-id (car rt)) 1
- (apply #'+ (mapcar #'citeproc-rt-count-names (cdr rt))))
- 0))
-
-(defun citeproc-rt-cull-spaces-puncts (rt)
- "Remove unnecessary characters from rich-text RT."
- (let* ((plain (citeproc-rt-to-plain rt))
- (updated (citeproc-rt-update-from-plain
- rt (citeproc-s-cull-spaces-puncts plain))))
- (citeproc-rt-format updated
- (lambda (x) (replace-regexp-in-string "\7f+" "" x)))))
-
-(defun citeproc-rt-render-affixes (rt &optional shallow)
- "Render the affixes in rich-text RT.
-If SHALLOW is non-nil then render only the affixes for the first
-level."
- (if (not (consp rt))
- rt
- (-let* (((attrs . contents) rt)
- (rendered
- (if shallow ; We do the recursive call depending on SHALLOW
- contents
- (-non-nil (--map (citeproc-rt-render-affixes it) contents)))))
- (if rendered
- (let-alist attrs
- (let ((delimited (if .delimiter
- (cdr (--mapcat (list .delimiter it) rendered))
- rendered)))
- (if (or .suffix .prefix)
- (let (result
- outer-attrs
- (inner-attrs
- (citeproc-rt-select-attrs attrs citeproc-rt-format-attrs)))
- (when .display ; The display attribute should encompass affixes
- (setq outer-attrs (list (cons 'display .display))
- inner-attrs (--remove (eq (car it) 'display) inner-attrs)))
- (when .suffix (push .suffix result))
- (push (cons inner-attrs
- delimited)
- result)
- (when .prefix (push .prefix result))
- (cons outer-attrs result))
- (cons (citeproc-rt-select-attrs attrs citeproc-rt-format-attrs)
- delimited))))
- nil))))
-
-(defun citeproc-rt-dedup (rt)
- "Remove duplicate substituted renderings from content RT."
- (car (citeproc-rt--dedup-single rt nil)))
-
-(defun citeproc-rt--dedup-single (rt substs)
- "Remove duplicate subst. var renderings from RT.
-SUBSTS contains an initial list of vars to be removed. Return
-a (<deduplicated content of RT> <substitued vars in RT> <vars in RT>) list."
- (if (not (consp rt))
- (list rt nil nil)
- (-let* (((attrs . cs) rt)
- ((&alist 'subst subst
- 'rendered-var var)
- attrs))
- (if (and var (memq var substs))
- (list nil nil nil)
- (-let (((new-c s v) (citeproc-rt--dedup-multi cs substs)))
- (list (cons (--reject (memq (car it) '(subst rendered-vars)) attrs)
- new-c)
- (if subst
- (-concat v (when var (list var)))
- s)
- (-concat v (if var
- (list var)
- nil))))))))
-
-(defun citeproc-rt--dedup-multi (cs substs)
- (if cs
- (-let* (((c s1 v1) (citeproc-rt--dedup-single (car cs) substs))
- ((cs s2 v2) (citeproc-rt--dedup-multi (cdr cs) (-concat substs s1))))
- (list (cons c cs)
- (-concat s1 s2)
- (-concat v1 v2)))
- (list nil nil nil)))
-
-(defun citeproc-rt-finalize (rt &optional punct-in-quote)
- "Finalize rich text RT.
-If the optional PUNCT-IN-QUOTE is non-nil then put punctuation
-inside quotes.
-
-Note: Finalization doesn't include culling, because some
-rich-text transformations require the state before culling (e.g.
-the replacement of subsequent authors)."
- ;; The first step is to replace the internally used `modifier letter
- ;; apostrophe' characters with the normal `right single quotation marks'
- (citeproc-rt-format (citeproc-rt-simplify-deep
- (citeproc-rt-italics-flipflop
- (if punct-in-quote (citeproc-rt-punct-in-quote rt) rt)))
- (lambda (x) (s-replace "ʼ" "’" x))))
-
-(defun citeproc-rt--attr-values (r attr)
- "Return the list of ATTR values in raw rich-text content R.
-The values are ordered depth-first."
- (if (listp r)
- (let ((val (alist-get attr (car r)))
- (body-vals (--mapcat (citeproc-rt--attr-values it attr) (cdr r))))
- (if val (cons val body-vals)
- body-vals))
- nil))
-
-(defun citeproc-rt-rendered-name-ids (r)
- "Return the list of name ids in raw content R."
- (citeproc-rt--attr-values r 'name-id))
-
-(defun citeproc-rt-rendered-vars (r)
- "Return the list of rendered vars in raw content R."
- (citeproc-rt--attr-values r 'rendered-var))
-
-(defun citeproc-rt-rendered-date-vars (r)
- "Return the list of date vars in raw content R."
- (--select (memq it citeproc--date-vars) (citeproc-rt-rendered-vars r)))
-
-(defun citeproc-rt-rendered-name-vars (r)
- "Return the list of name vars in raw content R."
- (--select (memq it citeproc--name-vars) (citeproc-rt-rendered-vars r)))
-
-;;; Helpers for bibliography rendering
-
-(defun citeproc-rt-subsequent-author-substitute (bib s)
- "Substitute S for subsequent author(s) in BIB.
-BIB is a list of bib entries in rich-text format. Return the
-modified bibliography."
- (let (prev-author)
- (--map
- (let ((author
- (citeproc-rt-find-first-node
- it
- (lambda (x)
- (and (consp x) (assoc 'rendered-names (car x)))))))
- (if (equal author prev-author)
- (car (citeproc-rt-replace-first-names it s))
- (prog1 it (setq prev-author author))))
- bib)))
-
-(defun citeproc-rt-link-title (r target)
- "Link the rendered title var in rich-text R to TARGET."
- (cl-flet ((rendered-var-title-p
- (node)
- (and (consp node)
- (eq (alist-get 'rendered-var (car node)) 'title)))
- (add-link
- (node)
- (push (cons 'href target) (car node))))
- (citeproc-rt-transform-first r #'rendered-var-title-p #'add-link)))
-
-(defun citeproc-rt-locator-p (r)
- "Return whether rich-text R is a rendered locator."
- (and (consp r) (string= (alist-get 'rendered-var (car r)) "locator")))
-
-(defun citeproc-rt-locator-label-p (r)
- "Return whether rich-text R is a rendered locator label."
- (and (consp r) (alist-get 'rendered-locator-label (car r))))
-
-(defun citeproc-rt-add-locator-label-position (r)
- "Add information about locator-label position in rich-text R.
-Return value is one of `label', `locator', `label-first',
-`locator-first', `label-only', `locator-only' or nil. This
-information is also added to the tree node attributes."
- (let ((result
- (cond
- ((not (consp r)) nil)
- ((citeproc-rt-locator-p r) 'locator)
- ((citeproc-rt-locator-label-p r) 'label)
- (t (let ((content (cdr r))
- first second)
- (while (and content (not (and first second)))
- (let* ((cur (pop content))
- (cur-order (citeproc-rt-add-locator-label-position cur)))
- (pcase cur-order
- ('label-first (setq first 'label second 'locator))
- ('locator-first (setq first 'locator second 'label))
- ((or 'label-only 'label)
- (if first (setq second 'label)
- (setq first 'label)))
- ((or 'locator-only 'locator)
- (if first (setq second 'locator)
- (setq first 'locator))))))
- (cond
- ((not first) nil)
- ((not second) (if (eq first 'locator) 'locator-only 'label-only))
- (t (if (eq first 'locator) 'locator-first 'label-first))))))))
- (when result (push (cons 'l-l-pos result) (car r)))
- result))
-
-(defun citeproc-rt-locator-w-label (r)
- "Return locator with label if found from rich-text R.
-Return R if no locator or locator label was found."
- (let ((l-l-pos (citeproc-rt-add-locator-label-position r)))
- (if l-l-pos
- (citeproc-rt-locator-w-label-1 r l-l-pos)
- ;; We return the full cite if no locator was found.
- r)))
-
-(defun citeproc-rt-locator-w-label-1 (r l-l-pos)
- "Return locator-label span from rich-text fragment R.
-L-L-POS is the global position of locator and label, see the
-documentation of `citeproc-rt-add-locator-label-position' for the
-possible values."
- (if (or (citeproc-rt-locator-label-p r) (citeproc-rt-locator-p r)) r
- (pcase-let* ((`(,attrs . ,content) r)
- (local-llpos (alist-get 'l-l-pos attrs)))
- (cons attrs
- (let (result
- (n-boundaries (if (or (and (eq l-l-pos 'locator-first)
- (eq local-llpos 'label-only))
- (and (eq l-l-pos 'label-first)
- (eq local-llpos 'locator-only)))
- 1 ; Fragment starts in a between position.
- 0))) ; Fragment starts in a before position.
- (while (and content (< n-boundaries 2))
- (let* ((cur-rt (pop content))
- (cur-rt-llpos (and (consp cur-rt) (alist-get 'l-l-pos (car cur-rt)))))
- (cond (cur-rt-llpos
- ;; Element at boundary
- (cl-incf n-boundaries
- (if (or (eq l-l-pos 'locator-only)
- (memq cur-rt-llpos '(label-first locator-first)))
- 2
- 1))
- (push (citeproc-rt-locator-w-label-1 cur-rt l-l-pos) result))
- ;; Element in between position, simply pushing
- ((= n-boundaries 1)
- (push cur-rt result)))))
- (nreverse result))))))
-
-(provide 'citeproc-rt)
-
-;;; citeproc-rt.el ends here
+++ /dev/null
-;;; citeproc-s.el --- citeproc-el string functions -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2017 András Simonyi
-
-;; Author: András Simonyi <andras.simonyi@gmail.com>
-
-;; 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 3 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.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; String utility functions for citeproc-el.
-
-;;; Code:
-
-(require 'thingatpt)
-(require 's)
-(require 'compat)
-
-(defun citeproc-s-camelcase-p (s)
- "Return whether string S is in camel case."
- (let ((case-fold-search nil))
- (and (< 1 (length s))
- (s-matches-p "[[:upper:]]" (substring s 1))
- (s-matches-p "[[:lower:]]" s))))
-
-(defun citeproc-s-fill-copy (s1 s2)
- "Return a copy of string S1 filled by characters from string S2.
-If string S1 is shorter than string S2 then prepend enough
-characters from to beginning of S2 to the beginning of a copy of
-S2 to make their length equal, and return the filled copy."
- (if (>= (length s1) (length s2)) s1
- (concat (substring s2 0 (- (length s2) (length s1))) s1)))
-
-(defun citeproc-s-fill-left-to-len (s len &optional char)
- "Fill string S to length LEN with CHAR from left."
- (let ((len-s (length s))
- (char (or char ?0)))
- (if (>= len-s len) s
- (concat (make-string (- len len-s) char) s))))
-
-(defun citeproc-s-nil-or-s-to-num (s)
- "Convert S, which is a string or nil to a number.
-A nil value is converted to 0."
- (if s (string-to-number s) 0))
-
-(defun citeproc-s-from-num-or-s (x)
- "Return the content of string or number X as a number."
- (if (numberp x) (number-to-string x) x))
-
-(defun citeproc-s-content (s)
- "Return the string content of string or symbol or nil S.
-The string content of nil is defined as \"\"."
- (pcase s
- ((\` nil) "")
- ((pred symbolp) (symbol-name s))
- (_ s)))
-
-(defun citeproc-s-slice-by-matches (s regexp &optional start annot)
- "Slice S up at the boundaries of each REGEXP match.
-Optionally start from index START. Matches are also included
-among the slices, but all zero-length slices are omitted. If
-optional ANNOT is non-nil then slices are given as (S . B) cons
-cells where S is the slice string, while B is nil if the S slice
-is a separating REGEXP match and t otherwise."
- (unless start (setq start 0))
- (save-match-data
- (let ((begin (string-match regexp s start)))
- (if begin
- (let ((end (match-end 0)))
- (if (and (= begin start) (= end start))
- (citeproc-s-slice-by-matches s regexp (1+ start) annot)
- (let ((result (citeproc-s-slice-by-matches (substring s end)
- regexp 0 annot)))
- (unless (= begin end)
- (let ((slice (substring s begin end)))
- (push (if annot (list slice) slice) result)))
- (unless (= 0 begin)
- (let ((slice (substring s 0 begin)))
- (push (if annot (cons slice t) slice) result)))
- result)))
- (list (if annot (cons s t) s))))))
-
-(defun citeproc-s-tail (s length)
- "Return the closing substring of string S with length LENGTH.
-Return S if LENGTH is nil or not less than the length of S."
- (let ((l (length s)))
- (if (and length (< length l))
- (substring s (- l length))
- s)))
-
-(defun citeproc-s-capitalize-first (s)
- "Capitalize the first word in string S.
-Return the capitalized version of S. If S contains no word or the
-first word is not in lowercase then return S."
- (if (s-present-p s)
- (with-temp-buffer
- (insert s)
- (goto-char 1)
- (forward-word)
- (backward-word)
- (let ((word (word-at-point)))
- (when (s-lowercase-p word)
- (capitalize-word 1)))
- (buffer-string))
- s))
-
-(defun citeproc-s-capitalize-all (s)
- "Capitalize all lowercase words in string S.
-Return the capitalized version of S. If S contains no word or the
-first word is not in lowercase then return S."
- (if (s-present-p s)
- (with-temp-buffer
- (insert s)
- (goto-char 1)
- (while (forward-word)
- (let ((word (word-at-point)))
- (when (s-lowercase-p word)
- (capitalize-word -1))))
- (buffer-string))
- s))
-
-(defun citeproc-s-sentence-case (s)
- "Return a sentence-cased version of string S."
- (if (s-present-p s)
- (with-temp-buffer
- (insert s)
- (goto-char 1)
- (let ((first t))
- (while (forward-word)
- (let ((word (word-at-point)))
- (cond ((s-uppercase-p word) (capitalize-word -1))
- ((and first (s-lowercase-p word)) (capitalize-word -1))))
- (when first (setq first nil))))
- (buffer-string))
- s))
-
-(defun citeproc-s-sentence-case-title (s &optional omit-nocase)
- "Return a sentence-cased version of title string S.
-If optional OMIT-NOCASE is non-nil then omit the nocase tags from the output."
- (if (s-blank-p s) s
- (let ((sliced (citeproc-s-slice-by-matches
- s "\\(<span class=\"nocase\">\\|</span>\\|: +[\"'“‘]*[[:alpha:]]\\)"))
- (protect-level 0)
- (first t)
- result)
- (dolist (slice sliced)
- (push
- (pcase slice
- ("<span class=\"nocase\">" (cl-incf protect-level) (if omit-nocase nil slice))
- ("</span>" (cl-decf protect-level) (if omit-nocase nil slice))
- ;; Don't touch the first letter after a colon since it probably
- ;; starts a subtitle.
- ((pred (string-match-p "^: +[\"'“‘]*[[:alpha:]]")) (setq first nil) slice)
- (_ (cond ((< 0 protect-level) (setq first nil) slice)
- ((not first) (downcase slice))
- (t (setq first nil)
- ;; We upcase the first letter and downcase the rest.
- (let ((pos (string-match "[[:alpha:]]" slice)))
- (if pos (concat (substring slice 0 pos)
- (upcase (substring slice pos (1+ pos)))
- (downcase (substring slice (1+ pos))))
- slice))))))
- result))
- (apply #'concat (nreverse result)))))
-
-(defconst citeproc-s-english-stopwords
- '("a" "according to" "across" "afore" "after" "against" "ahead of" "along" "alongside"
- "amid" "amidst" "among" "amongst" "an" "and" "anenst" "apart from" "apropos"
- "around" "as" "as regards" "aside" "astride" "at" "athwart" "atop" "back to"
- "barring" "because of" "before" "behind" "below" "beneath" "beside" "besides"
- "between" "beyond" "but" "by" "c" "ca" "circa" "close to" "d'" "de" "despite" "down"
- "due to" "during" "et" "except" "far from" "for" "forenenst" "from" "given" "in"
- "inside" "instead of" "into" "lest" "like" "modulo" "near" "next" "nor" "of" "off"
- "on" "onto" "or" "out" "outside of" "over" "per" "plus" "prior to" "pro" "pursuant
- to" "qua" "rather than" "regardless of" "sans" "since" "so" "such as" "than"
- "that of" "the" "through" "throughout" "thru" "thruout" "till" "to" "toward" "towards"
- "under" "underneath" "until" "unto" "up" "upon" "v." "van" "versus" "via" "vis-à-vis"
- "von" "vs." "where as" "with" "within" "without" "yet"))
-
-(defun citeproc-s-title-case (s)
- "Return a title-cased version of string S."
- (if (s-present-p s)
- (with-temp-buffer
- (insert s)
- (goto-char 1)
- (let ((first t)
- after-colon)
- (while (forward-word)
- (let ((word (word-at-point)))
- (cond ((and (not (or first after-colon))
- (member (downcase word) citeproc-s-english-stopwords)
- ;; Don't downcase A before a period:
- (or (not (string= word "A"))
- (= (point) (point-max))
- (/= (char-after) ?.)))
- (downcase-word -1))
- ((s-lowercase-p word)
- (capitalize-word -1))))
- (when first (setq first nil))
- (when (< (point) (point-max))
- (setq after-colon (or (= (char-after) ?:)
- (= (char-after) ?.))))))
- (buffer-string))
- s))
-
-(defun citeproc-s-smart-quotes (s oq cq)
- "Replace dumb quotes in string S with smart ones OQ and CQ.
-OQ is the opening quote, CQ is the closing quote to use."
- (with-temp-buffer
- (insert s)
- (goto-char 1)
- (while (search-forward "\"" nil 1)
- (let ((w-a-p (word-at-point)))
- (delete-char -1)
- (insert (if w-a-p oq cq))))
- (buffer-string)))
-
-(defun citeproc-s-replace-all-seq (s replacements)
- "Make replacements in S according to REPLACEMENTS sequentially.
-REPLACEMENTS is an alist with (FROM . TO) elements."
- (let ((result s))
- (pcase-dolist (`(,from . ,to) replacements)
- (setq result (string-replace from to result)))
- result))
-
-(defun citeproc-s-replace-all-sim (s regex replacements)
- "Replace all matches of REGEX in S according to REPLACEMENTS simultaneously.
-REPLACEMENTS is an alist with (FROM . TO) elements."
- (replace-regexp-in-string regex
- (lambda (match) (cdr (assoc-string match replacements)))
- s t t))
-
-(defun citeproc-s-smart-apostrophes (s)
- "Replace dumb apostophes in string S with smart ones.
-The replacement character used is the unicode character `modifier
-letter apostrophe'."
- (string-replace "'" "ʼ" (string-replace "’" "ʼ" s)))
-
-(defconst citeproc-s--cull-spaces-alist
- '((" " . " \7f") (";;" . ";\7f") ("..." . ".\7f\7f") (",," . ",\7f") (".." . ".\7f"))
- "Alist describing replacements for space and punct culling.")
-
-(defconst citeproc-s--cull-spaces-alist-rx
- (regexp-opt (mapcar #'car citeproc-s--cull-spaces-alist)))
-
-(defun citeproc-s-cull-spaces-puncts (s)
- "Replace unnecessary characters with delete chars in string S."
- (let ((result (citeproc-s-replace-all-seq s citeproc-s--cull-spaces-alist)))
- (dolist (match-rep '(("\\([:;!?]\\):" . "\\1\7f")
- ("\\([:.;!?]\\)\\." . "\\1\7f")
- ("\\([:;!]\\)!" . "\7f!")
- ("\\([:;?]\\)\\?" . "\7f?")
- ("\\.\\([”’‹›«»]\\)\\." . ".\\1\7f")
- (",\\([”’‹›«»]\\)," . ",\\1\7f"))
- result)
- (setq result (replace-regexp-in-string (car match-rep)
- (cdr match-rep)
- result)))))
-
-(provide 'citeproc-s)
-
-;;; citeproc-s.el ends here
+++ /dev/null
-;;; citeproc-sort.el --- cite and bibliography sorting -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2017 András Simonyi
-
-;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
-
-;; 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 3 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.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; Functions to sort cites and bibliography items.
-
-;;; Code:
-
-(require 'subr-x)
-(require 'cl-lib)
-(require 'dash)
-(require 's)
-
-(require 'citeproc-lib)
-(require 'citeproc-s)
-(require 'citeproc-rt)
-(require 'citeproc-macro)
-(require 'citeproc-proc)
-(require 'citeproc-name)
-(require 'citeproc-number)
-
-(defun citeproc--sort (_attrs _context &rest body)
- "Placeholder function corresponding to the cs:sort element of CSL."
- body)
-
-(defun citeproc-sort--name-var-key (var context)
- "Return the sort-key for name-var VAR using CONTEXT.
-VAR is a CSL name-var name as a symbol. The returned value is a
-string containing a semicolon-separated list of all full names in
-sort order."
- (citeproc-rt-to-plain
- (citeproc-rt-render-affixes
- (citeproc-name--render-var var '((form . "long") (name-as-sort-order . "all")
- (et-al-min . nil) (et-al-use-first . "0")
- (delimiter . "; "))
- nil nil nil nil nil context))))
-
-(defun citeproc-sort--date-as-key (d _context)
- "Render D citeproc-date struct as a sort key."
- (if d (let ((year (citeproc-date-year d))
- (month (or (citeproc-date-month d) 0))
- (day (or (citeproc-date-day d) 0)))
- ;; We add 5000 as an offset to deal with sorting BC years properly
- (concat (number-to-string (+ 5000 year))
- (citeproc-s-fill-left-to-len (number-to-string month) 2 ?0)
- (citeproc-s-fill-left-to-len (number-to-string day) 2 ?0)))
- ""))
-
-(defun citeproc-sort--date-var-key (var context)
- "Return the sort-key for name-var VAR using CONTEXT.
-VAR is a symbol."
- (-let* (((d1 d2) (citeproc-var-value var context))
- (rendered-first (citeproc-sort--date-as-key d1 context)))
- (if d2
- (concat rendered-first "–" (citeproc-sort--date-as-key d2 context))
- rendered-first)))
-
-(defun citeproc--key (attrs context &rest _body)
- "Return a sort key corresponding to ATTRS and CONTEXT."
- (-let (((&alist 'macro macro
- 'variable var)
- attrs)
- (global-attrs (--filter (memq (car it)
- '(names-min names-use-first names-use-last))
- attrs)))
- (if var (let ((var-sym (intern var)))
- (cond
- ((memq var-sym citeproc--number-vars)
- ;; OPTIMIZE: This is way too complicated to simply get a filled
- ;; numeric value..
- (citeproc-s-fill-left-to-len
- (citeproc-number-var-value
- (citeproc-var-value var-sym context) var-sym 'numeric context)
- 5))
- ((memq var-sym citeproc--date-vars)
- (citeproc-sort--date-var-key var-sym context))
- ((memq var-sym citeproc--name-vars)
- (citeproc-sort--name-var-key var-sym context))
- (t (citeproc-rt-to-plain (citeproc-var-value var-sym context)))))
- (let ((new-context (citeproc-context--create
- :vars (citeproc-context-vars context)
- :macros (citeproc-context-macros context)
- :terms (citeproc-context-terms context)
- :date-text (citeproc-context-date-text context)
- :date-numeric (citeproc-context-date-numeric context)
- :opts (nconc global-attrs (citeproc-context-opts context))
- :mode (citeproc-context-mode context)
- :render-mode 'sort
- :render-year-suffix nil)))
- (citeproc-macro-output-as-text macro new-context)))))
-
-(defun citeproc-sort--compare-keys (k1 k2 &optional desc)
- "Return 1, 0 or -1 depending on the sort-order of keys K1 and K2.
-If optional DESC is non-nil then reverse the comparison for
-descending sort."
- (cond ((string-collate-equalp k1 k2) 0)
- ((s-blank? k1) -1)
- ((s-blank? k2) 1)
- (t (* (if (string-collate-lessp k1 k2) 1 -1)
- (if desc -1 1)))))
-
-(defun citeproc-sort--compare-keylists (k1 k2 sort-orders)
- "Whether keylist K1 precedes keylist K2 in the sort order.
-SORT-ORDERS is a list of sort orders to use (see the bib- and
-cite-sort-orders slots of `citeproc-style' for details)."
- (citeproc-lib-lex-compare k1 k2 #'citeproc-sort--compare-keys sort-orders))
-
-(defun citeproc-sort--render-keys (style var-alist mode)
- "Render the sort keys of an item with STYLE and VAR-ALIST.
-MODE is either `cite' or `bib'."
- (let ((context (citeproc-context-create var-alist style mode 'sort))
- (sort (cl-ecase mode
- (cite (citeproc-style-cite-sort style))
- (bib (citeproc-style-bib-sort style)))))
- (if sort (funcall sort context) nil)))
-
-(defun citeproc-itd-update-sortkey (itd style)
- "Update the sort key of itemdata ITD for STYLE."
- (setf (citeproc-itemdata-sort-key itd)
- (citeproc-sort--render-keys style (citeproc-itemdata-varvals itd) 'bib)))
-
-(defun citeproc-proc-update-sortkeys (proc)
- "Update all sort keys of the itemdata in PROC."
- (let ((style (citeproc-proc-style proc))
- (itds (citeproc-proc-itemdata proc)))
- (maphash (lambda (_id itd)
- (citeproc-itd-update-sortkey itd style))
- itds)))
-
-(defun citeproc-sort-itds-on-citnum (itds)
- "Sort itemdata struct list ITDS according to citation number."
- (sort itds
- (lambda (x y)
- (< (string-to-number (citeproc-itd-getvar x 'citation-number))
- (string-to-number (citeproc-itd-getvar y 'citation-number))))))
-
-(defun citeproc-sort-itds-on-subbib (itd1 itd2)
- "Sort itemdata structs ITD1 ITD2 according to subbib order."
- (let ((idx1 (car (citeproc-itemdata-subbib-nos itd1)))
- (idx2 (car (citeproc-itemdata-subbib-nos itd2))))
- (and idx1
- (or (null idx2) (< idx1 idx2)))))
-
-(defun citeproc-sort-itds (itds sort-orders)
- "Sort the itemdata struct list ITDS according to SORT-ORDERS."
- (sort itds
- (lambda (x y)
- (citeproc-sort--compare-keylists (citeproc-itemdata-sort-key x)
- (citeproc-itemdata-sort-key y)
- sort-orders))))
-
-(defun citeproc-proc-sort-itds (proc)
- "Sort the itemdata in PROC."
- (let ((is-sorted-bib (citeproc-style-bib-sort (citeproc-proc-style proc)))
- (is-filtered (citeproc-proc-filtered-bib-p proc)))
- (when (or is-sorted-bib is-filtered)
- (let* ((itds (citeproc-sort-itds-on-citnum
- (hash-table-values (citeproc-proc-itemdata proc)))))
- (when is-sorted-bib
- (let ((sort-orders (citeproc-style-bib-sort-orders
- (citeproc-proc-style proc))))
- (setq itds (citeproc-sort-itds itds sort-orders))))
- ;; Additionally sort according to subbibliographies if there are filters.
- (when is-filtered
- (setq itds (sort itds #'citeproc-sort-itds-on-subbib)))
- ;; Set the CSL citation-number field according to the sort order.
- (--each-indexed itds
- (citeproc-itd-setvar it 'citation-number
- (number-to-string (1+ it-index))))))))
-
-(provide 'citeproc-sort)
-
-;;; citeproc-sort.el ends here
+++ /dev/null
-;; citeproc-style.el --- CSL style structure and related functions -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2017 András Simonyi
-
-;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
-
-;; 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 3 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.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; Structure type and functions for constructing and accessing CSL style
-;; objects.
-
-;;; Code:
-
-(require 'subr-x)
-(require 'let-alist)
-(require 'dash)
-(require 'cl-lib)
-(require 's)
-
-(require 'citeproc-lib)
-(require 'citeproc-locale)
-
-(cl-defstruct (citeproc-style (:constructor citeproc-style--create))
- "A struct representing a parsed and localized CSL style.
-CATEGORY is the style's category as a string,
-INFO is the style's general info (currently simply the
- corresponding fragment of the parsed xml),
-OPTS, BIB-OPTS, CITE-OPTS and LOCALE-OPTS are alists of general
- and bibliography-, cite- and locale-specific CSL options,
-BIB-SORT, BIB-LAYOUT, CITE-SORT and CITE-LAYOUT are anonymous
- functions for calculating sort-keys and rendering,
-BIB-SORT-ORDERS and CITE-SORT-ORDERS are the lists of sort orders
- for bibliography and cite sort (the value is a list containg t
- or nil as its n-th element depending on whether the sort for on
- the n-th key should be in ascending or desending order,
-CITE-LAYOUT-ATTRS contains the attributes of the citation layout
- as an alist,
-DATE-TEXT and DATE-NUMERIC are the style's date formats,
-LOCALE contains the locale to be used or nil if not set,
-MACROS is an alist with macro names as keys and corresponding
- anonymous rendering functions,
-TERMS is the style's parsed term-list,
-USES-YS-VAR is non-nil iff the style uses the YEAR-SUFFIX
- CSL-variable."
- category info opts bib-opts bib-sort bib-sort-orders
- bib-layout cite-opts cite-sort cite-sort-orders
- cite-layout cite-layout-attrs locale-opts macros terms
- uses-ys-var date-text date-numeric locale)
-
-(defun citeproc-style-parse (style)
- "Return the parsed representation of csl STYLE.
-STYLE is either a path to a style file or a style as a string.
-Returns a (YEAR-SUFF-P . PARSED-STYLE) cons cell. YEAR-SUFF-P is
-non-nil if the style uses the `year-suffix' csl var; PARSED-STYLE
-is the parsed form of the xml STYLE-FILE."
- (let ((xml-input (s-matches-p " ?<" style)))
- (with-temp-buffer
- (let ((case-fold-search t))
- (if xml-input (insert style)
- (insert-file-contents style))
- (goto-char 1)
- (cons (re-search-forward "variable=\"year-suffix\"" nil t)
- (citeproc-lib-remove-xml-comments
- (libxml-parse-xml-region (point-min) (point-max))))))))
-
-;; TODO: Parse and store info in a more structured and sensible form. Also,
-;; currently the first in-style locale is loaded that is compatible with the
-;; locale to be used. In theory, there may be more than one compatible in-style
-;; locales that should be merged in an order reflecting their closeness to the
-;; requested locale.
-(defun citeproc-create-style-from-locale (parsed-style year-suffix locale)
- "Create a citation style from parsed xml style PARSED-STYLE.
-YEAR-SUFFIX specifies whether the style explicitly uses the
-`year-suffix' csl variable. LOCALE is the locale for which
-in-style locale information will be loaded (if available)."
- (let* ((style (citeproc-style--create))
- (style-opts (cadr parsed-style))
- locale-loaded)
- (setf (citeproc-style-opts style) style-opts
- (citeproc-style-uses-ys-var style) year-suffix
- (citeproc-style-locale style)
- (or locale (alist-get 'default-locale style-opts)))
- (--each (cddr parsed-style)
- (pcase (car it)
- ('info
- (let* ((info-lst (cddr it))
- (category-info (cl-find-if
- (lambda (x) (and (eq 'category (car x))
- (eq 'citation-format (caaadr x))))
- info-lst))
- (category (cdaadr category-info)))
- (setf (citeproc-style-category style) category)))
- ('locale
- (let ((lang (alist-get 'lang (cadr it))))
- (when (and (citeproc-locale--compatible-p lang locale)
- (not locale-loaded))
- (citeproc-style--update-locale style it)
- (setq locale-loaded t))))
- ('citation
- (citeproc-style--update-cite-info style it))
- ('bibliography
- (citeproc-style--update-bib-info style it))
- ('macro
- (citeproc-style--update-macros style it))))
- style))
-
-(defun citeproc-style--parse-layout-and-sort-frag (frag)
- "Parse a citation or bibliography style xml FRAG.
-Return an alist with keys `layout', `opts', `layout-attrs', `sort'
-and `sort-orders'."
- (let* ((opts (cadr frag))
- (sort-p (eq (cl-caaddr frag) 'sort))
- (layout (citeproc-style--transform-xmltree
- (elt frag (if sort-p 3 2))))
- (layout-attrs (cl-cadadr (cl-caddr layout)))
- sort sort-orders)
- (when sort-p
- (let* ((sort-frag (cl-caddr frag)))
- (setq sort (citeproc-style--transform-xmltree sort-frag)
- sort-orders (--map (not (string= "descending" (alist-get 'sort (cadr it))))
- (cddr sort-frag)))))
- `((opts . ,opts) (layout . ,layout) (layout-attrs . ,layout-attrs)
- (sort . ,sort) (sort-orders . ,sort-orders))))
-
-(defun citeproc-style--update-cite-info (style frag)
- "Update the cite info of STYLE on the basis of its parsed FRAG."
- (let-alist (citeproc-style--parse-layout-and-sort-frag frag)
- (setf (citeproc-style-cite-opts style) .opts
- (citeproc-style-cite-layout style) .layout
- (citeproc-style-cite-layout-attrs style) .layout-attrs
- (citeproc-style-cite-sort style) .sort
- (citeproc-style-cite-sort-orders style) .sort-orders)))
-
-(defun citeproc-style--update-bib-info (style frag)
- "Update the bib info of STYLE on the basis of its parsed FRAG."
- (let-alist (citeproc-style--parse-layout-and-sort-frag frag)
- (setf (citeproc-style-bib-opts style) .opts
- (citeproc-style-bib-layout style) .layout
- (citeproc-style-bib-sort style) .sort
- (citeproc-style-bib-sort-orders style) .sort-orders)))
-
-(defun citeproc-style--update-macros (style frag)
- "Update the macro info of STYLE on the basis of its parsed FRAG."
- (let ((name (cl-cdaadr frag)))
- (setf (car frag) 'macro)
- (setf (cadr frag) nil)
- (push (cons name (citeproc-style--transform-xmltree frag))
- (citeproc-style-macros style))))
-
-(defun citeproc-style--update-locale (style frag)
- "Update locale info in STYLE using xml fragment FRAG.
-FRAG should be a parsed locale element from a style or a locale."
- (--each (cddr frag)
- (pcase (car it)
- ('style-options (setf (citeproc-style-locale-opts style)
- (-concat (citeproc-style-locale-opts style)
- (cadr it))))
- ('date
- (citeproc-style--update-locale-date style it))
- ('terms
- (let ((parsed-terms (citeproc-locale-termlist-from-xml-frag (cddr it))))
- (setf (citeproc-style-terms style)
- (if (citeproc-style-terms style)
- (citeproc-term-list-update parsed-terms (citeproc-style-terms style))
- parsed-terms)))))))
-
-(defun citeproc-style--update-locale-date (style frag)
- "Update date info in STYLE using xml fragment FRAG.
-FRAG should be a parsed locale element from a style or a locale."
- (let* ((date-attrs (cadr frag))
- (form (alist-get 'form date-attrs))
- (date-format (cons date-attrs
- (citeproc-lib-named-parts-to-alist frag))))
- (if (string= form "text")
- (unless (citeproc-style-date-text style)
- (setf (citeproc-style-date-text style) date-format))
- (unless (citeproc-style-date-numeric style)
- (setf (citeproc-style-date-numeric style) date-format)))))
-
-(defconst citeproc-style--opt-defaults
- '((cite-opts near-note-distance "5")
- (locale-opts punctuation-in-quote "false")
- (locale-opts limit-day-ordinals-to-day-1 "false")
- (bib-opts hanging-indent "false")
- (bib-opts line-spacing "1")
- (bib-opts entry-spacing "1")
- (opts initialize-with-hyphen "true")
- (opts demote-non-dropping-particle "display-and-sort"))
- "Global style options.
-Specified as a list of (STYLE-SLOT OPTION-NAME OPTION-DEFAULT)
-lists.
-
-Note: Collapse-related options are not specified here since their
-default settings are interdependent.")
-
-(defun citeproc-style--set-opt (style opt-slot opt value)
- "Set OPT in STYLE's OPT-SLOT to VALUE."
- (setf (cl-struct-slot-value 'citeproc-style opt-slot style)
- (cons (cons opt value)
- (cl-struct-slot-value 'citeproc-style opt-slot style))))
-
-(defun citeproc-style--set-opt-defaults (style)
- "Set missing options of STYLE to their default values."
- (cl-loop
- for (slot option value) in citeproc-style--opt-defaults do
- (let ((slot-value (cl-struct-slot-value 'citeproc-style slot style)))
- (unless (alist-get option slot-value)
- (setf (cl-struct-slot-value 'citeproc-style slot style)
- (cons (cons option value) slot-value)))))
- (let* ((cite-opts (citeproc-style-cite-opts style))
- (collapse (alist-get 'collapse cite-opts)))
- (when (and collapse (not (string= collapse "citation-number")))
- (let ((cite-layout-dl
- (alist-get 'delimiter (citeproc-style-cite-layout-attrs style)))
- (cite-group-dl
- (alist-get 'cite-group-delimiter cite-opts)))
- (unless cite-group-dl
- (citeproc-style--set-opt style 'cite-opts 'cite-group-delimiter ", "))
- (unless (alist-get 'after-collapse-delimiter cite-opts)
- (citeproc-style--set-opt
- style 'cite-opts 'after-collapse-delimiter cite-layout-dl))
- (when (and (member collapse '("year-suffix" "year-suffix-ranged"))
- (null (alist-get 'year-suffix-delimiter cite-opts)))
- (citeproc-style--set-opt
- style 'cite-opts 'year-suffix-delimiter cite-layout-dl))))))
-
-(defun citeproc-style--transform-xmltree (tree)
- "Transform parsed csl xml fragment TREE into a lambda."
- `(lambda (context) ,(citeproc-style--transform-xmltree-1 tree)))
-
-(defun citeproc-style--transform-xmltree-1 (tree)
- "Transform parsed xml fragment TREE into an eval-able form.
-Symbols in car position are prefixed with `citeproc--' and the
-symbol `context' is inserted everywhere after the second (attrs)
-position and before the (possibly empty) body."
- (pcase tree
- ((pred atom) tree)
- (`(names . ,_) (citeproc-style--transform-names tree))
- (_
- `(,(intern (concat "citeproc--" (symbol-name (car tree))))
- ,(list 'quote (cadr tree))
- context
- ,@(mapcar #'citeproc-style--transform-xmltree-1 (cddr tree))))))
-
-(defun citeproc-style--transform-names (frag)
- "Transform the content of a cs:names CSL element xml FRAG."
- (let* ((names-attrs (cadr frag))
- (body (-remove #'stringp (cddr frag)))
- (vars (alist-get 'variable names-attrs))
- substs name-attrs name-parts et-al-attrs
- is-label label-attrs label-before-names)
- (--each body
- (pcase (car it)
- ('name
- (setq name-attrs (cadr it)
- name-parts (citeproc-lib-named-parts-to-alist it)
- label-before-names t))
- ('et-al
- (setq et-al-attrs (cadr it)))
- ('label
- (setq is-label t
- label-attrs (cadr it)
- label-before-names nil))
- ('substitute
- (setq substs
- (mapcar
- (lambda (x)
- (if (eq (car x) 'names)
- `(citeproc-name-render-vars
- ,(alist-get 'variable (cadr x))
- names-attrs name-attrs name-parts et-al-attrs
- is-label label-before-names label-attrs context)
- (citeproc-style--transform-xmltree-1 x)))
- (cddr it))))))
- `(if (citeproc-var-value 'suppress-author context) (cons nil 'empty-vars)
- (let* ((names-attrs ',names-attrs)
- (name-attrs ',name-attrs)
- (count (string= (alist-get 'form name-attrs) "count"))
- (et-al-attrs ',et-al-attrs)
- (name-parts ',name-parts)
- (label-attrs ',label-attrs)
- (is-label ,is-label)
- (label-before-names ,label-before-names)
- (val (citeproc-name-render-vars
- ,vars names-attrs name-attrs name-parts et-al-attrs
- is-label label-before-names label-attrs context))
- (result (if (car val)
- val
- (-if-let ((cont . type) (--first (car it)
- (list ,@substs)))
- (cons (cons (list '(subst . t)) (list cont)) type)
- (cons nil 'empty-vars))))
- (final (if count
- (let* ((number (citeproc-rt-count-names (car result)))
- (str (if (= 0 number) "" (number-to-string number))))
- (cons str (cdr result)))
- result)))
- ;; Handle `author' citation mode by stopping if needed
- (citeproc-context-maybe-stop-rendering 'names context final)))))
-
-(defun citeproc-style-cite-note (style)
- "Return whether csl STYLE is a note style."
- (string= (citeproc-style-category style) "note"))
-
-(defun citeproc-style-cite-superscript-p (style)
- "Return whether csl STYLE has a superscript citaton layout."
- (string= (alist-get 'vertical-align (citeproc-style-cite-layout-attrs style))
- "sup"))
-
-(defun citeproc-style-global-opts (style layout)
- "Return the global opts in STYLE for LAYOUT.
-LAYOUT is either `bib' or `cite'."
- (-concat (cl-ecase layout
- (bib (citeproc-style-bib-opts style))
- (cite (citeproc-style-cite-opts style)))
- (citeproc-style-opts style)))
-
-(defun citeproc-style-bib-opts-to-formatting-params (bib-opts)
- "Convert BIB-OPTS to a formatting parameters alist."
- (let ((result
- (cl-loop
- for (opt . val) in bib-opts
- if (memq opt
- '(hanging-indent line-spacing entry-spacing second-field-align))
- collect (cons opt
- (pcase val
- ("true" t)
- ("false" nil)
- ("flush" 'flush)
- ("margin" 'margin)
- (_ (string-to-number val)))))))
- (if (alist-get 'second-field-align result)
- result
- (cons (cons 'second-field-align nil)
- result))))
-
-(provide 'citeproc-style)
-
-;;; citeproc-style.el ends here
+++ /dev/null
-;;; citeproc-subbibs.el --- support for subbibliographies -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2021-2022 András Simonyi
-
-;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
-
-;; 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 3 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.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; Support for generating subbibliographies based on filtering items.
-
-;;; Code:
-
-(require 'subr-x)
-(require 'compat)
-(require 'dash)
-
-(require 'citeproc-proc)
-(require 'citeproc-itemdata)
-
-(defun citeproc-sb--match-p (vv filter)
- "Return whether var-vals alist VV matches all conditions in FILTER.
-FILTER should be an alist containing symbol keys and string
-values, each pair describing an atomic condition to be
-satisified. For a list and description of the supported keys
-see the documentation of `citeproc-add-subbib-filters'."
- (let* ((csl-type (alist-get 'type vv))
- (type (or (alist-get 'blt-type vv) csl-type))
- (keyword (alist-get 'keyword vv))
- (keywords (and keyword (mapcar #'string-clean-whitespace
- (split-string keyword "[,;]" t)))))
- (--every-p
- (pcase it
- (`(type . ,key) (string= type key))
- (`(nottype . ,key) (not (string= type key)))
- (`(keyword . ,key) (member key keywords))
- (`(notkeyword . ,key) (not (member key keywords)))
- (`(filter . ,key) (funcall (intern key) vv))
- (`(csltype . ,key) (string= csl-type key))
- (`(notcsltype . ,key) (not (string= csl-type key)))
- (`(,key . ,_) (error "Unsupported Citeproc filter keyword `%s'" key)))
- filter)))
-
-(defun citeproc-sb-add-subbib-info (proc)
- "Add subbibliography information to the items in PROC."
- (when (citeproc-proc-filtered-bib-p proc)
- (let ((filters (citeproc-proc-bib-filters proc)))
- (maphash
- (lambda (_ itemdata)
- (let* ((varvals (citeproc-itemdata-varvals itemdata))
- (subbib-nos
- (-non-nil
- (--map-indexed
- (when (citeproc-sb--match-p varvals it) it-index)
- filters))))
- (setf (citeproc-itemdata-subbib-nos itemdata) subbib-nos)))
- (citeproc-proc-itemdata proc)))))
-
-(defun citeproc-sb-prune-unrendered (proc)
- "Remove all itemdata about unrendered items from PROC.
-An item is unrendered if
-- there are subbibfilters but none of them matches it, and
-- it is not cited."
- (when (citeproc-proc-filtered-bib-p proc)
- (let ((itemdata (citeproc-proc-itemdata proc)))
- (maphash
- (lambda (id data)
- (when (and (citeproc-itemdata-uncited data)
- (null (citeproc-itemdata-subbib-nos data)))
- (remhash id itemdata)))
- itemdata))))
-
-(provide 'citeproc-subbibs)
-
-;;; citeproc-subbibs.el ends here
+++ /dev/null
-;;; citeproc-term.el --- functions for term localization -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2017 András Simonyi
-
-;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
-
-;; 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 3 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.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; Functions for localizing the terms of a CSL style according to a locale.
-
-;;; Code:
-
-(require 'dash)
-(require 'cl-lib)
-(require 'let-alist)
-
-(require 'citeproc-lib)
-(require 'citeproc-s)
-
-(cl-defstruct (citeproc-term (:constructor citeproc-term--create))
- "A struct representing a localized term."
- (name nil) (form nil) (number nil) (gender nil) (gender-form nil)
- (match nil) (text nil))
-
-(defun citeproc-term--compare (t1 t2)
- "Compare terms T1 and T2.
-The comparison is based on the term fields except the last one,
-and relies on the alphabetical ordering of fields' string
-content (see the function `citeproc-lib-s-content'). Return 1, -1
-or 0 iff T1 precedes, succeeds or is equal according to the
-ordering."
- (cond ((not t2) 1)
- ((not t1) -1)
- (t (let ((idx 1)
- (result 0))
- (while (and (= result 0) (< idx 7))
- (let ((s1 (citeproc-s-content (aref t1 idx)))
- (s2 (citeproc-s-content (aref t2 idx))))
- (cond ((string< s1 s2) (setq result 1))
- ((string> s1 s2) (setq result -1))))
- (cl-incf idx)) result))))
-
-(defun citeproc-term-list--sort (tl)
- "Sort termlist TL in place using `citeproc-term--compare'."
- (cl-sort tl (lambda (x y) (> (citeproc-term--compare x y) -1))))
-
-(defun citeproc-term-list-update (tl1 tl2 &optional sorted-input)
- "Return a term list which is TL1 updated with term list TL2.
-TL1 and TL2 are list of citeproc-term structs. The order of terms
-in the returned term list is undetermined. If the optional
-SORTED-INPUT is non-nil then the term lists are supposed to be
-already sorted according to `citeproc-term--compare', otherwise
-they are sorted in-place."
- (let (result)
- (unless sorted-input
- (setq tl1 (citeproc-term-list--sort tl1)
- tl2 (citeproc-term-list--sort tl2)))
- (while (or tl1 tl2)
- (let* ((t1 (car tl1))
- (t2 (car tl2))
- (cmp (citeproc-term--compare t1 t2)))
- (cond ((= cmp 1) (push t1 result) (pop tl1))
- ((= cmp -1) (push t2 result) (pop tl2))
- (t (push t2 result) (pop tl1) (pop tl2)))))
- result))
-
-(defun citeproc-term--from-xml-frag (frag)
- "Transform xml FRAG representing a term into a citeproc-term struct."
- (let-alist (car frag)
- (-let* ((.form (or .form "long"))
- (term (citeproc-term--create
- :name .name
- :form (citeproc-lib-intern .form)
- :gender (citeproc-lib-intern .gender)
- :match (citeproc-lib-intern .match)
- :gender-form (citeproc-lib-intern .gender-form))))
- (if (= (length frag) 2)
- (progn
- (setf (citeproc-term-text term) (cadr frag))
- (list term))
- (setf (citeproc-term-text term) (cl-caddr (cadr frag)))
- (setf (citeproc-term-number term) 'single)
- (let ((multi-term (copy-citeproc-term term)))
- (setf (citeproc-term-text multi-term) (cl-caddr (cl-caddr frag)))
- (setf (citeproc-term-number multi-term) 'multiple)
- (list term multi-term))))))
-
-(defun citeproc-term-text-from-terms (term terms)
- "Return the first text associated with TERM in TERMS.
-Return nil if TERM is not in TERMS."
- (-if-let (match (--first (string= term (citeproc-term-name it))
- terms))
- (citeproc-term-text match)
- nil))
-
-(provide 'citeproc-term)
-
-;;; citeproc-term.el ends here
+++ /dev/null
-;; citeproc-test-human.el --- support tests in CSL suite format -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2017-2021 András Simonyi
-
-;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
-
-;; 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 3 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.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; Functions to create ERT tests from tests in CSL test suite format. The
-;; official tests can be found at
-;; <https://github.com/citation-style-language/test-suite>.
-
-;;; Code:
-
-(require 'f)
-(require 's)
-(require 'json)
-(require 'ert)
-(require 'string-inflection)
-
-(require 'citeproc)
-
-(defvar citeproc-test-human--locale-dir "./test/locales")
-
-(defun citeproc-test-human--parse-testfile (file)
- "Return a parsed form of CSL test FILE."
- (let (result
- (json-array-type 'list)
- (json-key-type 'symbol))
- (with-temp-buffer
- (insert-file-contents file)
- (goto-char 1)
- (setq result (list (cons 'YEAR-SUFF
- (re-search-forward "variable=\"year-suffix\"" nil t))))
- (goto-char 1)
- (while (re-search-forward ">>=+ \\{1,2\\}\\([[:graph:]]+\\) =+>>" nil t)
- (let ((section (intern (buffer-substring (nth 2 (match-data))
- (nth 3 (match-data)))))
- (start (1+ (point)))
- end)
- (re-search-forward "<<=" nil t)
- (setq end (- (car (match-data)) 1))
- (push (cons section (pcase section
- ('OUTPUT-FORMAT
- (intern (buffer-substring-no-properties start end)))
- ('CSL (buffer-substring-no-properties start end))
- ((or 'INPUT 'CITATIONS 'CITATION-ITEMS)
- (goto-char (- start 1)) (json-read))
- (_ (buffer-substring start end))))
- result))))
- result))
-
-(defun citeproc-test-human--create-getter (items)
- "Return a getter function for ITEMS.
-ITEMS is the parsed representation of the `INPUT' section of a
-CSL test."
- (lambda (itemids)
- (let (result)
- (dolist (item items result)
- (let ((id (citeproc-s-from-num-or-s (alist-get 'id item))))
- (when (member id itemids)
- (push (cons id item) result)))))))
-
-(defun citeproc-test-human--proc-from-style (style parsed-input)
- "Create a processor from STYLE and PARSED-INPUT."
- (citeproc-create style
- (citeproc-test-human--create-getter parsed-input)
- (citeproc-locale-getter-from-dir citeproc-test-human--locale-dir)))
-
-(defun citeproc-test-human--proc-from-testfile (file)
- "Create an (itemless) processor from a test FILE."
- (let ((style-string (alist-get 'CSL (citeproc-test-human--parse-testfile file)))
- (locale-getter (citeproc-locale-getter-from-dir citeproc-test-human--locale-dir)))
- (citeproc-create style-string nil locale-getter)))
-
-(defun citeproc-test-human--parse-citation (ct-desc &optional cites-only)
- "Parse test citations description CT-DESC.
-Return a list of citation structures. If CITES-ONLY is non-nil
-then the input is list of cites."
- (if cites-only
- (citeproc-citation-create
- :cites (-map #'citeproc-test-human--normalize-cite ct-desc))
- (let ((citation-info (car ct-desc)))
- (let-alist (alist-get 'properties citation-info)
- (citeproc-citation-create
- :cites (-map #'citeproc-test-human--normalize-cite
- (alist-get 'citationItems citation-info))
- :note-index .noteIndex
- :mode (citeproc-lib-intern .mode)
- :capitalize-first .capitalize-first
- :suppress-affixes .suppress-affixes
- :ignore-et-al .ignore-et-al)))))
-
-(defun citeproc-test-human--normalize-cite (cite)
- "Normalize a test CITE."
- (--map (let ((val (cdr it)))
- (if (numberp val) (cons (car it) (number-to-string val)) it))
- cite))
-
-(defun citeproc-test-human--run-parsed (parsed)
- "Run the parsed CSL test PARSED.
-Return the resulting output."
- (-let* (((&alist 'CSL style
- 'INPUT input
- 'MODE mode
- 'CITATION-ITEMS citation-items
- 'CITATIONS citations
- 'OUTPUT-FORMAT output-format)
- parsed)
- (output-format (or output-format 'csl-test))
- (proc (citeproc-test-human--proc-from-style style input)))
- (--each input
- (citeproc-proc-put-item-by-id proc
- (citeproc-s-from-num-or-s (alist-get 'id it))))
- (when (string= mode "citation")
- (cond
- (citation-items
- (citeproc-append-citations (--map (citeproc-test-human--parse-citation it t)
- citation-items)
- proc))
- (citations
- (citeproc-append-citations (mapcar #'citeproc-test-human--parse-citation citations)
- proc))
- (t (citeproc-append-citations (list (citeproc-test-human--parse-citation input t))
- proc))))
- (let ((output (if (string= mode "citation")
- (citeproc-render-citations proc output-format
- (when (eq 'csl-test output-format)
- 'no-links))
- (car (citeproc-render-bib proc output-format 'no-links)))))
- (if (string= mode "citation") (s-join "\n" output) output))))
-
-(defun citeproc-test-human--expected-from-parsed (parsed)
- "Return the expected output of parsed CSL test PARSED."
- (let ((expected (alist-get 'RESULT parsed)))
- (if (or (string= (s-left 5 expected) "..[0]")
- (string= (s-left 5 expected) ">>[0]"))
- (s-join "\n" (--map (substring it 6)
- (split-string expected "\n")))
- expected)))
-
-(defun citeproc-test-human-create-from-file (file expected-fails &optional name-prefix)
- "Create an ERT test from a CSL test FILE.
-If optional NAME-PREFIX is non-nil then it is added the name of
-the created test after the obligatory `citeproc'."
- (let* ((parsed (citeproc-test-human--parse-testfile file))
- (expected (citeproc-test-human--expected-from-parsed parsed))
- (file-name (f-filename file))
- (test-name (intern
- (concat "citeproc-"
- (if name-prefix (concat name-prefix "-") "")
- (string-inflection-kebab-case-function
- (substring file-name 0 -4)))))
- (expected-fail (memq test-name expected-fails)))
- (eval `(ert-deftest ,test-name ()
- :expected-result ,(if expected-fail :failed :passed)
- (let ((citeproc-disambiguation-cite-pos 'subsequent))
- (should (string=
- ,expected
- (citeproc-test-human--run-parsed ',parsed))))))))
-
-(defun citeproc-test-human---read-expected-fails (expected-fails-file)
- "Read the list of tests expected to fail from EXPECTED-FAILS-FILE."
- (let* ((list-as-str (with-temp-buffer
- (insert-file-contents expected-fails-file)
- (buffer-string)))
- (split (split-string list-as-str "\n")))
- (--map (intern it) (butlast split))))
-
-(defun citeproc-test-human-create-from-dir (dir &optional
- expected-fails-file name-prefix)
- "Create all CSL tests from DIR.
-Each file in DIR having the `txt' extension is read as a
-human-readable CSL test, and a corresponding ERT test is created.
-The created test's name will be constructed by prefixing the
-test's filename (without the extension) with `citeproc-'. If the
-optional EXPECTED-FAILS-FILE is non-nil then read that file as a
-list of tests whose failure is expected. If optional NAME-PREFIX
-is non-nil then it is added the names of the created tests after
-the obligatory `citeproc'. The file should contain one test-name
-per line (together with the `citeproc-' prefix)."
- (let ((expected-fails
- (if expected-fails-file
- (citeproc-test-human---read-expected-fails expected-fails-file)
- nil)))
- (dolist (test-file (f-glob (concat dir "/*.txt")))
- (citeproc-test-human-create-from-file test-file expected-fails
- name-prefix))))
-
-(provide 'citeproc-test-human)
-
-;;; citeproc-test-human.el ends here
+++ /dev/null
-;;; citeproc.el --- A CSL 1.0.2 Citation Processor -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2017-2024 András Simonyi
-
-;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
-;; Maintainer: András Simonyi <andras.simonyiNOSPAMgmail.com>
-;; URL: https://github.com/andras-simonyi/citeproc-el
-;; Keywords: bib
-;; Package-Requires: ((emacs "26") (dash "2.13.0") (s "1.12.0") (f "0.18.0") (queue "0.2") (string-inflection "1.0") (org "9") (parsebib "2.4")(compat "28.1"))
-;; Package-Version: 20251103.716
-;; Package-Revision: a3d62ab8e40a
-
-;; 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 3 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.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;; This file is not part of GNU Emacs.
-
-;;; Commentary:
-
-;; citeproc-el is a library for rendering citations and bibliographies in styles
-;; described in the Citation Style Language (CSL).
-
-;;; Code:
-
-(require 'dash)
-(require 'queue)
-
-(require 'citeproc-rt)
-(require 'citeproc-locale)
-(require 'citeproc-style)
-(require 'citeproc-choose)
-(require 'citeproc-generic-elements)
-(require 'citeproc-context)
-(require 'citeproc-itemdata)
-(require 'citeproc-proc)
-(require 'citeproc-cite)
-(require 'citeproc-sort)
-(require 'citeproc-formatters)
-(require 'citeproc-itemgetters)
-(require 'citeproc-subbibs)
-
-;;; Public API
-
-(defun citeproc-create (style it-getter loc-getter &optional loc force-loc)
- "Return a CSL processor for a given STYLE, IT-GETTER and LOC-GETTER.
-STYLE is either a path to a CSL style file or a CSL style as a
- string.
-IT-GETTER is an item-getter function that takes a list of itemid
- strings as its sole argument and returns an alist in which the
- given itemids are the keys and the values are the parsed csl
- json descriptions of the corresponding bibliography items (keys
- are symbols, arrays and hashes should be represented as lists
- and alists, respecively).
-LOC-GETTER is a function that takes a locale string (e.g.
- \"en-GB\") as an argument and returns a corresponding parsed
- CSL locale (as parsed by Emacs's `libxml-parse-xml-region').
-Optional LOC is the locale to use if the style doesn't specify a
- default one. Defaults to \"en-US\".
-If optional FORCE-LOC is non-nil then use locale LOC even if
- STYLE specifies a different one as default. Defaults to nil."
- (let ((style (citeproc-create-style style loc-getter loc force-loc))
- (names (make-hash-table :test 'equal))
- (itemdata (make-hash-table :test 'equal))
- (citations (make-queue)))
- (citeproc-proc--create :style style :getter it-getter :names names
- :itemdata itemdata :citations citations :finalized t)))
-
-(defun citeproc-append-citations (citations proc)
- "Append CITATIONS to the list of citations in PROC.
-CITATIONS is a list of `citeproc-citation' structures."
- (let ((itemdata (citeproc-proc-itemdata proc))
- ids)
- ;; Collect new itemids
- (dolist (citation citations)
- (dolist (cite (citeproc-citation-cites citation))
- (push (alist-get 'id cite) ids)))
- (let* ((uniq-ids (delete-dups (nreverse ids))) ; reverse pushed ids
- (new-ids (--remove (gethash it itemdata) uniq-ids)))
- ;; Add all new items in one pass
- (citeproc-proc-put-items-by-id proc new-ids)
- ;; Internalize the cites dealing with locator-extra if present, add itemdata to
- ;; the cite structs and add them to the cite queue.
- (dolist (citation citations)
- (setf (citeproc-citation-cites citation)
- (--map (cons (cons 'itd (gethash (alist-get 'id it) itemdata))
- (citeproc-cite--internalize-locator it))
- (citeproc-citation-cites citation)))
- (queue-append (citeproc-proc-citations proc) citation))
- (setf (citeproc-proc-finalized proc) nil))))
-
-(defun citeproc-add-uncited (itemids proc)
- "Add uncited bib items with ITEMIDS to PROC.
-As an extension, an itemid can be the string \"*\" which has the
-effect of adding all items available in the itemgetter."
- ;; We simply store the added ids here, real processing is performed when the
- ;; processor is finalized.
- (push itemids (citeproc-proc-uncited proc))
- (setf (citeproc-proc-finalized proc) nil))
-
-(defun citeproc-add-subbib-filters (filters proc)
- "Add sub-bibliography FILTERS to PROC.
-FILTERS should be a list of alists containing symbol keys and
-string values, each pair describing an atomic condition to be
-satisified by the printed entries. The following keys are
-supported:
-- `type': print only entries of the given type. Type is the
- bib(la)tex entry type if available, otherwise the CSL type is
- used as fallback;
-- `nottype': print only entries not of the given type. Type is
- the bib(la)tex entry type if available, otherwise the CSL type
- is used as fallback;
-- `csltype', `notcsltype': same as `type' and `nottype' but uses
- the entries' CSL type even if the bib(la)tex type is also
- available;
-- `keyword': print only entries with the given keyword;
-- `notkeyword': print only entries without the given keyword;
-- `filter': print only entries for which the function named by
- the key returns a non-nil value."
- (setf (citeproc-proc-bib-filters proc) filters
- (citeproc-proc-finalized proc) nil))
-
-(defun citeproc-render-citations (proc format &optional internal-links)
- "Render all citations in PROC in the given FORMAT.
-Return a list of formatted citations.
- If the optional INTERNAL-LINKS is `bib-links' then link cites
-to the bibliography regardless of the style type, if `no-links'
-then don't add internal links, if nil or `auto' then add internal
-links based on the style type (cite-cite links for note styles
-and cite-bib links else). For legacy reasons, any other value is
-treated as `no-links'."
- (citeproc-proc-finalize proc)
- (--map (citeproc-citation--render-formatted-citation it proc format internal-links)
- (queue-head (citeproc-proc-citations proc))))
-
-(defun citeproc-render-bib (proc format &optional internal-links
- no-external-links bib-formatter-fun)
- "Render a bibliography of items in PROC in FORMAT.
-For the optional INTERNAL-LINKS argument see
-`citeproc-render-citations'. If the optional NO-EXTERNAL-LINKS is
-non-nil then don't generate external links. If the optional
-BIB-FORMATTER-FUN is given then it will be used to join the
-bibliography items instead of the content of the chosen
-formatter's `bib' slot (see `citeproc-formatter' for details).
-
-Returns an error message string if the style of PROC doesn't
-contain a bibliography section. Otherwise it returns
-a (FORMATTED-BIBLIOGRAPHY . FORMATTING-PARAMETERS) cons cell,
-where FORMATTED-BIBLIOGRAPHY is either a single bibliography or a
-list of sub-bibliograhies if filters were added to the processor,
-and FORMATTING-PARAMETERS is an alist containing the following
-formatting parameters keyed to the parameter names as symbols:
-- `max-offset' (integer): The width of the widest first field in
- the bibliography, measured in characters.
-- `line-spacing' (integer): Vertical line distance specified as a
- multiple of standard line height.
-- `entry-spacing' (integer): Vertical distance between
- bibliographic entries, specified as a multiple of standard line
- height.
-- `second-field-align' (`flush'or `margin'): The position of
- second-field alignment.
-- `hanging-indent' (boolean): Whether the bibliography items should
- be rendered with hanging-indents."
- (if (null (citeproc-style-bib-layout (citeproc-proc-style proc)))
- "[NO BIBLIOGRAPHY LAYOUT IN CSL STYLE]"
- (citeproc-proc-finalize proc)
- (let* ((formatter (citeproc-formatter-for-format format))
- (rt-formatter (citeproc-formatter-rt formatter))
- (bib-formatter (or bib-formatter-fun
- (citeproc-formatter-bib formatter)))
- (bibitem-formatter (citeproc-formatter-bib-item formatter))
- (formatter-no-external-links (citeproc-formatter-no-external-links
- formatter))
- (style (citeproc-proc-style proc))
- (bib-opts (citeproc-style-bib-opts style))
- (punct-in-quote (string= (alist-get 'punctuation-in-quote
- (citeproc-style-locale-opts style))
- "true"))
- (itemdata (citeproc-proc-itemdata proc))
- (filters (citeproc-proc-bib-filters proc)))
- ;; Render raw bibitems for each itemdata struct and store them in the
- ;; `rawbibitem' slot.
- (maphash (lambda (_ itd)
- (setf (citeproc-itemdata-rawbibitem itd)
- (citeproc-rt-finalize
- (citeproc-render-varlist-in-rt
- (citeproc-itemdata-varvals itd)
- style 'bib 'display internal-links
- (or formatter-no-external-links no-external-links))
- punct-in-quote)))
- itemdata)
- (let* ((raw-bib
- (if (citeproc-proc-filtered-bib-p proc)
- ;; There are filters, we need to select and sort the subbibs.
- (let* ((nr-of-filters (length filters))
- (result (make-list nr-of-filters nil))
- ;; We store boolean to-be-sorted flags for each sub-bib
- (to-be-sorted (make-bool-vector nr-of-filters nil))
- (bib-sort (citeproc-style-bib-sort (citeproc-proc-style proc))))
- ;; Put the itds into subbib lists.
- (maphash
- (lambda (_ itd)
- (let ((subbib-nos (citeproc-itemdata-subbib-nos itd)))
- ;; Set to-be-sorted for later subbibs if itemdata
- ;; occcurs in more than one.
- (when-let ((later-subbib-nos (cdr subbib-nos)))
- (dolist (subbib-no later-subbib-nos)
- (setf (elt to-be-sorted subbib-no) t)))
- ;; Push the item in all corresponding subbibs.
- (dolist (subbib-no subbib-nos)
- (push itd (elt result subbib-no)))))
- itemdata)
- ;; Sort the itds in each individual list
- (setq result
- (--map-indexed
- (if (and bib-sort (elt to-be-sorted it-index))
- ;; Subbib contains earlier item, needs to sorted.
- (citeproc-sort-itds it (citeproc-style-bib-sort-orders
- (citeproc-proc-style proc)))
- ;; No earlier item, sorting on citation-number.
- (citeproc-sort-itds-on-citnum it))
- result))
- ;; Generate the raw bibs.
- (--map (mapcar #'citeproc-itemdata-rawbibitem it) result))
- ;; No filters, so raw-bib is a list containing a single raw bibliograhy.
- (list (mapcar #'citeproc-itemdata-rawbibitem
- (citeproc-sort-itds-on-citnum (hash-table-values itemdata))))))
- ;; Perform author-substitution.
- (substituted
- (-if-let (subs-auth-subst
- (alist-get 'subsequent-author-substitute bib-opts))
- (--map (citeproc-rt-subsequent-author-substitute it subs-auth-subst)
- raw-bib)
- raw-bib))
- ;; Calculate formatting params.
- ;; NOTE: This is the only place where we check whether there are
- ;; bibliography items in the processor, even though the empty case
- ;; could be handled way more efficiently.
- (max-offset (if (and (alist-get 'second-field-align bib-opts)
- (not (hash-table-empty-p itemdata)))
- (citeproc-proc-max-offset itemdata)
- 0))
- (format-params (cons (cons 'max-offset max-offset)
- (citeproc-style-bib-opts-to-formatting-params bib-opts)))
- (formatted-bib
- (--map (funcall bib-formatter
- (mapcar
- (lambda (x)
- (funcall
- bibitem-formatter
- (funcall
- rt-formatter (citeproc-rt-cull-spaces-puncts x))
- format-params))
- it)
- format-params)
- substituted)))
- ;; Generate final return value.
- (cons (if filters formatted-bib (car formatted-bib))
- format-params)))))
-
-(defun citeproc-clear (proc)
- "Remove all bibliographic and citation data from PROC."
- (clrhash (citeproc-proc-itemdata proc))
- (clrhash (citeproc-proc-names proc))
- (queue-clear (citeproc-proc-citations proc))
- (setf (citeproc-proc-finalized proc) t))
-
-;; For one-off renderings
-
-(defun citeproc-create-style (style locale-getter &optional locale force-locale)
- "Compile style in STYLE into a citeproc-style struct.
-STYLE is either a path to a CSL style file, or a style as a
-string. LOCALE-GETTER is a getter function for locales, the
-optional LOCALE is a locale to prefer. If FORCE-LOCALE is non-nil
-then use LOCALE even if the style's default locale is different."
- (-let* (((year-suffix . parsed-style) (citeproc-style-parse style))
- (default-locale (alist-get 'default-locale (cadr parsed-style)))
- (preferred-locale (if force-locale locale (or default-locale
- locale
- "en-US")))
- (act-parsed-locale (funcall locale-getter preferred-locale))
- (act-locale (alist-get 'lang (cadr act-parsed-locale)))
- (style (citeproc-create-style-from-locale
- parsed-style
- (not (not year-suffix)) act-locale)))
- (citeproc-style--update-locale style act-parsed-locale)
- (citeproc-style--set-opt-defaults style)
- (setf (citeproc-style-locale style) (or locale act-locale))
- style))
-
-;; REVIEW: this should be rethought -- should we apply the specific wrappers as
-;; well?
-(defun citeproc-render-item (item-data style mode format
- &optional no-external-links)
- "Render a bibliography item described by ITEM-DATA with STYLE.
-ITEM-DATA is the parsed form of a bibliography item description
- in CSL-JSON format,
-STYLE is a `citeproc-style' structure,
-MODE is one of the symbols `bib' or `cite',
-FORMAT is a symbol representing a supported output format.
-If the optional NO-EXTERNAL-LINKS is non-nil then don't generate
-external links in the item."
- (let ((internal-varlist (--map-when (memq (car it) citeproc--date-vars)
- (cons (car it)
- (citeproc-date-parse (cdr it)))
- item-data)))
- (funcall (citeproc-formatter-rt (citeproc-formatter-for-format format))
- (citeproc-rt-cull-spaces-puncts
- (citeproc-rt-finalize
- (citeproc-render-varlist-in-rt
- internal-varlist style mode 'display 'no-links no-external-links))))))
-
-(provide 'citeproc)
-
-;;; citeproc.el ends here
--- /dev/null
+citeproc-el is a library for rendering citations and bibliographies in styles
+described in the Citation Style Language (CSL).
--- /dev/null
+;;; citeproc-autoloads.el --- automatically extracted autoloads (do not edit) -*- lexical-binding: t -*-
+;; Generated by the `loaddefs-generate' function.
+
+;; This file is part of GNU Emacs.
+
+;;; Code:
+
+(add-to-list 'load-path (or (and load-file-name (directory-file-name (file-name-directory load-file-name))) (car load-path)))
+
+
+\f
+;;; Generated autoloads from citeproc.el
+
+(register-definition-prefixes "citeproc" '("citeproc-"))
+
+\f
+;;; Generated autoloads from citeproc-biblatex.el
+
+(register-definition-prefixes "citeproc-biblatex" '("citeproc-blt-"))
+
+\f
+;;; Generated autoloads from citeproc-bibtex.el
+
+(register-definition-prefixes "citeproc-bibtex" '("citeproc-bt-"))
+
+\f
+;;; Generated autoloads from citeproc-choose.el
+
+(register-definition-prefixes "citeproc-choose" '("citeproc-"))
+
+\f
+;;; Generated autoloads from citeproc-cite.el
+
+(register-definition-prefixes "citeproc-cite" '("citeproc-"))
+
+\f
+;;; Generated autoloads from citeproc-context.el
+
+(register-definition-prefixes "citeproc-context" '("citeproc-"))
+
+\f
+;;; Generated autoloads from citeproc-date.el
+
+(register-definition-prefixes "citeproc-date" '("citeproc-"))
+
+\f
+;;; Generated autoloads from citeproc-disamb.el
+
+(register-definition-prefixes "citeproc-disamb" '("citeproc-"))
+
+\f
+;;; Generated autoloads from citeproc-formatters.el
+
+(register-definition-prefixes "citeproc-formatters" '("citeproc-f"))
+
+\f
+;;; Generated autoloads from citeproc-generic-elements.el
+
+(register-definition-prefixes "citeproc-generic-elements" '("citeproc-"))
+
+\f
+;;; Generated autoloads from citeproc-itemdata.el
+
+(register-definition-prefixes "citeproc-itemdata" '("citeproc-itd-"))
+
+\f
+;;; Generated autoloads from citeproc-itemgetters.el
+
+(register-definition-prefixes "citeproc-itemgetters" '("citeproc-"))
+
+\f
+;;; Generated autoloads from citeproc-lib.el
+
+(register-definition-prefixes "citeproc-lib" '("citeproc-"))
+
+\f
+;;; Generated autoloads from citeproc-locale.el
+
+(register-definition-prefixes "citeproc-locale" '("citeproc-locale-"))
+
+\f
+;;; Generated autoloads from citeproc-macro.el
+
+(register-definition-prefixes "citeproc-macro" '("citeproc-"))
+
+\f
+;;; Generated autoloads from citeproc-name.el
+
+(register-definition-prefixes "citeproc-name" '("citeproc-"))
+
+\f
+;;; Generated autoloads from citeproc-number.el
+
+(register-definition-prefixes "citeproc-number" '("citeproc-"))
+
+\f
+;;; Generated autoloads from citeproc-prange.el
+
+(register-definition-prefixes "citeproc-prange" '("citeproc-prange-"))
+
+\f
+;;; Generated autoloads from citeproc-proc.el
+
+(register-definition-prefixes "citeproc-proc" '("citeproc-proc-"))
+
+\f
+;;; Generated autoloads from citeproc-rt.el
+
+(register-definition-prefixes "citeproc-rt" '("citeproc-rt-"))
+
+\f
+;;; Generated autoloads from citeproc-s.el
+
+(register-definition-prefixes "citeproc-s" '("citeproc-s-"))
+
+\f
+;;; Generated autoloads from citeproc-sort.el
+
+(register-definition-prefixes "citeproc-sort" '("citeproc-"))
+
+\f
+;;; Generated autoloads from citeproc-style.el
+
+(register-definition-prefixes "citeproc-style" '("citeproc-"))
+
+\f
+;;; Generated autoloads from citeproc-subbibs.el
+
+(register-definition-prefixes "citeproc-subbibs" '("citeproc-sb-"))
+
+\f
+;;; Generated autoloads from citeproc-term.el
+
+(register-definition-prefixes "citeproc-term" '("citeproc-term-"))
+
+\f
+;;; Generated autoloads from citeproc-test-human.el
+
+(register-definition-prefixes "citeproc-test-human" '("citeproc-test-human-"))
+\f
+;;; End of scraped data
+
+(provide 'citeproc-autoloads)
+
+;; Local Variables:
+;; version-control: never
+;; no-byte-compile: t
+;; no-update-autoloads: t
+;; no-native-compile: t
+;; coding: utf-8-emacs-unix
+;; End:
+
+;;; citeproc-autoloads.el ends here
--- /dev/null
+;;; citeproc-biblatex.el --- convert biblatex entries to CSL -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2021 András Simonyi
+
+;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
+
+;; 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 3 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.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Convert biblatex bibliography entries to CSL.
+
+;;; Code:
+
+(require 'parse-time)
+(require 'compat)
+
+(require 'citeproc-bibtex)
+
+(defvar citeproc-blt-to-csl-types-alist
+ '((article . "article-journal")
+ (book . "book")
+ (periodical . "book")
+ (booklet . "pamphlet")
+ (bookinbook . "chapter")
+ (misc . "article")
+ (other . "article")
+ (standard . "legislation")
+ (collection . "book")
+ (conference . "paper-conference")
+ (dataset . "dataset")
+ (electronic . "webpage")
+ (inbook . "chapter")
+ (incollection . "chapter")
+ (inreference . "entry-encyclopedia")
+ (inproceedings . "paper-conference")
+ (manual . "book")
+ (mastersthesis . "thesis")
+ (mvbook . "book")
+ (mvcollection . "book")
+ (mvproceedings . "book")
+ (mvreference . "book")
+ (online . "webpage")
+ (patent . "patent")
+ (phdthesis . "thesis")
+ (proceedings . "book")
+ (reference . "book")
+ (report . "report")
+ (software . "software")
+ (suppbook . "chapter")
+ (suppcollection . "chapter")
+ (techreport . "report")
+ (thesis . "thesis")
+ (unpublished . "manuscript")
+ (www . "webpage")
+ (artwork . "graphic")
+ (audio . "song")
+ (commentary . "book")
+ (image . "figure")
+ (jurisdiction . "legal_case")
+ (legislation . "bill") ?
+ (legal . "treaty")
+ (letter . "personal_communication")
+ (movie . "motion_picture")
+ (music . "song")
+ (performance . "speech")
+ (review . "review")
+ (standard . "legislation")
+ (video . "motion_picture")
+ (data . "dataset")
+ (letters . "personal_communication")
+ (newsarticle . "article-newspaper"))
+ "Alist mapping biblatex item types to CSL item types.")
+
+(defun citeproc-blt--to-csl-type (type entrysubtype)
+ "Return the CSL type corresponding to blt TYPE and ENTRYSUBTYPE."
+ (pcase type
+ ((or 'article 'periodical 'supperiodical)
+ (pcase entrysubtype
+ ("magazine" "article-magazine")
+ ("newspaper" "article-newspaper")
+ (_ "article-journal")))
+ (_ (assoc-default type citeproc-blt-to-csl-types-alist))))
+
+(defvar citeproc-blt-reftype-to-genre
+ '(("mastersthesis" . "Master's thesis")
+ ("phdthesis" . "PhD thesis")
+ ("mathesis" . "Master's thesis")
+ ("resreport" . "research report")
+ ("techreport" . "technical report")
+ ("patreqfr" . "French patent request")
+ ("patenteu" . "European patent")
+ ("patentus" . "U.S. patent"))
+ "Alist mapping biblatex reftypes to CSL genres.")
+
+(defvar citeproc-blt-article-types
+ '(article periodical suppperiodical review)
+ "Article-like biblatex types.")
+
+(defvar citeproc-blt-chapter-types
+ '(inbook incollection inproceedings inreference bookinbook)
+ "Chapter-like biblatex types.")
+
+(defvar citeproc-blt-collection-types
+ '(book collection proceedings reference
+ mvbook mvcollection mvproceedings mvreference
+ bookinbook inbook incollection inproceedings
+ inreference suppbook suppcollection)
+ "Collection or collection part biblatex types.")
+
+(defvar citeproc-blt-to-csl-names-alist
+ '((author . author)
+ (editor . editor)
+ (bookauthor . container-author)
+ (translator . translator))
+ "Alist mapping biblatex name fields to the corresponding CSL ones.")
+
+(defvar citeproc-blt-editortype-to-csl-name-alist
+ '(("organizer" . organizer)
+ ("director" . director)
+ ("compiler" . compiler)
+ ("editor" . editor)
+ ("collaborator" . contributor))
+ "Alist mapping biblatex editortypes to CSL fields.")
+
+(defvar citeproc-blt-to-csl-dates-alist
+ '((eventdate . event-date)
+ (origdate . original-date)
+ (urldate . accessed))
+ "Alist mapping biblatex date fields to the corresponding CSL ones.")
+
+(defconst citeproc-blt--publisher-fields
+ '(school institution organization howpublished publisher)
+ "Biblatex fields containing publisher-related information.")
+
+(defconst citeproc-blt--etype-to-baseurl-alist
+ '(("arxiv" . "https://arxiv.org/abs/")
+ ("jstor" . "https://www.jstor.org/stable/")
+ ("pubmed" ."https://www.ncbi.nlm.nih.gov/pubmed/")
+ ("googlebooks" . "https://books.google.com?id="))
+ "Alist mapping biblatex date fields to the corresponding CSL ones.")
+
+(defvar citeproc-blt-to-csl-standard-alist
+ '(;; locators
+ (volume . volume)
+ (part . part)
+ (edition . edition)
+ (version . version)
+ (volumes . number-of-volumes)
+ (pagetotal . number-of-pages)
+ (chapter . chapter-number)
+ (pages . page)
+ ;; publisher
+ (origpublisher . original-publisher)
+ ;; places
+ (venue . event-place)
+ (origlocation . original-publisher-place)
+ (address . publisher-place)
+ ;; doi etcetera
+ (doi . DOI)
+ (isbn . ISBN)
+ (issn . ISSN)
+ (pmid . PMID)
+ (pmcid . PMCID)
+ (library . call-number)
+ ;; notes
+ (abstract . abstract)
+ (annotation . annote)
+ (annote . annote) ; alias for jurabib compatibility
+ ;; else
+ (pubstate . status)
+ (language . language)
+ (version . version)
+ (keywords . keyword)
+ (label . citation-label))
+ "Alist mapping biblatex standard fields to the corresponding CSL ones.
+Only those fields are mapped that do not require further processing.")
+
+(defvar citeproc-blt-to-csl-title-alist
+ '((eventtitle . event-title)
+ (origtitle . original-title)
+ (series . collection-title))
+ "Alist mapping biblatex title fields to the corresponding CSL ones.
+Only those fields are mapped that do not require further
+processing.")
+
+(defun citeproc-blt--parse-date (d)
+ "Parse single biblatex date-time expression D."
+ ;; Remove time part, if present.
+ (-when-let (time-sep-pos (cl-position ?T d))
+ (setq d (substring d 0 time-sep-pos)))
+ (--map (let ((converted (string-to-number it)))
+ (if (not (= converted 0))
+ converted
+ (error "Couldn't parse '%s' as a date" d)))
+ (split-string d "-")))
+
+(defun citeproc-blt--to-csl-date (d)
+ "Return a CSL version of the biblatex date field given by D."
+ (let* ((interval-strings (split-string d "/"))
+ (interval-date-parts
+ (mapcar #'citeproc-blt--parse-date interval-strings)))
+ (list (cons 'date-parts interval-date-parts))))
+
+(defun citeproc-blt--get-standard (v b &optional with-nocase)
+ "Return the CSL-normalized value of var V from item B.
+V is a biblatex var name as a string, B is a biblatex entry as an
+alist. If optional WITH-NOCASE is non-nil then convert BibTeX
+no-case brackets to the corresponding CSL XML spans. Return nil
+if V is undefined in B."
+ (-when-let (blt-val (alist-get v b))
+ (citeproc-bt--to-csl blt-val with-nocase)))
+
+(defun citeproc-blt--get-title (v b &optional with-nocase sent-case)
+ "Return the CSL-normalized value of a title var V from item B.
+If optional WITH-NOCASE is non-nil then convert BibTeX no-case
+brackets to the corresponding CSL XML spans, and if optional
+SENT-CASE is non-nil the convert to sentence-case. Return nil if
+V is undefined in B."
+ (-when-let (blt-val (alist-get v b))
+ (citeproc-blt--to-csl-title blt-val with-nocase sent-case)))
+
+(defun citeproc-blt--to-csl-title (s with-nocase sent-case)
+ "Return the CSL-normalized value of a title string S.
+If optional WITH-NOCASE is non-nil then convert BibTeX no-case
+brackets to the corresponding CSL XML spans, and if optional
+SENT-CASE is non-nil the convert to sentence-case."
+ (if sent-case
+ (citeproc-s-sentence-case-title (citeproc-bt--to-csl s t) (not with-nocase))
+ (citeproc-bt--to-csl s with-nocase)))
+
+(defconst citeproc-blt--titlecase-langids
+ '("american" "british" "canadian" "english" "australian" "newzealand"
+ "USenglish" "UKenglish")
+ "List of biblatex langids with title-cased title fields.")
+
+(defconst citeproc-blt--langid-to-lang-alist
+ '(("english" . "en-US")
+ ("USenglish" . "en-US")
+ ("american" . "en-US")
+ ("british" . "en-GB")
+ ("UKenglish" . "en-GB")
+ ("canadian" . "en-US")
+ ("australian" . "en-GB")
+ ("newzealand" . "en-GB")
+ ("afrikaans" . "af-ZA")
+ ("arabic" . "ar")
+ ("basque" . "eu")
+ ("bulgarian" . "bg-BG")
+ ("catalan" . "ca-AD")
+ ("croatian" . "hr-HR")
+ ("czech" . "cs-CZ")
+ ("danish" . "da-DK")
+ ("dutch" . "nl-NL")
+ ("estonian" . "et-EE")
+ ("finnish" . "fi-FI")
+ ("canadien" . "fr-CA")
+ ("acadian" . "fr-CA")
+ ("french" . "fr-FR")
+ ("francais" . "fr-FR")
+ ("austrian" . "de-AT")
+ ("naustrian" . "de-AT")
+ ("german" . "de-DE")
+ ("germanb" . "de-DE")
+ ("ngerman" . "de-DE")
+ ("greek" . "el-GR")
+ ("polutonikogreek" . "el-GR")
+ ("hebrew" . "he-IL")
+ ("hungarian" . "hu-HU")
+ ("icelandic" . "is-IS")
+ ("italian" . "it-IT")
+ ("japanese" . "ja-JP")
+ ("latvian" . "lv-LV")
+ ("lithuanian" . "lt-LT")
+ ("magyar" . "hu-HU")
+ ("mongolian" . "mn-MN")
+ ("norsk" . "nb-NO")
+ ("nynorsk" . "nn-NO")
+ ("farsi" . "fa-IR")
+ ("polish" . "pl-PL")
+ ("brazil" . "pt-BR")
+ ("brazilian" . "pt-BR")
+ ("portugues" . "pt-PT")
+ ("portuguese" . "pt-PT")
+ ("romanian" . "ro-RO")
+ ("russian" . "ru-RU")
+ ("serbian" . "sr-RS")
+ ("serbianc" . "sr-RS")
+ ("slovak" . "sk-SK")
+ ("slovene" . "sl-SL")
+ ("spanish" . "es-ES")
+ ("swedish" . "sv-SE")
+ ("thai" . "th-TH")
+ ("turkish" . "tr-TR")
+ ("ukrainian" . "uk-UA")
+ ("vietnamese" . "vi-VN")
+ ("latin" . "la"))
+ "Alist mapping biblatex langids to CSL language codes.")
+
+(defun citeproc-blt-entry-to-csl (b &optional omit-nocase no-sentcase-wo-langid)
+ "Return a CSL form of parsed biblatex entry B.
+If the optional OMIT-NOCASE is non-nil then no no-case XML
+markers are generated, and if the optional NO-SENTCASE-WO-LANGID
+is non-nil then title fields in items without a `langid' field
+are not converted to sentence-case.
+
+The processing logic follows the analogous
+function (itemToReference) in John MacFarlane's Pandoc, see
+<https://github.com/jgm/pandoc/blob/master/src/Text/Pandoc/Citeproc/BibTeX.hs>
+Many thanks to him.
+
+Note: in the code, var names starting with ~ refer to values of
+biblatex variables in B."
+ (let* ((b (cl-remove-if (lambda (x) (equal "" (cdr x))) b))
+ (b (mapcar (lambda (x) (cons (intern (downcase (car x))) (cdr x))) b))
+ (~type (intern (downcase (alist-get '=type= b))))
+ (~entrysubtype (alist-get 'entrysubtype b))
+ (type (citeproc-blt--to-csl-type ~type ~entrysubtype))
+ (is-article (memq ~type citeproc-blt-article-types))
+ (is-periodical (eq ~type 'periodical))
+ (is-chapter-like (memq ~type citeproc-blt-chapter-types))
+ (~langid (alist-get 'langid b))
+ (sent-case (or (member ~langid citeproc-blt--titlecase-langids)
+ (and (null ~langid) (not no-sentcase-wo-langid))))
+ (with-nocase (not omit-nocase))
+ result)
+ ;; language
+ (when ~langid
+ (push (cons 'language (cdr (assoc ~langid citeproc-blt--langid-to-lang-alist)))
+ result))
+ ;; set type and genre
+ (push (cons 'type type) result)
+ (when-let ((~reftype (alist-get 'type b)))
+ (push (cons 'genre (or (assoc-default ~reftype citeproc-blt-reftype-to-genre)
+ (citeproc-bt--to-csl ~reftype)))
+ result))
+ ;; We store the original bib(la)tex type for filtering purposes.
+ (push (cons 'blt-type (symbol-name ~type)) result)
+ ;; names
+ ;; TODO: handle editorb and editorc as well...
+ (when-let ((~editortype (alist-get 'editortype b))
+ (~editor (alist-get 'editor b))
+ (csl-var (assoc-default ~editortype
+ citeproc-blt-editortype-to-csl-name-alist)))
+ (push (cons csl-var (citeproc-bt--to-csl-names ~editor))
+ result))
+ (when-let ((~editoratype (alist-get 'editoratype b))
+ (~editora (alist-get 'editora b))
+ (csl-var (assoc-default ~editoratype
+ citeproc-blt-editortype-to-csl-name-alist)))
+ (push (cons csl-var (citeproc-bt--to-csl-names ~editora))
+ result))
+ ;; dates
+ (-when-let (issued (-if-let (~issued (alist-get 'date b))
+ (citeproc-blt--to-csl-date ~issued)
+ (-when-let (~year (alist-get 'year b))
+ (citeproc-bt--to-csl-date ~year
+ (alist-get 'month b)))))
+ (push (cons 'issued issued) result))
+ ;; locators
+ (-if-let (~number (alist-get 'number b))
+ (cond ((memq ~type citeproc-blt-collection-types) ; collection
+ (push `(collection-number . ,~number) result))
+ (is-article ; article
+ (push `(issue . ,(-if-let (~issue (alist-get 'issue b))
+ (concat ~number ", " ~issue)
+ ~number))
+ result))
+ (t (push `(number . ,~number) result))))
+ ;; titles
+ (let* ((~maintitle (citeproc-blt--get-title 'maintitle b with-nocase sent-case))
+ (title
+ (cond (is-periodical (citeproc-blt--get-title 'issuetitle b with-nocase sent-case))
+ ((and ~maintitle (not is-chapter-like)) ~maintitle)
+ (t (citeproc-blt--get-title 'title b with-nocase sent-case))))
+ (subtitle (citeproc-blt--get-title
+ (cond (is-periodical 'issuesubtitle)
+ ((and ~maintitle (not is-chapter-like))
+ 'mainsubtitle)
+ (t 'subtitle))
+ b with-nocase sent-case))
+ (title-addon
+ (citeproc-blt--get-title
+ (if (and ~maintitle (not is-chapter-like))
+ 'maintitleaddon 'titleaddon)
+ b with-nocase sent-case))
+ (volume-title
+ (when ~maintitle
+ (citeproc-blt--get-title
+ (if is-chapter-like 'booktitle 'title) b with-nocase sent-case)))
+ (volume-subtitle
+ (when ~maintitle
+ (citeproc-blt--get-title
+ (if is-chapter-like 'booksubtitle 'subtitle) b with-nocase sent-case)))
+ (volume-title-addon
+ (when ~maintitle
+ (citeproc-blt--get-title
+ (if is-chapter-like 'booktitleaddon 'titleaddon) b with-nocase sent-case)))
+ (container-title
+ (or (and is-periodical (citeproc-blt--get-title 'title b with-nocase sent-case))
+ (and is-chapter-like ~maintitle)
+ (and is-chapter-like (citeproc-blt--get-title
+ 'booktitle b with-nocase sent-case))
+ (or (citeproc-blt--get-title 'journaltitle b with-nocase sent-case)
+ ;; also accept `journal' for BibTeX compatibility
+ (citeproc-blt--get-title 'journal b with-nocase sent-case))))
+ (container-subtitle
+ (or (and is-periodical (citeproc-blt--get-title
+ 'subtitle b with-nocase sent-case))
+ (and is-chapter-like (citeproc-blt--get-title
+ 'mainsubtitle b with-nocase sent-case))
+ (and is-chapter-like (citeproc-blt--get-title
+ 'booksubtitle b with-nocase sent-case))
+ (citeproc-blt--get-title 'journalsubtitle b with-nocase sent-case)))
+ (container-title-addon
+ (or (and is-periodical (citeproc-blt--get-title
+ 'titleaddon b with-nocase sent-case))
+ (and is-chapter-like (citeproc-blt--get-title
+ 'maintitleaddon b with-nocase sent-case))
+ (and is-chapter-like
+ (citeproc-blt--get-title 'booktitleaddon b with-nocase sent-case))))
+ (container-title-short
+ (or (and is-periodical (not ~maintitle)
+ (citeproc-blt--get-title 'titleaddon b with-nocase sent-case))
+ (citeproc-blt--get-title 'shortjournal b with-nocase sent-case)))
+ (title-short
+ (or (and (or (not ~maintitle) is-chapter-like)
+ (citeproc-blt--get-title 'shorttitle b with-nocase sent-case))
+ (and (or subtitle title-addon)
+ (not ~maintitle)
+ title))))
+ (when title
+ (push (cons 'title
+ (concat title
+ (when subtitle (concat ": " subtitle))
+ (when title-addon (concat ". " title-addon))))
+ result))
+ (when title-short
+ (push (cons 'title-short title-short) result))
+ (when volume-title
+ (push (cons 'volume-title
+ (concat volume-title
+ (when volume-subtitle (concat ": " volume-subtitle))
+ (when volume-title-addon (concat ". " volume-title-addon))))
+ result))
+ (when container-title
+ (push (cons 'container-title
+ (concat container-title
+ (when container-subtitle (concat ": " container-subtitle))
+ (when container-title-addon (concat ". " container-title-addon))))
+ result))
+ (when container-title-short
+ (push (cons 'container-title-short container-title-short) result)))
+ ;; publisher
+ (-when-let (values (-non-nil (--map (citeproc-blt--get-standard it b)
+ citeproc-blt--publisher-fields)))
+ (push `(publisher . ,(mapconcat #'identity values "; ")) result))
+ ;; places
+ (let ((csl-place-var
+ (if (eq ~type 'patent) 'jurisdiction 'publisher-place)))
+ (-when-let (~location (or (citeproc-blt--get-standard 'location b)
+ (citeproc-blt--get-standard 'address b)))
+ (push (cons csl-place-var ~location) result)))
+ ;; url
+ (-when-let (url (or (let ((u (alist-get 'url b))) (and u (string-replace "\\" "" u)))
+ (when-let ((~eprinttype (or (alist-get 'eprinttype b)
+ (alist-get 'archiveprefix b)))
+ (~eprint (alist-get 'eprint b))
+ (base-url
+ (assoc-default ~eprinttype
+ citeproc-blt--etype-to-baseurl-alist)))
+ (concat base-url ~eprint))))
+ (push (cons 'URL url) result))
+ ;; notes
+ (-when-let (note (let ((~note (citeproc-blt--get-standard 'note b))
+ (~addendum (citeproc-blt--get-standard 'addendum b)))
+ (cond ((and ~note ~addendum) (concat ~note ". " ~addendum))
+ (~note ~note)
+ (~addendum ~addendum)
+ (t nil))))
+ (push (cons 'note note) result))
+ ;; rest
+ (let (rest)
+ (pcase-dolist (`(,blt-key . ,blt-value) b)
+ ;; remaining standard vars
+ (-when-let (csl-key
+ (alist-get blt-key citeproc-blt-to-csl-standard-alist))
+ (unless (alist-get csl-key result)
+ (push (cons csl-key (citeproc-bt--to-csl blt-value)) rest)))
+ ;; remaining name vars
+ (-when-let (csl-key
+ (alist-get blt-key citeproc-blt-to-csl-names-alist))
+ (unless (alist-get csl-key result)
+ (push (cons csl-key (citeproc-bt--to-csl-names blt-value)) rest)))
+ ;; remaining date vars
+ (-when-let (csl-key
+ (alist-get blt-key citeproc-blt-to-csl-dates-alist))
+ (unless (alist-get csl-key result)
+ (push (cons csl-key (citeproc-blt--to-csl-date blt-value)) rest)))
+ ;; remaining title vars
+ (-when-let (csl-key
+ (alist-get blt-key citeproc-blt-to-csl-title-alist))
+ (push (cons csl-key
+ (citeproc-blt--to-csl-title blt-value with-nocase sent-case))
+ rest)))
+ (append result rest))))
+
+(provide 'citeproc-biblatex)
+
+;;; citeproc-biblatex.el ends here
--- /dev/null
+;;; citeproc-bibtex.el --- convert BibTeX entries to CSL -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017-2021 András Simonyi
+
+;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
+
+;; 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 3 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.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Convert BibTeX bibliography entries to CSL.
+
+;;; Code:
+
+(require 'dash)
+(require 'subr-x)
+(require 'bibtex)
+(require 'cl-lib)
+(require 's)
+(require 'org)
+(require 'map)
+(require 'compat)
+;; Handle the fact that org-bibtex has been renamed to ol-bibtex -- for the time
+;; being we support both feature names.
+(or (require 'ol-bibtex nil t)
+ (require 'org-bibtex))
+
+(require 'citeproc-s)
+
+;; Declare used ol-bibtex variables and functions to silence 'reference to free
+;; variable' and 'function is not known to be defined' warnings during
+;; compilation.
+(defvar org-bibtex-key-property)
+(defvar org-bibtex-type-property-name)
+(defvar org-bibtex-export-arbitrary-fields)
+(defvar org-bibtex-prefix)
+(defvar org-bibtex-types)
+(declare-function org-bibtex-get "ext:ol-bibtex")
+
+(defconst citeproc-bt--to-csl-types-alist
+ '(("article" . "article-journal") ("book" . "book") ("proceedings" . "book")
+ ("manual" . "book") ("periodical" . "book") ("booklet" . "pamphlet")
+ ("inbook" . "chapter") ("incollection" . "chapter") ("inproceedings" . "paper-conference")
+ ("conference" . "paper-conference") ("mastersthesis" . "thesis") ("phdthesis" . "thesis")
+ ("techreport" . "report") ("patent" . "patent") ("electronic" . "webpage")
+ ("misc" . "article") ("other" . "article") ("standard" . "legislation")
+ ("unpublished" . "manuscript") ("online" . "article-journal"))
+ "Alist mapping BibTeX item types to CSL item types.")
+
+(defconst citeproc-bt--to-csl-keys-alist
+ '(("=key=" . citation-label) ("address" . publisher-place)
+ ("booktitle" . container-title) ("journal" . container-title)
+ ("chapter" . title) ("location" . event-place) ("series" . collection-title)
+ ("keywords" . keyword) ("institution" . publisher) ("school" . publisher)
+ ("pages" . page) ("organization" . publisher) ("url" . URL)
+ ("doi" . DOI) ("pmid" . PMID) ("pmcid" . PMCID))
+ "Alist mapping BibTeX keys to CSL keys with different names.")
+
+(defconst citeproc-bt--mon-to-num-alist
+ '(("jan" . 1) ("feb" . 2) ("mar" . 3) ("apr" . 4) ("may" . 5) ("jun" . 6)
+ ("jul" . 7) ("aug" . 8) ("sep" . 9) ("oct" . 10) ("nov" . 11) ("dec" . 12))
+ "Alist mapping LaTeX abbreviated month names to ordinals.")
+
+(defconst citeproc-bt--pref-to-ucs-alist
+ '(("'" . "ACUTE") ("`" . "GRAVE") ("^" . "CIRCUMFLEX") ("~" . "TILDE")
+ ("=" . "MACRON") ("." . "WITH DOT ABOVE") ("\"" . "DIAERESIS")
+ ("''" . "DIAERESIS") ("H" . "DOUBLE ACUTE") ("r" . "WITH RING ABOVE")
+ ("u" . "BREVE") ("c" . "CEDILLA") ("k" . "OGONEK") ("v" . "CARON"))
+ "Alist mapping LaTeX prefixes to unicode name endings.")
+
+(defconst citeproc-bt--comm-letter-to-ucs-alist
+ '((("`" . "A") . "À")
+ (("'" . "A") . "Á")
+ (("^" . "A") . "Â")
+ (("~" . "A") . "Ã")
+ (("\"" . "A") . "Ä")
+ (("r" . "A") . "Å")
+ (("c" . "C") . "Ç")
+ (("v" . "C") . "Č")
+ (("'" . "C") . "Ć")
+ (("`" . "E") . "È")
+ (("'" . "E") . "É")
+ (("^" . "E") . "Ê")
+ (("\"" . "E") . "Ë")
+ (("`" . "I") . "Ì")
+ (("'" . "I") . "Í")
+ (("^" . "I") . "Î")
+ (("\"" . "I") . "Ï")
+ (("~" . "N") . "Ñ")
+ (("`" . "O") . "Ò")
+ (("'" . "O") . "Ó")
+ (("^" . "O") . "Ô")
+ (("~" . "O") . "Õ")
+ (("\"" . "O") . "Ö")
+ (("c" . "S") . "Ş")
+ (("v" . "S") . "Š")
+ (("`" . "U") . "Ù")
+ (("'" . "U") . "Ú")
+ (("^" . "U") . "Û")
+ (("\"" . "U") . "Ü")
+ (("'" . "Y") . "Ý")
+ (("`" . "a") . "à")
+ (("'" . "a") . "á")
+ (("^" . "a") . "â")
+ (("~" . "a") . "ã")
+ (("\"" . "a") . "ä")
+ (("r" . "a") . "å")
+ (("c" . "c") . "ç")
+ (("v" . "c") . "č")
+ (("'" . "c") . "ć")
+ (("`" . "e") . "è")
+ (("'" . "e") . "é")
+ (("^" . "e") . "ê")
+ (("\"" . "e") . "ë")
+ (("`" . "i") . "ì")
+ (("'" . "i") . "í")
+ (("^" . "i") . "î")
+ (("\"" . "i") . "ï")
+ (("~" . "n") . "ñ")
+ (("`" . "o") . "ò")
+ (("'" . "o") . "ó")
+ (("^" . "o") . "ô")
+ (("~" . "o") . "õ")
+ (("\"" . "o") . "ö")
+ (("v" . "r") . "ř")
+ (("c" . "s") . "ş")
+ (("v" . "s") . "š")
+ (("`" . "u") . "ù")
+ (("'" . "u") . "ú")
+ (("^" . "u") . "û")
+ (("\"" . "u") . "ü")
+ (("'" . "y") . "ý")
+ (("\"" . "y") . "ÿ")
+ (("H" . "o") . "ő")
+ (("H" . "O") . "Ő")
+ (("H" . "u") . "ű")
+ (("H" . "U") . "Ű")
+ (("v" . "z") . "ž")
+ (("v" . "Z") . "Ž"))
+ "Alist mapping LaTeX (SYMBOL-COMMAND . ASCII-CHAR) pairs to unicode characters.")
+
+(defconst citeproc-bt--to-ucs-alist
+ '(("l" . "ł") ("L" . "Ł") ("o" . "ø") ("O" . "Ø") ("AA" . "Å") ("aa" . "å")
+ ("AE" . "Æ") ("ae" . "æ") ("ss" . "ß") ("i" . "ı"))
+ "Alist mapping LaTeX commands to characters.")
+
+(defun citeproc-bt--to-ucs (ltx char)
+ "Return the unicode version of LaTeX command LTX applied to CHAR.
+LTX is a one-char LaTeX accenting command (e.g. \"'\"), CHAR is
+an ascii character. Return nil if no corresponding unicode
+character was found."
+ (or (assoc-default (cons ltx char) citeproc-bt--comm-letter-to-ucs-alist)
+ ;; If the combination is not in citeproc-bt--comm-letter-to-ucs-alist
+ ;; then, as a last resort, we try to assemble the canonical unicode name
+ ;; of the requested character and look it up in (usc-names). This process
+ ;; can be *very slow* on older Emacs versions in which (usc-names) returns
+ ;; an alist!
+
+ ;; NOTE: Because of a nasty interaction bug between `ucs-names' and
+ ;; `replace-regexp-in-string' we do the lookup only for Emacs versions
+ ;; earlier than 28.
+ (when-let* (((version< emacs-version "28" ))
+ (case-name (if (s-lowercase-p char) "SMALL" "CAPITAL"))
+ (combining-name (assoc-default ltx citeproc-bt--pref-to-ucs-alist))
+ (name (concat "LATIN " case-name " LETTER "
+ (upcase char) " " combining-name))
+ (char-name (map-elt (ucs-names) name)))
+ (char-to-string char-name))))
+
+(defconst citeproc-bt--decode-rx
+ (rx (or
+ (seq "{\\" (group-n 1 (in "'" "`" "^" "~" "=" "." "\"")) (0+ space)
+ (group-n 2 letter) "}")
+ (seq "{\\" (group-n 1 (in "H" "r" "u" "c" "k" "v")) (1+ space)
+ (group-n 2 letter) "}")
+ (seq "{\\" (group-n 1 (or "l" "L" "o" "O" "AA" "aa" "ae" "AE" "ss" "i"))
+ (0+ space) "}")
+ (seq "\\" (group-n 1 (in "'" "`" "^" "~" "=" "." "\"" "H" "r" "u" "c" "k" "v"))
+ (0+ space) "{" (group-n 2 letter) "}")
+ (seq "\\" (group-n 1 (in "H" "r" "u" "c" "k" "v")) (1+ space)
+ (group-n 2 letter))
+ (seq "\\" (group-n 1 (in "'" "`" "^" "~" "=" "." "\"")) (0+ space)
+ (group-n 2 letter))
+ (seq "\\" (group-n 1 (or "l" "L" "o" "O" "AA" "aa" "ae" "AE" "ss" "i"))
+ word-boundary)))
+ "Regular expression matching BibTeX special character commands.")
+
+(defun citeproc-bt--decode (s)
+ "Decode a BibTeX encoded string."
+ (replace-regexp-in-string
+ citeproc-bt--decode-rx
+ (lambda (x)
+ (let ((command (match-string 1 x))
+ (letter (match-string 2 x)))
+ (if letter
+ (or (citeproc-bt--to-ucs command letter) (concat "\\" x))
+ (or (assoc-default command citeproc-bt--to-ucs-alist) x))))
+ s t t))
+
+(defun citeproc-bt--decode-buffer ()
+ "Decode BibTeX encoded characters in the current buffer."
+ (goto-char (point-min))
+ (while (re-search-forward citeproc-bt--decode-rx nil t)
+ (replace-match
+ (let ((replacement (let ((command (match-string 1))
+ (letter (match-string 2)))
+ (if letter
+ (or (citeproc-bt--to-ucs command letter) (concat "\\" (match-string 0)))
+ (assoc-default command citeproc-bt--to-ucs-alist)))))
+ replacement))))
+
+(defconst citeproc-bt--command-rx
+ (rx "\\" (1+ (any "a-z" "A-Z")) "{" ; \TEX-COMMAND{
+ (group (*? anything)) ; ARGUMENT
+ "}" ; }
+ ))
+
+(defconst citeproc-bt--command-wo-arg-rx
+ (rx "\\" (1+ (any "a-z" "A-Z")) word-end)) ; \TEX-COMMAND + word-end
+
+(defconst citeproc-bt--braces-rx
+ (rx (group (or string-start (not "\\"))) "{" ; unescaped {
+ (group (optional (seq (*? anything) (not "\\")))) ; TEXT
+ "}")) ; unescaped }
+
+(defun citeproc-bt--process-brackets (s &optional lhb rhb)
+ "Process LaTeX curly brackets in string S.
+Optional LHB and RHB specify what to substitute for left and
+right braces when they are not enclosing command arguments.
+The default is to remove them."
+ (let* ((result s)
+ (match t))
+ (while match
+ (cond ((string-match citeproc-bt--command-rx result)
+ (setq result (replace-match "\\1" t nil result)
+ match t))
+ ((string-match citeproc-bt--command-wo-arg-rx result)
+ (setq result (replace-match "" t nil result)
+ match t))
+ ((string-match citeproc-bt--braces-rx result)
+ (setq result (replace-match
+ (concat "\\1" lhb "\\2" rhb)
+ t nil result)
+ match t))
+ (t (setq match nil))))
+ (s-replace-all '(("\\{" . "{") ("\\}" . "}")) result)))
+
+(defun citeproc-bt--preprocess-for-decode (s)
+ "Preprocess field S before decoding.
+Remove flanking dumb quotes from string S and make some
+replacements."
+ (let ((wo-quotes (if (and (string= (substring s 0 1) "\"")
+ (string= (substring s -1) "\""))
+ (substring s 1 -1) s)))
+ (string-replace "\\&" "&" wo-quotes)))
+
+(defun citeproc-bt--to-csl (s &optional with-nocase)
+ "Convert a BibTeX field S to a CSL one.
+If optional WITH-NOCASE is non-nil then convert BibTeX no-case
+brackets to the corresponding CSL XML spans."
+ (if (> (length s) 0)
+ (--> s
+ (citeproc-bt--preprocess-for-decode it)
+ (citeproc-bt--decode it)
+ (citeproc-bt--process-brackets
+ it
+ (when with-nocase "<span class=\"nocase\">")
+ (when with-nocase "</span>"))
+ (citeproc-s-replace-all-seq it '(("\n" . " ") ("~" . " ") ("--" . "–")))
+ (s-trim it))
+ s))
+
+(defun citeproc-bt--to-csl-names (n)
+ "Return a CSL version of BibTeX names field N."
+ (let ((name-fields (s-split "\\band\\b" n)))
+ (mapcar
+ (lambda (x)
+ (let ((trimmed (s-trim x)))
+ (cond
+ ((string= trimmed "") '((family . "")))
+ ;; Presence of equal sign signals extended specification.
+ ((string-match "=" trimmed) (citeproc-bt--ext-desc-to-csl-name trimmed))
+ ;; Brackets indicate corporate entities without name parts.
+ ((and (string= "{" (substring trimmed 0 1))
+ (string= "}" (substring trimmed -1)))
+ `((literal . ,(citeproc-bt--to-csl (substring trimmed 1 -1)))))
+ ;; Else standard bib(la)tex name field processing.
+ (t (citeproc-bt--to-csl-name (citeproc-bt--to-csl trimmed))))))
+ name-fields)))
+
+(defvar citeproc-bt-dropping-particles
+ '("dela" "il" "sen" "z" "ze")
+ "List containing dropping particles. Particles whose first word
+is not on this list are classified as non-dropping.")
+
+(defun citeproc-bt--parse-family (f)
+ "Parse family name tokens F into a csl name-part alist."
+ (let (family result particle)
+ (-if-let (firsts (butlast f))
+ (progn
+ (while (and firsts (s-lowercase-p (car firsts)))
+ (push (pop firsts) particle))
+ (when particle
+ (push (cons (if (member (car particle) citeproc-bt-dropping-particles)
+ 'dropping-particle
+ 'non-dropping-particle)
+ (nreverse particle))
+ result))
+ (setq family (-concat firsts (last f))))
+ (setq family f))
+ (push `(family . ,family) result)
+ result))
+
+(defun citeproc-bt--parse-attr-val-field (f)
+ "Parse biblatex key-val field F into an alist."
+ (let* ((bracketless (replace-regexp-in-string "[{}]" "" f))
+ (equal-split (split-string bracketless "=" t " "))
+ (first-attr (intern (string-trim (pop equal-split) "[ \"]+" "[ \"]+")))
+ (reversed (nreverse equal-split))
+ (result (list (string-trim (pop reversed) "[ \"]+" "[ \"]+"))))
+ (dolist (elt reversed)
+ (let ((pos (- (length elt) 2))
+ found)
+ (while (and (< 0 pos) (null found))
+ (if (= (aref elt pos) ?,)
+ (setq found t)
+ (cl-decf pos)))
+ (unless found (error "Could not parse biblatex key-value list \"%s\"" f))
+ (let ((key (intern (s-trim (substring elt (1+ pos)))))
+ (val (string-trim (substring elt 0 pos) "[ \"]+" "[ \"]+")))
+ (push key (car result))
+ (push val result))))
+ (push first-attr (car result))
+ result))
+
+(defun citeproc-bt--ext-desc-to-csl-name (name)
+ "Return a CSL version of extended biblatex description NAME."
+ (let* ((parsed (citeproc-bt--parse-attr-val-field name))
+ (dropping (string= (alist-get 'useprefix parsed) "false")))
+ (--keep (pcase (car it)
+ ((or 'family 'given 'suffix) it)
+ ('prefix (cons (if dropping 'dropping-particle 'non-dropping-particle)
+ (cdr it)))
+ (_ nil))
+ parsed)))
+
+(defun citeproc-bt--to-csl-name (name)
+ "Return a CSL version of BibTeX name string NAME."
+ (let* (result
+ family
+ (tokens (-remove #'s-blank-str-p
+ (citeproc-s-slice-by-matches name "\\(,\\|[[:space:]]+\\)")))
+ (parts (-split-on "," tokens)))
+ (pcase (length parts)
+ ;; No commas in the name
+ (1 (let ((name (car parts)))
+ (-if-let (1st-downcased-idx (-find-index #'s-lowercase-p name))
+ (progn (setq family (-slice name 1st-downcased-idx))
+ (when (> 1st-downcased-idx 0)
+ (push `(given . ,(-slice name 0 1st-downcased-idx)) result)))
+ (setq family (last name))
+ (when (> (length name) 1)
+ (push `(given . ,(-slice name 0 -1)) result)))))
+ ;; A single comma separates family and last name
+ (2 (setq family (car parts))
+ (push `(given . ,(cadr parts)) result))
+ ;; More than one commas
+ (_ (setq family (car parts))
+ (push `(suffix . ,(cadr parts)) result)
+ (push `(given . ,(cl-caddr parts)) result)))
+ (setq result (nconc (citeproc-bt--parse-family family) result))
+ (--map (cons (car it) (s-join " " (cdr it)))
+ result)))
+
+(defun citeproc-bt--to-csl-date (year month)
+ "Return a CSL version of the date given by YEAR and MONTH.
+YEAR and MONTH are the values of the corresponding BibTeX fields,
+MONTH might be nil."
+ (condition-case nil
+ (let ((csl-year (string-to-number (car (s-match "[[:digit:]]+" year))))
+ (csl-month (when month
+ (assoc-default (downcase month)
+ citeproc-bt--mon-to-num-alist)))
+ date)
+ (when csl-year
+ (when csl-month (push csl-month date))
+ (push csl-year date))
+ (list (cons 'date-parts (list date))))
+ (error
+ (error (concat "Couldn't parse year: '%s'"
+ (when month " and month: '%s'")
+ " as a date")
+ year month))))
+
+(defun citeproc-bt-entry-to-csl (b)
+ "Return a CSL form of normalized parsed BibTeX entry B."
+ (let ((type (assoc-default (downcase (assoc-default "=type=" b))
+ citeproc-bt--to-csl-types-alist))
+ result year month)
+ (cl-loop for (key . value) in b do
+ (let ((key (downcase key))
+ (value (citeproc-bt--to-csl value)))
+ (-if-let (csl-key (assoc-default key citeproc-bt--to-csl-keys-alist))
+ ;; Vars mapped simply to a differently named CSL var
+ (push (cons csl-key value) result)
+ (pcase key
+ ((or "author" "editor") ; Name vars
+ (push (cons (intern key) (citeproc-bt--to-csl-names value))
+ result))
+ ("=type=" (push (cons 'type type) result))
+ ("number" (push (cons (if (string= type "article-journal") 'issue
+ 'number)
+ value)
+ result))
+ ;; Date vars that need further processing below
+ ("year" (setq year value))
+ ("month" (setq month value))
+ ;; Remaining keys are mapped without change
+ (_ (push (cons (intern key) value) result))))))
+ (when year
+ (push (cons 'issued (citeproc-bt--to-csl-date year month))
+ result))
+ result))
+
+;; This function is based on the function `org-bibtex-headline' in org-bibtex,
+;; written by Bastien Guerry <bzgNOSPAMgnu.org>, Carsten Dominik <carsten dot dominik
+;; at gmail dot com> and Eric Schulte <schulte dot eric at gmail dot com>.
+;; Copyright (C) 2007-2017 Free Software Foundation, Inc.
+(defun citeproc-bt-from-org-headline (&optional itemids)
+ "Return a (KEY . BIBTEX-ENTRY) pair from the headline at point.
+The returned BibTeX entry has the same form as produced by
+`bibtex-parse-entry'. Return nil if the headline has no
+associated bibtex data. If optional ITEMIDS is given then also
+return nil if the entry's key is not in ITEMIDS."
+ (letrec ((val (lambda (key lst) (cdr (assoc key lst))))
+ (to (lambda (string) (intern (concat ":" string))))
+ (from (lambda (key) (substring (symbol-name key) 1)))
+ (flatten (lambda (&rest lsts)
+ (apply #'append (mapcar
+ (lambda (e)
+ (if (listp e) (apply flatten e) (list e)))
+ lsts))))
+ (id (org-bibtex-get org-bibtex-key-property))
+ (type (org-bibtex-get org-bibtex-type-property-name)))
+ (when (and type (or (null itemids) (member id itemids)))
+ `(,id .
+ (("=type=" . ,type)
+ ,@(remove
+ nil
+ (if (and org-bibtex-export-arbitrary-fields
+ org-bibtex-prefix)
+ (mapcar
+ (lambda (kv)
+ (let ((key (car kv)) (val0 (cdr kv)))
+ (when (and
+ (string-match org-bibtex-prefix key)
+ (not (string=
+ (downcase (concat org-bibtex-prefix
+ org-bibtex-type-property-name))
+ (downcase key))))
+ (cons (downcase (replace-regexp-in-string
+ org-bibtex-prefix "" key))
+ val0))))
+ (org-entry-properties nil 'standard))
+ (mapcar
+ (lambda (field)
+ (let ((value (or (org-bibtex-get (funcall from field))
+ (and (eq :title field)
+ (nth 4 (org-heading-components))))))
+ (when value (cons (funcall from field) value))))
+ (funcall flatten
+ (funcall val :required (funcall val (funcall to type) org-bibtex-types))
+ (funcall val :optional (funcall val (funcall to type) org-bibtex-types)))))))))))
+
+(provide 'citeproc-bibtex)
+
+;;; citeproc-bibtex.el ends here
--- /dev/null
+;; citeproc-choose.el --- conditionally rendered CSL elements -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017 András Simonyi
+
+;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
+
+;; 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 3 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.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; CSL supports conditional rendering via the cs:choose rendering element, which
+;; can contain cs:if, cs:else-if and cs:else elements as children. This file
+;; contains functions corresponding to all these elements with some auxiliary
+;; functions.
+
+;; In order to support conditional rendering by cs:choose, the functions
+;; corresponding to cs:if, cs:else-if and cs:else (`citeproc--if',
+;; `citeproc--else-if', `citeproc--else') return the generalized boolean value
+;; of their condition in addition to their rendered content in the form of a
+;; (BOOLEAN . CONTENT) pair.
+
+;;; Code:
+
+(require 's)
+
+(require 'citeproc-lib)
+(require 'citeproc-context)
+(require 'citeproc-date)
+
+(defun citeproc-choose-eval-conditions (attrs context)
+ "Eval (possibly complex) boolean conditions in ATTRS."
+ (-let* ((conditions (citeproc-choose--elementary-conditions
+ (--remove (eq (car it) 'match) attrs)))
+ (match (or (alist-get 'match attrs) "all"))
+ (values (--map (citeproc-choose--eval-elementary-condition (car it)
+ (intern (cdr it))
+ context)
+ conditions)))
+ (pcase match
+ ("all" (--all? it values))
+ ("any" (--any? it values))
+ ("none" (--none? it values)))))
+
+(defun citeproc-choose--elementary-conditions (attrs)
+ "Expand complex conditions in ATTRS into elementary ones.
+Return a list of elementary (CONDITION-TYPE . PARAM) pairs."
+ (cl-mapcan (lambda (x)
+ (--map (cons (car x) it)
+ (s-split " " (cdr x))))
+ attrs))
+
+(defun citeproc-choose--eval-elementary-condition (type param context)
+ "Evaluate an elementary choose condition of TYPE with PARAM.
+TYPE is one of the symbols `variable', `type', `locator',
+`is-numeric', `is-uncertain-date', `position' and `disambiguate'.
+Return the result of evaluation, which is a generalized boolean."
+ (pcase type
+ ('variable (citeproc-var-value param context))
+ ('type (string= param (citeproc-var-value 'type context)))
+ ('locator (string= param (citeproc-var-value 'label context)))
+ ('is-numeric (let ((val (citeproc-var-value param context)))
+ (citeproc-lib-numeric-p val)))
+ ;; We return t iff the first date is uncertain. A more complicated alternative
+ ;; would be to test the second date of date ranges as well.
+ ('is-uncertain-date (-when-let (dates (citeproc-var-value param context))
+ (citeproc-date-circa (car dates))))
+ ('position (and (eq (citeproc-context-mode context) 'cite)
+ (or (and (eq param 'near-note) (citeproc-var-value 'near-note context))
+ (let ((pos (citeproc-var-value 'position context)))
+ (or (eq param pos)
+ (and (eq param 'subsequent)
+ (or (eq pos 'ibid) (eq pos 'ibid-with-locator)))
+ (and (eq param 'ibid)
+ (eq pos 'ibid-with-locator)))))))
+ ('disambiguate (citeproc-var-value 'disambiguate context))))
+
+(defmacro citeproc--choose (_attrs _context &rest body)
+ "Return the content of the first element in BODY with t boolean value.
+Return the empty (nil . `text-only') content if there is no such
+element."
+ `(let ((first-true
+ (--first (car it) (list ,@body))))
+ (if first-true
+ (cdr first-true)
+ (cons nil (quote text-only)))))
+
+(defmacro citeproc--if (attrs context &rest body)
+ "If conditions in ATTRS eval to t return t with rendered BODY.
+Return nil otherwise."
+ `(if (citeproc-choose-eval-conditions ,attrs ,context)
+ (cons t (citeproc-lib-add-splice-tag
+ (citeproc-lib-splice-into (list ,@body) 'splice)
+ 'splice))
+ nil))
+
+(defalias 'citeproc--else-if 'citeproc--if)
+
+(defun citeproc--else (_attrs _context &rest body)
+ "Always return t boolean plus rendered BODY"
+ (let ((spliced-body (citeproc-lib-splice-into body 'splice)))
+ (cons t (citeproc-lib-add-splice-tag spliced-body 'splice))))
+
+(provide 'citeproc-choose)
+
+;;; citeproc-choose.el ends here
--- /dev/null
+;;; citeproc-cite.el --- cite and citation rendering -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017-2024 András Simonyi
+
+;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
+
+;; 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 3 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.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Functionality to render citations and the cites they contain. (Terminology
+;; from the CSL standard: "citations consist of one or more cites to individual
+;; items".)
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'dash)
+(require 'queue)
+(require 's)
+
+(require 'citeproc-rt)
+(require 'citeproc-number)
+(require 'citeproc-itemdata)
+(require 'citeproc-style)
+(require 'citeproc-proc)
+(require 'citeproc-formatters)
+(require 'citeproc-sort)
+(require 'citeproc-subbibs)
+(require 'citeproc-date)
+(require 'citeproc-biblatex)
+
+
+(declare-function citeproc-style-category "citeproc-style" (style))
+
+(cl-defstruct (citeproc-citation (:constructor citeproc-citation-create))
+ "A struct representing a citation.
+CITES is a list of alists describing individual cites,
+NOTE-INDEX is the note index of the citation if it occurs in a
+ note,
+MODE is either nil (for the default citation mode) or one
+ of the symbols `suppress-author', `textual', `author-only',
+ `year-only', `title-only', `bib-entry', `locator-only',
+SUPPRESS-AFFIXES is non-nil if the citation affixes should be
+ suppressed,
+CAPITALIZE-FIRST is non-nil if the first word of the rendered
+ citation should be capitalized,
+IGNORE-ET-AL is non-nil if et-al settings should be ignored for
+ the first cite.
+GROUPED is used internally to indicate whether the cites were
+ grouped by the csl processor."
+ cites note-index mode suppress-affixes capitalize-first
+ ignore-et-al grouped)
+
+(defconst citeproc-cite--from-mode-alist
+ '((textual . ((suppress-author . t)))
+ (suppress-author . ((suppress-author . t)))
+ (author-only . ((stop-rendering-at . names)))
+ (year-only . ((stop-rendering-at . issued)))
+ (title-only . ((stop-rendering-at . title) (bib-entry . t) (use-short-title . t)))
+ (bib-entry . ((bib-entry . t)))
+ (locator-only . ((locator-only . t))))
+ "Alist mapping citation modes to corresponding cite-level
+key-value pair representations.")
+
+(defvar citeproc-citation-postprocess-functions nil
+ "A list of functions to postprocess rendered citations.
+Each function takes a single argument, a rich-text, and returns a
+post-processed rich-text value. The functions are applied in the
+order they appear in the list.")
+
+(defun citeproc-cite--parse-locator-extra (s)
+ "Parse extra locator text S into locator-date and locator-extra.
+Return a pair (LOCATOR-DATE . LOCATOR-EXTRA) where
+- LOCATOR-DATE is a `citeproc-date' struct or nil, and
+- LOCATOR-EXTRA is a string or nil."
+ (let (locator-date locator-extra)
+ (if (not (string-match-p "^[0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}" s))
+ (setq locator-extra (and (not (s-blank-str-p s)) s))
+ (setq locator-date (citeproc-date-parse (citeproc-blt--to-csl-date
+ (substring s 0 10))))
+ (let ((extra (substring s 10)))
+ (unless (s-blank-str-p extra) (setq locator-extra extra))))
+ (cons locator-date locator-extra)))
+
+(defun citeproc-cite--internalize-locator (cite)
+ "Internalize a CITE struct's locator by parsing it into fields.
+If the \"|\" separator is present in the locator then parse it
+into `locator', `locator-extra' and `locator-date', and update
+CITE with these fields accordingly. Returns the possibly modified
+CITE."
+ (when-let ((locator (alist-get 'locator cite))
+ (separator-pos (cl-position ?| locator)))
+ (setf (alist-get 'locator cite) (substring locator 0 separator-pos))
+ (pcase-let ((`(,locator-date . ,locator-extra) (citeproc-cite--parse-locator-extra
+ (substring locator (1+ separator-pos)))))
+ (when locator-date (push (cons 'locator-date locator-date) cite))
+ (when locator-extra (push (cons 'locator-extra locator-extra) cite))))
+ cite)
+
+(defun citeproc-cite--varlist (cite)
+ "Return the varlist belonging to CITE."
+ (let* ((itd (alist-get 'itd cite))
+ (item-vv (citeproc-itemdata-varvals itd))
+ ;; OPTIMIZE: Should we do this filtering?
+ (cite-vv
+ (--filter (memq (car it)
+ '(label locator suppress-author suppress-date
+ stop-rendering-at position near-note
+ first-reference-note-number ignore-et-al
+ bib-entry locator-only use-short-title
+ locator-extra locator-date))
+ cite)))
+ (nconc cite-vv item-vv)))
+
+(defun citeproc-cite--render (cite style &optional internal-links)
+ "Render CITE in STYLE, together with its affixes.
+If the prefix or suffix in CITE don't contain trailing and
+leading spaces then they are added. If the optional
+INTERNAL-LINKS is `bib-links' then link cites to the bibliography
+regardless of the style type, if `no-links' then don't add
+internal links, if nil or `auto' then add internal links based on
+the style type (cite-cite links for note styles and cite-bib
+links else). For legacy reasons, any other value is treated as
+`no-links'."
+ (-let* ((result nil)
+ ((&alist 'suffix suff
+ 'prefix pref
+ 'bib-entry bib-entry
+ 'locator-only locator-only
+ 'stop-rendering-at stop-rendering-at)
+ cite)
+ (rt-pref (citeproc-rt-from-str pref))
+ (plain-pref (citeproc-rt-to-plain rt-pref))
+ (rt-suff (citeproc-rt-from-str suff))
+ (plain-suff (citeproc-rt-to-plain rt-suff))
+ (mode (if bib-entry 'bib 'cite))
+ (varlist (citeproc-cite--varlist cite)))
+ ;; Remove cite-number when cite is the full bibliography entry.
+ (when (and (eq mode 'bib) (not stop-rendering-at))
+ (push '(citation-number) varlist))
+ (let ((rendered-varlist
+ (citeproc-render-varlist-in-rt
+ varlist style mode 'display
+ ;; No link-targets for bib-entry based citations.
+ (if (eq mode 'bib) 'no-links internal-links)
+ ;; No external limking for title-only citations, since we link to the
+ ;; corresponding bibliography entry.
+ (eq stop-rendering-at 'title))))
+ ;; Locator-only cites require extensive post-processing of full cite.
+ (when locator-only
+ (setq rendered-varlist (citeproc-rt-locator-w-label rendered-varlist)))
+ ;; Title-only cites
+ (when (eq stop-rendering-at 'title)
+ (when-let* ((cite-no-attr
+ (citeproc-context-int-link-attrval
+ style internal-links 'cite (alist-get 'position varlist)))
+ (cite-no-attr-val (cons cite-no-attr
+ (alist-get 'citation-number varlist))))
+ ;; Add cited-item-no attr to link to the bibliography entry
+ (setf (car rendered-varlist)
+ (-snoc (car rendered-varlist) cite-no-attr-val))))
+ ;; Add cite prefix and suffix
+ (when (s-present-p plain-suff)
+ (push (citeproc-rt-from-str suff) result)
+ (unless (memql (aref plain-suff 0) '(?, ?\s))
+ (push " " result)))
+ (push rendered-varlist result)
+ (when (s-present-p plain-pref)
+ (unless (= (aref plain-pref (1- (length plain-pref))) ?\s)
+ (push " " result))
+ (push rt-pref result))
+ (citeproc-rt-join-formatted nil result nil))))
+
+(defun citeproc-cite-or-citegroup--render (c style internal-links top-dl gr-dl ys-dl ac-dl)
+ "Render cite or cite-group C with STYLE.
+For the INTERNAL-LINKS argument see `citeproc-cite--render'.
+TOP-DL is the top-, GR-DL the group-, YS-DL the year-suffix- and
+AC-DL the after-collapse-delimiter to use."
+ (cond ((and (car c) (memq (car c) '(top group year-suffix-collapsed)))
+ (let ((delimiter (pcase (car c)
+ ('top top-dl)
+ ('group gr-dl)
+ ('year-suffix-collapsed ys-dl))))
+ (cons
+ nil ; empty attribute list
+ (nbutlast ; remove last delimiter
+ (--mapcat (list (citeproc-cite-or-citegroup--render
+ it style internal-links top-dl gr-dl ys-dl ac-dl)
+ (if (and (car it) (memq (car it) '(group year-suffix-collapsed)))
+ ac-dl
+ delimiter))
+ (cdr c))))))
+ ((eq (car c) 'range)
+ (list nil (citeproc-cite--render (cl-second c) style internal-links)
+ "–" (citeproc-cite--render (cl-third c) style internal-links)))
+ (t (citeproc-cite--render c style internal-links))))
+
+(defun citeproc-citation--render (c proc &optional internal-links)
+ "Render citation C with CSL processor PROC.
+For the optional INTERNAL-LINKS argument see
+`citeproc-cite--render'."
+ (let* ((style (citeproc-proc-style proc))
+ (punct-in-quote
+ (string= (alist-get 'punctuation-in-quote (citeproc-style-locale-opts style))
+ "true"))
+ (cites (citeproc-citation-cites c))
+ (cite-attrs (citeproc-style-cite-layout-attrs style))
+ (cite-layout-dl (alist-get 'delimiter cite-attrs)))
+ ;; Remove delimiters from cite-attrs -- they are rendered 'manually' because of
+ ;; the delimiter-after-collapse complications in rendering. Also remove affixes
+ ;; if requested.
+ (setq cite-attrs
+ (if (citeproc-citation-suppress-affixes c)
+ (--remove (memq (car it) '(delimiter prefix suffix)) cite-attrs)
+ (--remove (eq (car it) 'delimiter) cite-attrs)))
+ ;; Generate rendered cites
+ (let ((rendered-cites
+ (cond
+ ((citeproc-citation-grouped c)
+ (let ((gr-dl
+ (alist-get 'cite-group-delimiter (citeproc-style-cite-opts style)))
+ (ys-dl
+ (alist-get 'year-suffix-delimiter (citeproc-style-cite-opts style)))
+ (aft-coll-dl
+ (alist-get
+ 'after-collapse-delimiter (citeproc-style-cite-opts style))))
+ (cdr (citeproc-cite-or-citegroup--render
+ (cons 'top cites) ; indicate top level input
+ style internal-links cite-layout-dl gr-dl ys-dl aft-coll-dl))))
+ ((cdr cites)
+ (cdr (--mapcat
+ (list cite-layout-dl (citeproc-cite--render it style internal-links))
+ cites)))
+ (t
+ (list (citeproc-cite--render (car cites) style internal-links))))))
+ ;; Calculate inner and outer citation attrs (affixes go inside)
+ (let* ((non-affixes (--remove (memq (car it) '(prefix suffix delimiter)) cite-attrs))
+ (affixes (--filter (memq (car it) '(prefix suffix)) cite-attrs))
+ (outer-attrs (and affixes non-affixes))
+ (result
+ (citeproc-rt-cull-spaces-puncts
+ (citeproc-rt-finalize
+ (citeproc-rt-render-affixes
+ (citeproc-rt-join-formatted (if outer-attrs affixes cite-attrs)
+ rendered-cites nil)
+ t)
+ punct-in-quote))))
+ ;; Add outer (non-affix attrs) if needed
+ (when outer-attrs
+ (setq result (list outer-attrs result)))
+ ;; Prepend author to textual citations
+ (when (and (eq (citeproc-citation-mode c) 'textual)
+ (not (member (citeproc-style-category style) '("numeric" "label"))))
+ (let* ((first-elt (car cites)) ;; First elt is either a cite or a cite group.
+ ;; If the latter then we need to locate the
+ ;; first cite as the 2nd element of the first
+ ;; cite group.
+ (first-cite (if (eq 'group (car first-elt))
+ (cadr first-elt)
+ first-elt))
+ (author-cite
+ (append '((suppress-author . nil) (stop-rendering-at . names)
+ (prefix) (suffix) (locator))
+ first-cite))
+ (rendered-author (citeproc-cite--render author-cite style 'no-links)))
+ (when (listp rendered-author)
+ (setq result `(nil ,rendered-author " " ,result)))))
+ ;; Capitalize first
+ (when (citeproc-citation-capitalize-first c)
+ (setq result (citeproc-rt-change-case result #'citeproc-s-capitalize-first)))
+ ;; Run the citation postprocessing hook
+ (dolist (fn citeproc-citation-postprocess-functions)
+ (setq result (funcall fn result)))
+ result))))
+
+(defun citeproc-cites--collapse-indexed (cites index-getter no-span-pred)
+ "Collapse continuously indexed cites in CITES.
+INDEX-GETTER is a function from cites to numeric indices,
+NO-SPAN-PRED is a predicate that returns non-nil for cites that
+cannot be part of a span. Return the collapsed cites list or nil
+if no cites were collapsed."
+ (let (group-len start-cite prev-index end-cite result)
+ (dolist (cite cites)
+ (let* ((cur-index (funcall index-getter cite))
+ (no-span-elt (funcall no-span-pred cite))
+ (subsequent (and prev-index (= (1+ prev-index) cur-index))))
+ ;; Process ending current group
+ (when (and group-len (or no-span-elt (not subsequent)))
+ (setq result (nconc (citeproc-cite-range--collapse
+ start-cite end-cite
+ group-len)
+ result)))
+ (cond (no-span-elt ; Not only cite-no
+ (push cite result)
+ (setq group-len nil))
+ ((or (not group-len) (not subsequent)) ; New group starts
+ (setq group-len 1
+ start-cite cite
+ prev-index cur-index))
+ (t ; Group continues
+ (cl-incf group-len)
+ (setq end-cite cite
+ prev-index cur-index)))))
+ ;; Process the last group
+ (when group-len
+ (setq result (nconc (citeproc-cite-range--collapse
+ start-cite end-cite group-len)
+ result)))
+ (if (/= (length cites) (length result))
+ (nreverse result)
+ nil)))
+
+(defun citeproc-cite-range--collapse (start-cite end-cite len)
+ "Collapse cite span with START-CITE, END-CITE of LEN length.
+START-CITE end END-CITE is the first and last rendered cites of
+the span."
+ (pcase len
+ (1 (list start-cite))
+ (2 (list end-cite start-cite))
+ (_ (list (list 'range start-cite end-cite)))))
+
+(defun citeproc-citation--collapse-num-citeranges (citation)
+ "Collapse numbered ranges in CITATION."
+ (let* ((cites (citeproc-citation-cites citation))
+ (cites-length (length cites)))
+ (when (> cites-length 2)
+ (-when-let (collapsed
+ (citeproc-cites--collapse-indexed
+ cites
+ (lambda (x)
+ (string-to-number
+ (alist-get 'citation-number (citeproc-cite--varlist x))))
+ (lambda (x) (alist-get 'locator (citeproc-cite--varlist x)))))
+ (setf (citeproc-citation-cites citation) collapsed
+ (citeproc-citation-grouped citation) t)))))
+
+(defun citeproc-cites--collapse-suff-citeranges (cites)
+ "Collapse continuously year-suffixed CITES."
+ (or (citeproc-cites--collapse-indexed
+ cites
+ (lambda (x)
+ (string-to-char (alist-get 'year-suffix (citeproc-cite--varlist x) " ")))
+ (lambda (_x) nil))
+ cites))
+
+(defun citeproc-citation--render-formatted-citation (c proc format &optional internal-links)
+ "Render citation C with csl processor PROC in FORMAT.
+For the optional INTERNAL-LINKS argument see
+`citeproc-cite--render'."
+ (let ((fmt (citeproc-formatter-for-format format)))
+ (funcall (citeproc-formatter-cite fmt)
+ (funcall (citeproc-formatter-rt fmt)
+ (citeproc-citation--render c proc internal-links)))))
+
+(defun citeproc-citation--sort-cites (citation proc)
+ "Sort cites in CITATION for processor PROC."
+ (let ((cites (citeproc-citation-cites citation)))
+ (when (cdr cites)
+ (let* ((style (citeproc-proc-style proc))
+ (sort-orders (citeproc-style-cite-sort-orders style)))
+ (setf (citeproc-citation-cites citation)
+ (sort
+ (--map (cons (cons 'key ; add keys to the cites as extra attr
+ (citeproc-sort--render-keys style (citeproc-cite--varlist it) 'cite))
+ it)
+ cites)
+ (lambda (x y) (citeproc-sort--compare-keylists (cdar x) (cdar y) sort-orders))))))))
+
+(defun citeproc-proc-sort-cites (proc)
+ "Sort cites in all citations of PROC."
+ (when (citeproc-style-cite-sort (citeproc-proc-style proc))
+ (dolist (citation (queue-head (citeproc-proc-citations proc)))
+ (citeproc-citation--sort-cites citation proc))))
+
+(defun citeproc-proc-apply-citation-modes (proc)
+ "Apply mode to the first cite in each citation in PROC."
+ (dolist (citation (queue-head (citeproc-proc-citations proc)))
+ (let ((mode (citeproc-citation-mode citation))
+ (cites (citeproc-citation-cites citation))
+ (ignore-et-al (citeproc-citation-ignore-et-al citation)))
+ (-when-let (mode-rep
+ (alist-get mode citeproc-cite--from-mode-alist))
+ (setf (car cites) (nconc (car cites) mode-rep)))
+ (when ignore-et-al
+ (push '(ignore-et-al . t) (car cites))))))
+
+(defun citeproc-proc-group-and-collapse-cites (proc)
+ "Group and collapse cites in all citations of PROC."
+ (let* ((cite-opts (citeproc-style-cite-opts (citeproc-proc-style proc)))
+ (group-delim (alist-get 'cite-group-delimiter cite-opts))
+ (collapse-type (alist-get 'collapse cite-opts))
+ (collapse-year-type
+ (when collapse-type
+ (let ((cy (member collapse-type
+ '("year" "year-suffix" "year-suffix-ranged"))))
+ (and cy (car cy))))))
+ ;; Collapse (and group) according to collapse type
+ (cond ((or group-delim collapse-year-type)
+ ;; Group and possibly collapse
+ (dolist (citation (queue-head (citeproc-proc-citations proc)))
+ (citeproc-citation--group-and-collapse-cites citation proc collapse-type)))
+ ;; Collapse numeric cites
+ ((string= collapse-type "citation-number")
+ (dolist (citation (queue-head (citeproc-proc-citations proc)))
+ (citeproc-citation--collapse-num-citeranges citation))))))
+
+(defun citeproc-citation--group-and-collapse-cites (c proc &optional collapse-type)
+ "Divide items in citation C in place into groups for PROC.
+Apart from movement necessary for grouping, the relative
+positions of cites in C is kept. If optional COLLAPSE-TYPE is
+given then collapse the groups accordingly."
+ (let ((cites (citeproc-citation-cites c)))
+ (when (cdr cites)
+ (let (groups)
+ (dolist (cite cites)
+ (let ((g-ind
+ ;; Cites are in the same group iff the cdrs of the rendered cite's first
+ ;; name-var are equal. The cdr is taken because we ignore attributes, in
+ ;; particular the cited-item-no attribute which is added when the cite consists
+ ;; entirely of the rendered name var
+ (--find-index (equal (cdr (citeproc-cite--first-namevar-cont cite proc))
+ (cdr (citeproc-cite--first-namevar-cont (car it) proc)))
+ groups)))
+ (if g-ind
+ (push cite (nth g-ind groups))
+ (push (list cite) groups))))
+ (unless (= (length groups) (length cites))
+ (setf (citeproc-citation-cites c)
+ (nreverse
+ (--map (if (cdr it)
+ (cons 'group
+ (pcase collapse-type
+ ("year"
+ (citeproc-citation-group--collapse-year (nreverse it)))
+ ("year-suffix"
+ (citeproc-citation-group--collapse-ys (nreverse it) proc nil))
+ ("year-suffix-ranged"
+ (citeproc-citation-group--collapse-ys (nreverse it) proc t))
+ (_ (nreverse it))))
+ (car it))
+ groups))
+ (citeproc-citation-grouped c) t))))))
+
+(defun citeproc-citation-group--collapse-year (cites)
+ "Collapse year in group CITES."
+ (cons (car cites)
+ (--map (cons '(suppress-author . t) it)
+ (cdr cites))))
+
+(defun citeproc-citation-group--collapse-ys (cites proc collapse-ranges)
+ "Collapse year and suffix in group CITES using PROC.
+If optional COLLAPSE-RANGES is non-nil then collapse year-suffix
+ranges."
+ (let ((first t) (groups (list (list (car cites))))
+ prev-datevar-cont prev-locator)
+ (dolist (cite cites)
+ (let* ((varlist (citeproc-cite--varlist cite))
+ (datevar-cont (cadr (citeproc-cite--first-datevar-cont cite proc)))
+ (locator (alist-get 'locator varlist)))
+ (cond (first
+ (setq first nil))
+ ((or prev-locator
+ locator
+ (not (alist-get 'year-suffix varlist))
+ (not (equal datevar-cont prev-datevar-cont)))
+ (push (list (cons '(suppress-author . t)
+ cite))
+ groups))
+ (t
+ (push (cons '(suppress-date . t)
+ (cons '(suppress-author . t)
+ cite))
+ (car groups))))
+ (setq prev-datevar-cont datevar-cont
+ prev-locator locator))
+ cites)
+ (nreverse
+ (--map (if (cdr it)
+ (cons 'year-suffix-collapsed
+ (if (and collapse-ranges (> (length cites) 2))
+ (citeproc-cites--collapse-suff-citeranges (nreverse it))
+ (nreverse it)))
+ (car it))
+ groups))))
+
+(defun citeproc-citations--itd-referred-p (itd citations)
+ "Whether ITD is referred to in CITATIONS."
+ (let ((cites (--mapcat (citeproc-citation-cites it) citations)))
+ (--any-p (eq itd (alist-get 'itd it)) cites)))
+
+(defun citeproc-cite--update-nn-queue (q index nnd)
+ "Remove too distant citations from near-notes queue Q.
+INDEX is the actual note-index, NND is the near-note-distance."
+ (while (and (queue-head q)
+ (< nnd (- index
+ (citeproc-citation-note-index (queue-first q)))))
+ (queue-dequeue q)))
+
+(defun citeproc-cite--loc-equal-p (s1 s2)
+ "Whether locator strings S1 and S2 refer to the same location."
+ (if (and (citeproc-lib-numeric-p s1) (citeproc-lib-numeric-p s2))
+ (equal (citeproc-number-extract s1) (citeproc-number-extract s2))
+ (string= (s-trim s1) (s-trim s2))))
+
+(defvar citeproc-disambiguation-cite-pos 'last
+ "Which cite position should be the basis of cite disambiguation.
+Possible values are `last', `first' and `subsequent'.")
+
+(defun citeproc-proc-update-positions (proc)
+ "Update all position-related fields in PROC."
+ (citeproc-proc-delete-occurrence-info proc)
+ (let* ((ctns (queue-head (citeproc-proc-citations proc)))
+ (cite-opts (citeproc-style-cite-opts (citeproc-proc-style proc)))
+ (nnd (string-to-number
+ (or (alist-get 'near-note-distance cite-opts)
+ "5")))
+ (near-note-ctns (make-queue))
+ prev-itd prev-loc prev-label)
+ (unless (eq citeproc-disambiguation-cite-pos 'last)
+ (dolist (itd (hash-table-values
+ (citeproc-proc-itemdata proc)))
+ (setf (citeproc-itemdata-disamb-pos itd) citeproc-disambiguation-cite-pos)))
+ (dolist (ctn ctns)
+ (let* ((note-ind (citeproc-citation-note-index ctn))
+ (cites (citeproc-citation-cites ctn))
+ (single-cite (not (cdr cites))))
+ (when note-ind (citeproc-cite--update-nn-queue near-note-ctns note-ind nnd))
+ (let (seen-itds)
+ (while cites
+ (let* ((cite (car cites))
+ (itd (alist-get 'itd cite))
+ (locator (alist-get 'locator cite))
+ (label (alist-get 'label cite))
+ (pos (if (citeproc-itemdata-occurred-before itd)
+ (if (eq itd prev-itd)
+ (if prev-loc
+ (if locator
+ (if (and (citeproc-cite--loc-equal-p prev-loc locator)
+ (string= prev-label label))
+ 'ibid
+ 'ibid-with-locator)
+ 'subsequent)
+ (if locator 'ibid-with-locator 'ibid))
+ 'subsequent)
+ 'first)))
+ (when (and note-ind
+ (or (citeproc-citations--itd-referred-p itd (queue-head near-note-ctns))
+ (memq itd seen-itds)))
+ (setf (alist-get 'near-note (car cites)) t))
+ (setf (alist-get 'position (car cites)) pos
+ prev-itd itd
+ prev-loc locator
+ prev-label label)
+ (when (eq citeproc-disambiguation-cite-pos 'last)
+ (citeproc-itd-update-disamb-pos itd pos))
+ (let ((prev-occurrence (citeproc-itemdata-occurred-before itd)))
+ (if prev-occurrence
+ (unless (eq t prev-occurrence)
+ (setf (alist-get 'first-reference-note-number (car cites))
+ (number-to-string prev-occurrence)))
+ (setf (citeproc-itemdata-occurred-before itd) (or note-ind t))))
+ (push itd seen-itds)
+ (pop cites))))
+ (unless single-cite
+ (setq prev-itd nil prev-loc nil prev-label nil))
+ (when note-ind (queue-append near-note-ctns ctn))))))
+
+(defun citeproc-proc-finalize (proc)
+ "Finalize processor PROC by sorting and disambiguating items."
+ (unless (citeproc-proc-finalized proc)
+ (citeproc-proc-process-uncited proc)
+ (citeproc-sb-add-subbib-info proc)
+ (citeproc-sb-prune-unrendered proc)
+ (citeproc-proc-update-sortkeys proc)
+ (citeproc-proc-sort-itds proc)
+ (citeproc-proc-update-positions proc)
+ (citeproc-proc-disamb proc)
+ (citeproc-proc-sort-cites proc)
+ (citeproc-proc-apply-citation-modes proc)
+ (citeproc-proc-group-and-collapse-cites proc)
+ (setf (citeproc-proc-finalized proc) t)))
+
+(defun citeproc-cite--first-namevar-cont (cite proc)
+ "Return the first raw name-var node of CITE rendered with PROC."
+ (citeproc-rt-find-first-node
+ (citeproc-itd-rt-cite (alist-get 'itd cite) (citeproc-proc-style proc))
+ (lambda (x)
+ (and (consp x) (memq (alist-get 'rendered-var (car x))
+ citeproc--name-vars)))))
+
+(defun citeproc-cite--first-datevar-cont (cite proc)
+ "Return the first raw date-var node of CITE rendered with PROC."
+ (citeproc-rt-find-first-node
+ (citeproc-itd-rt-cite (alist-get 'itd cite) (citeproc-proc-style proc))
+ (lambda (x)
+ (and (consp x) (memq (alist-get 'rendered-var (car x))
+ citeproc--date-vars)))))
+(provide 'citeproc-cite)
+
+;;; citeproc-cite.el ends here
--- /dev/null
+;;; citeproc-context.el --- rendering context for CSL elements -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017-2021 András Simonyi
+
+;; Author: András Simonyi <andras.simonyi@gmail.com>
+
+;; 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 3 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.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Provides the `citeproc-context' CL-structure type to represent rendering
+;; contexts for CSL elements, and functions for accessing context-dependent
+;; information (variable and term values etc.). Also contains some functions
+;; that perform context-dependent formatting (e.g., quoting).
+
+;;; Code:
+
+(require 'let-alist)
+(require 'subr-x)
+
+(require 'citeproc-lib)
+(require 'citeproc-rt)
+(require 'citeproc-term)
+(require 'citeproc-prange)
+(require 'citeproc-style)
+
+(cl-defstruct (citeproc-context (:constructor citeproc-context--create))
+ "A struct representing the context for rendering CSL elements."
+ vars macros terms date-text date-numeric opts locale-opts
+ mode render-mode render-year-suffix no-external-links locale)
+
+(defun citeproc-context-create (var-alist style mode render-mode
+ &optional no-external-links)
+ "Create a citeproc-context struct from var-values VAR-ALIST and csl style STYLE.
+MODE is either `bib' or `cite', RENDER-MODE is `display' or `sort'."
+ (citeproc-context--create
+ :vars var-alist
+ :macros (citeproc-style-macros style)
+ :terms (citeproc-style-terms style)
+ :date-text (citeproc-style-date-text style)
+ :date-numeric (citeproc-style-date-numeric style)
+ :opts (citeproc-style-global-opts style mode)
+ :locale (citeproc-style-locale style)
+ :locale-opts (citeproc-style-locale-opts style)
+ :mode mode
+ :render-mode render-mode
+ :render-year-suffix (not (citeproc-style-uses-ys-var style))
+ :no-external-links no-external-links))
+
+(defconst citeproc--short-long-var-alist
+ '((title . title-short) (container-title . container-title-short))
+ "Alist mapping the long form of variables names to their short form.")
+
+(defun citeproc-var-value (var context &optional form)
+ "Return the value of csl variable VAR in CONTEXT.
+VAR is a symbol, CONTEXT is a `citeproc-context' struct, and the
+optional FORM can be nil, `short' or `long'."
+ (let ((var-vals (citeproc-context-vars context)))
+ (if (or (eq form 'short)
+ ;; Also use the short form of title when the cite contains the
+ ;; (use-short-title . t) pair. This is used for title-only citations.
+ (and (eq var 'title) (alist-get 'use-short-title var-vals)))
+ (-if-let* ((short-var (alist-get var citeproc--short-long-var-alist))
+ (short-var-val (alist-get short-var var-vals)))
+ short-var-val
+ (alist-get var var-vals))
+ (let ((var-val (alist-get var var-vals)))
+ (if (and var-val (or (and (eq var 'locator)
+ (string= (citeproc-var-value 'label context) "page"))
+ (eq var 'page)))
+ (let ((prange-format (citeproc-lib-intern (alist-get 'page-range-format
+ (citeproc-context-opts context))))
+ (sep (or (citeproc-term-text-from-terms "page-range-delimiter"
+ (citeproc-context-terms context))
+ "–")))
+ (citeproc-rt-from-str (citeproc-prange-render var-val prange-format sep)))
+ var-val)))))
+
+(defun citeproc-locator-label (context)
+ "Return the current locator label variable from CONTEXT."
+ (citeproc-var-value 'label context))
+
+(defun citeproc-rt-quote (rt context)
+ "Return the quoted version of rich-text RT using CONTEXT."
+ (let ((oq (citeproc-term-get-text "open-quote" context))
+ (cq (citeproc-term-get-text "close-quote" context))
+ (oiq (citeproc-term-get-text "open-inner-quote" context))
+ (ciq (citeproc-term-get-text "close-inner-quote" context)))
+ `(,oq ,@(citeproc-rt-replace-all-sim `((,oq . ,oiq) (,cq . ,ciq)
+ (,oiq . ,oq) (,ciq . ,cq))
+ (format "\\(%s\\|%s\\|%s\\|%s\\)" oq cq oiq ciq)
+ rt)
+ ,cq)))
+
+(defun citeproc-rt-textcased (rts case context)
+ "Return rich-text content RTS in text-case CASE using CONTEXT.
+CASE is one of the following: `lowercase', `uppercase',
+`capitalize-first', `capitalize-all', `sentence', `title'."
+ (pcase case
+ ('uppercase
+ (citeproc-rt-map-strings #'upcase rts t))
+ ('lowercase
+ (citeproc-rt-map-strings #'downcase rts t))
+ ('capitalize-first
+ (--map (citeproc-rt-change-case it #'citeproc-s-capitalize-first) rts))
+ ('capitalize-all
+ (--map (citeproc-rt-change-case it #'citeproc-s-capitalize-all) rts))
+ ('sentence
+ (--map (citeproc-rt-change-case it #'citeproc-s-sentence-case) rts))
+ ('title
+ (let ((locale (citeproc-context-locale context))
+ (language (citeproc-var-value 'language context)))
+ (if (or (and language (string-prefix-p "en" language))
+ (and (null language)
+ (or (and locale (string-prefix-p "en" locale))
+ (null locale))))
+ (--map (citeproc-rt-change-case it #'citeproc-s-title-case) rts)
+ rts)))))
+
+(defun citeproc-rt-join-formatted (attrs rts context)
+ "Join and format according to ATTRS the rich-texts in RTS."
+ (let-alist attrs
+ (let ((result (delq nil rts)))
+ (when .text-case
+ (setq result (citeproc-rt-textcased result (intern .text-case) context)))
+ (when (string= .strip-periods "true") (setq result (citeproc-rt-strip-periods result)))
+ (when (string= .quotes "true") (setq result (citeproc-rt-quote result context)))
+ (push (citeproc-rt-select-attrs attrs citeproc-rt-ext-format-attrs) result)
+ (if (and .delimiter
+ (> (length result) 2))
+ result
+ (citeproc-rt-simplify-shallow result)))))
+
+(defun citeproc-rt-format-single (attrs rt context)
+ "Format according to ATTRS rich-text RT using CONTEXT."
+ (if (or (not rt) (and (char-or-string-p rt) (string= rt "")))
+ nil
+ (citeproc-rt-join-formatted attrs (list rt) context)))
+
+(defun citeproc-rt-typed-join (attrs typed-rts context)
+ "Join and format according to ATTRS contents in list TYPED-RTS.
+TYPED RTS is a list of (RICH-TEXT . TYPE) pairs"
+ (-let* ((types (--map (cdr it) typed-rts))
+ (type (cond ((--all? (eq it 'text-only) types)
+ 'text-only)
+ ((--any? (eq it 'present-var) types)
+ 'present-var)
+ (t 'empty-vars))))
+ (cons (citeproc-rt-join-formatted attrs
+ (--map (car it) typed-rts)
+ context)
+ type)))
+
+(defun citeproc-term-get-text (term context)
+ "Return the first text associated with TERM in CONTEXT."
+ (citeproc-term-text-from-terms term (citeproc-context-terms context)))
+
+(defconst citeproc--term-form-fallback-alist
+ '((verb-short . verb)
+ (symbol . short)
+ (verb . long)
+ (short . long))
+ "Alist containing the fallback form for each term form.")
+
+(defun citeproc-term-inflected-text (term form number context)
+ "Return the text associated with TERM having FORM and NUMBER."
+ (let ((matches
+ (--select (string= term (citeproc-term-name it))
+ (citeproc-context-terms context))))
+ (if (not matches) nil
+ (let (match)
+ (while (and (not match) form)
+ (setq match (--first (and (eq form (citeproc-term-form it))
+ (or (not (citeproc-term-number it))
+ (eq number (citeproc-term-number it))))
+ matches))
+ (unless match
+ (setq form (alist-get form citeproc--term-form-fallback-alist))))
+ (when match (citeproc-term-text match))))))
+
+(defun citeproc-term-get-gender (term context)
+ "Return the gender of TERM or nil if none is given."
+ (-if-let (match
+ (--first (and (string= (citeproc-term-name it) term)
+ (citeproc-term-gender it)
+ (eq (citeproc-term-form it) 'long))
+ (citeproc-context-terms context)))
+ (citeproc-term-gender match)
+ nil))
+
+(defun citeproc-context-int-link-attrval (style internal-links mode cite-pos)
+ "Return an appropriate attribute to represent internal linking info.
+INTERNAL-LINKS is the internal linking mode, see the
+documentation of `citeproc-render-varlist-in-rt', while MODE is
+the rendering mode, `bib' or `cite', and CITE-POS is a cite
+position. Returns an appropriate attribute to be added or nil if
+no internal links should be produced."
+ (let ((note-style (citeproc-style-cite-note style)))
+ (unless (or (and internal-links (not (memq internal-links '(auto bib-links))))
+ (and note-style (eq mode 'bib) (or (null internal-links)
+ (eq internal-links 'auto))))
+ (if (and note-style (not (eq internal-links 'bib-links)))
+ ;; For note styles link subsequent cites to the first ones.
+ (if (eq cite-pos 'first) 'bib-item-no 'cited-item-no)
+ ;; Else link each cite to the corresponding bib item.
+ (if (eq mode 'cite) 'cited-item-no 'bib-item-no)))))
+
+(defun citeproc-context-maybe-stop-rendering
+ (trigger context result &optional var)
+ "Stop rendering if a (`stop-rendering-at'. TRIGGER) pair is present in CONTEXT.
+In case of stopping return with RESULT. If the optional VAR
+symbol is non-nil then rendering is stopped only if VAR is eq to
+TRIGGER."
+ (if (and (eq trigger (alist-get 'stop-rendering-at (citeproc-context-vars context)))
+ (or (not var) (eq var trigger))
+ (eq (cdr result) 'present-var))
+ (let ((rt-result (car result)))
+ (push '(stopped-rendering . t) (car rt-result))
+ (throw 'stop-rendering (citeproc-rt-render-affixes rt-result)))
+ result))
+
+(defun citeproc-render-varlist-in-rt (var-alist style mode render-mode &optional
+ internal-links no-external-links)
+ "Render an item described by VAR-ALIST with STYLE in rich-text.
+Does NOT finalize the rich-text rendering. MODE is either `bib'
+or `cite', RENDER-MODE is `display' or `sort'.
+ If the optional INTERNAL-LINKS is `bib-links' then link cites
+to the bibliography regardless of the style type, if `no-links'
+then don't add internal links, if nil or `auto' then add internal
+links based on the style type (cite-cite links for note styles
+and cite-bib links else). For legacy reasons, any other value is
+treated as `no-links'.
+ If the optional NO-EXTERNAL-LINKS is non-nil then don't add
+external links."
+ (-if-let (unprocessed-id (alist-get 'unprocessed-with-id var-alist))
+ ;; Itemid received no associated csl fields from the getter!
+ (list nil (concat "NO_ITEM_DATA:" unprocessed-id))
+ (let* ((context (citeproc-context-create var-alist style mode render-mode
+ no-external-links))
+ (layout-fun-accessor (if (eq mode 'cite) 'citeproc-style-cite-layout
+ 'citeproc-style-bib-layout))
+ (layout-fun (funcall layout-fun-accessor style)))
+ (if (null layout-fun) "[NO BIBLIOGRAPHY LAYOUT IN CSL STYLE]"
+ (let ((rendered (catch 'stop-rendering
+ (funcall layout-fun context))))
+ ;; Finalize external linking by linking the title if needed
+ (when (and (eq mode 'bib) (not no-external-links))
+ (-when-let ((var . val) (--any (assoc it var-alist)
+ citeproc--linked-vars))
+ (unless (cl-intersection (citeproc-rt-rendered-vars rendered)
+ citeproc--linked-vars)
+ (citeproc-rt-link-title rendered
+ (concat (alist-get var citeproc--link-prefix-alist
+ "")
+ (alist-get var var-alist))))))
+ ;; Add appropriate item-no information
+ (when-let* ((cite-no-attr
+ (citeproc-context-int-link-attrval
+ style internal-links mode (alist-get 'position var-alist)))
+ (cite-no-attr-val (cons cite-no-attr
+ (alist-get 'citation-number var-alist))))
+ (cond ((consp rendered) (setf (car rendered)
+ (-snoc (car rendered) cite-no-attr-val)))
+ ((stringp rendered) (setq rendered
+ (list (list cite-no-attr-val) rendered)))))
+ ;; Add year-suffix if needed
+ (-if-let (year-suffix (alist-get 'year-suffix var-alist))
+ (car (citeproc-rt-add-year-suffix
+ rendered
+ ;; year suffix is empty if already rendered by var just to delete the
+ ;; suppressed date
+ (if (citeproc-style-uses-ys-var style) "" year-suffix)))
+ rendered))))))
+
+(provide 'citeproc-context)
+
+;;; citeproc-context.el ends here
--- /dev/null
+;;; citeproc-date.el --- CSL date rendering -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017 András Simonyi
+
+;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
+
+;; 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 3 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.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Structure type and functions to render CSL date elements.
+
+;;; Code:
+
+(require 'subr-x)
+(require 'cl-lib)
+(require 'dash)
+(require 'let-alist)
+(require 's)
+
+(require 'citeproc-lib)
+(require 'citeproc-rt)
+(require 'citeproc-context)
+(require 'citeproc-number)
+
+(cl-defstruct (citeproc-date (:constructor citeproc-date-create))
+ "Struct for representing dates.
+Slots YEAR, MONTH, DAY are integers, while SEASON and CIRCA are
+booleans. SEASON indicates whether the integer in slot MONTH is
+to be interpreted as a season number."
+ (year nil) (month nil) (day nil) (season nil) (circa nil))
+
+(defun citeproc-date-parse (date-rep)
+ "Parse CSL json date repr. DATE-REP into an internal one."
+ (let-alist date-rep
+ (--map (citeproc-date--conv it .season .circa) .date-parts)))
+
+(defun citeproc-date--conv (dates &optional season circa)
+ "Convert date-part list DATES to a citeproc-date struct.
+Set the remaining slots to the values SEASON and CIRCA."
+ (-let* ((numeric
+ (--map (if (stringp it) (string-to-number it) it) dates))
+ ((year month day) numeric))
+ (citeproc-date-create :year year :month month :day day
+ :season season :circa circa)))
+
+(defun citeproc-date--partattrs-for-sort (part-attrs)
+ "Return a sort-key version of PART-ATTRS."
+ (let (result)
+ (when (assoc 'day part-attrs)
+ (push '(day . ((form . "numeric-leading-zeros"))) result))
+ (when (assoc 'month part-attrs)
+ (push '(month . ((form . "numeric-leading-zeros"))) result))
+ (when (assoc 'year part-attrs)
+ (push '(year . ((form . "long"))) result))
+ result))
+
+(defun citeproc--date (attrs context &rest body)
+ "Function corresponding to the date CSL element."
+ (-let* (((&alist 'variable var
+ 'form form)
+ attrs)
+ (var-sym (intern var))
+ (parsed-dates (citeproc-var-value var-sym context))
+ ((d1 d2) parsed-dates)
+ (result
+ (if d1
+ (progn
+ (when form
+ (let ((localized (citeproc-date--localized-attrs attrs body context)))
+ (setq attrs (car localized)
+ body (cdr localized))))
+ (when (eq (citeproc-context-render-mode context) 'sort)
+ (setq body (citeproc-date--partattrs-for-sort body)))
+ (if (citeproc-date--renders-with-attrs-p d1 body)
+ (progn
+ (push `(rendered-var . ,(intern var)) attrs)
+ (cons (if d2
+ (citeproc-date--render-range d1 d2 attrs body context)
+ (citeproc-date--render d1 attrs body context))
+ 'present-var))
+ (cons nil 'empty-vars)))
+ (cons nil 'empty-vars))))
+ ;; Handle `year' citation mode by stopping if needed
+ (citeproc-context-maybe-stop-rendering 'issued context result var-sym)))
+
+(defun citeproc--date-part (attrs _context &rest _body)
+ "Function corresponding to the date-part CSL element."
+ (cons (intern (alist-get 'name attrs))
+ attrs))
+
+(defun citeproc-date--renders-with-attrs-p (date part-attrs)
+ "Whether DATE contains date-parts corresponding to PART-ATTRS."
+ (let ((date-parts (mapcar #'car part-attrs)))
+ (or (memq 'year date-parts) ; All dates contain a year
+ (and (memq 'month date-parts) (citeproc-date-month date))
+ (and (memq 'day date-parts) (citeproc-date-day date)))))
+
+(defun citeproc-date--localized-attrs (attrs part-attrs context)
+ "Return the localized date attrs merged with date ATTRS and date PART-ATTRS."
+ (-let* (((&alist 'form form
+ 'date-parts date-parts)
+ attrs)
+ ((loc-attrs . loc-part-attrs)
+ (if (string= form "text") (citeproc-context-date-text context)
+ (citeproc-context-date-numeric context))))
+ (pcase (citeproc-lib-intern date-parts)
+ ('year
+ (setq loc-part-attrs
+ (--select (eq (car it) 'year) loc-part-attrs)))
+ ('year-month
+ (setq loc-part-attrs
+ (--select (memq (car it) '(year month)) loc-part-attrs))))
+ (cons (-concat attrs loc-attrs)
+ (--map (cons (car it)
+ (-concat (alist-get (car it) part-attrs) (cdr it)))
+ loc-part-attrs))))
+
+(defun citeproc-date--render (d attrs part-attrs context)
+ "Render citeproc-date D according to formatting in ATTRS and PART-ATTRS.
+Return a rich-text content."
+ (if (citeproc-var-value 'suppress-date context)
+ (citeproc-rt-format-single attrs "<suppressed-date>" context)
+ (let ((rendered-date (citeproc-date--render-parts d part-attrs context)))
+ (citeproc-rt-join-formatted attrs rendered-date context))))
+
+(defun citeproc-date--render-parts (d part-attrs context &optional no-last-suffix)
+ "Render the parts of citeproc-date D according to PART-ATTRS.
+Return a list of rich-text contents. If optional NO-LAST-SUFFIX
+is non-nil then remove the suffix attribute of the last rendered
+element (used for date range rendering)."
+ (let ((result (--map (pcase (car it)
+ ('year (citeproc-date--render-year d (cdr it) context))
+ ('month (citeproc-date--render-month d (cdr it) context))
+ ('day (citeproc-date--render-day d (cdr it) context)))
+ part-attrs)))
+ (-if-let* ((n-l-s no-last-suffix)
+ (last (car (last result)))
+ (wo-suffix (and (consp last)
+ (cons (--remove (eq 'suffix (car it)) (car last))
+ (cdr last)))))
+ (-snoc (butlast result) wo-suffix)
+ result)))
+
+(defun citeproc-date--render-range-parts (d1 d2 part-attrs sep context)
+ "Render the parts of citeproc-dates D1 and D2 according to PART-ATTRS.
+PART-ATTRS is a list containing either part-attrs or lists of part-attrs.
+The formers are only rendered for D1, while the latters are rendered for both
+D1 and D2. Return a list of rich-text contents."
+ (--mapcat (pcase (car it)
+ ('year (list (citeproc-date--render-year d1 (cdr it) context)))
+ ('month (list (citeproc-date--render-month d1 (cdr it) context)))
+ ('day (list (citeproc-date--render-day d1 (cdr it) context)))
+ (_ (-concat (citeproc-date--render-parts d1 it context t)
+ (list sep)
+ (citeproc-date--render-parts d2 it context))))
+ part-attrs))
+
+(defun citeproc-date--render-range (d1 d2 attrs part-attrs context)
+ "Render the range given by dates D1 D2 according to attrs."
+ (if (citeproc-var-value 'suppress-date context)
+ (citeproc-rt-format-single attrs "" context)
+ (let* ((gran (min (citeproc-date--gran d1)
+ (citeproc-date--attrs-gran part-attrs)))
+ (range-sep (or (alist-get 'range-delimiter
+ (alist-get (elt '(year month day) gran)
+ part-attrs))
+ "–"))
+ (range-p-attrs
+ (cond ((/= (citeproc-date-year d1) (citeproc-date-year d2))
+ (list part-attrs))
+ ((/= (citeproc-date-month d1) (citeproc-date-month d2))
+ (let ((year-part (--find (eq 'year (car it))
+ part-attrs))
+ (attrs-wo-year
+ (--remove (eq 'year (car it))
+ part-attrs)))
+ (cond ((eq (caar part-attrs) 'year)
+ (list year-part attrs-wo-year))
+ ((eq (caar (last part-attrs)) 'year)
+ (list attrs-wo-year year-part))
+ (t (list attrs-wo-year)))))
+ (t (--map (if (eq (car it) 'day) (list it) it)
+ part-attrs))))
+ (rendered-range (citeproc-date--render-range-parts d1 d2 range-p-attrs range-sep
+ context)))
+ (citeproc-rt-join-formatted attrs rendered-range context))))
+
+(defun citeproc-date--attrs-gran (d-attrs)
+ "Return the granularity (smallest unit) of date-attrs alist D-ATTRS.
+The returned value is 0, 1 or 2, corresponding to a year, month
+or day granularity."
+ (cond ((assoc 'day d-attrs) 2)
+ ((assoc 'month d-attrs) 1)
+ (t 0)))
+
+(defun citeproc-date--gran (date)
+ "Return the granularity (smallest unit) in citeproc-date struct DATE.
+The returned value is 0, 1 or 2, corresponding to a year, month
+or day granularity."
+ (cond ((citeproc-date-day date) 2)
+ ((citeproc-date-month date) 1)
+ (t 0)))
+
+(defun citeproc-date--render-year (d attrs context)
+ "Render the year in date D according to formatting in ATTRS.
+D is a citeproc-date structure. Return a rich-text content."
+ (-let* ((form (alist-get 'form attrs))
+ (year (citeproc-date-year d))
+ (s (number-to-string (abs year)))
+ (era
+ (cond ((> year 999) "")
+ ((> year 0) (citeproc-term-get-text "ad" context))
+ (t (citeproc-term-get-text "bc" context)))))
+
+ (citeproc-rt-format-single attrs (concat (if (string= form "short")
+ (s-right 2 s)
+ s)
+ era)
+ context)))
+
+(defun citeproc-date--render-month (d attrs context)
+ "Render the month in date D according to formatting in ATTRS.
+D is a citeproc-date structure. Return a rich-text content."
+ (-if-let (month (citeproc-date-month d))
+ (let ((form (alist-get 'form attrs))
+ (term-pref (if (citeproc-date-season d)
+ "season-" "month-")))
+ (citeproc-rt-format-single
+ attrs
+ (pcase (citeproc-lib-intern form)
+ ('numeric (number-to-string month))
+ ('numeric-leading-zeros (format "%02d" month))
+ ('short (citeproc-term-inflected-text
+ (concat term-pref (format "%02d" month))
+ 'short nil context))
+ (_ (citeproc-term-inflected-text
+ (concat term-pref (format "%02d" month))
+ 'long nil context)))
+ context))
+ nil))
+
+(defun citeproc-date--render-day (d attrs context)
+ "Render the day in date D according to formatting in ATTRS.
+D is a citeproc-date structure. Return a rich-text content."
+ (-if-let (day (citeproc-date-day d))
+ (let ((form (alist-get 'form attrs))
+ (month (citeproc-date-month d)))
+ (citeproc-rt-format-single
+ attrs
+ (cond
+ ((string= form "numeric-leading-zeros")
+ (format "%02d" day))
+ ((and (string= form "ordinal")
+ (or (= day 1)
+ (not (string= "true"
+ (alist-get 'limit-day-ordinals-to-day-1
+ (citeproc-context-locale-opts context))))))
+ (citeproc-number--format-as-ordinal (number-to-string day)
+ (concat "month-" (format "%02d" month))
+ context))
+ (t (number-to-string day)))
+ context))
+ nil))
+
+(provide 'citeproc-date)
+
+;;; citeproc-date.el ends here
--- /dev/null
+;;; citeproc-disamb.el --- disambiguate ambiguous cites -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017 András Simonyi
+
+;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
+
+;; 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 3 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.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Functions to disambiguate cites of different bibliography items that would
+;; have the same rendering. Disambiguation steps (e.g., adding more names,
+;; expanding names, adding year-suffixes) are performed according to the
+;; disambiguation rules specified by the CSL style in use.
+
+;;; Code:
+
+(require 'dash)
+(require 'cl-lib)
+(require 'subr-x)
+
+(require 'citeproc-itemdata)
+
+(defun citeproc-itd-inc-disamb-level (key itd type)
+ "Increment the disambiguation level of KEY in itemdata ITD.
+TYPE is either `add-names' or `show-given-names.'"
+ (let ((vv (citeproc-itemdata-varvals itd)))
+ (if (alist-get type vv)
+ (let* ((cur-level (alist-get key (alist-get type vv)))
+ (new-level (if cur-level (1+ cur-level) 1)))
+ (setf (alist-get key (alist-get type vv)) new-level))
+ (push `(,type . ((,key . 1))) (citeproc-itemdata-varvals itd))))
+ (setf (citeproc-itemdata-rc-uptodate itd) nil))
+
+(defun citeproc-itd-add-name (itd style &optional _first-step)
+ "Perform an add-name disambig. step on itemdata ITD with STYLE.
+FIRST-STEP is ignored -- it is there to get the same signature as
+the other two disamb. step functions. Return nil if no disambiguation
+could be performed and t otherwise. Disambiguation is performed
+from left to right: an item is attempted to be expanded only if
+no previous items to the left could be."
+ (let* ((vars (citeproc-itd-namevars itd style))
+ (cite (citeproc-itd-plain-cite itd style))
+ (vv (citeproc-itemdata-varvals itd))
+ (levels (alist-get 'add-names vv))
+ (remaining-vars (if levels (memq (caar levels) vars) vars))
+ (success nil))
+ (while (and (not success) remaining-vars)
+ (citeproc-itd-inc-disamb-level (car remaining-vars) itd 'add-names)
+ (if (string= cite (citeproc-itd-plain-cite itd style))
+ (pop remaining-vars)
+ (setq success t)))
+ success))
+
+(defun citeproc-itd-add-given (itd style &optional first-step)
+ "Perform an add-given disambig. step on itemdata ITD with STYLE.
+Unless FIRST-STEP is non-nil, remove the last previously added
+given name if the last added given name is shown in its entirety.
+Return nil if no disambig. step could be performed and t
+otherwise."
+ (let* ((nids (citeproc-itd-nameids itd style))
+ (cite (citeproc-itd-plain-cite itd style))
+ (vv (citeproc-itemdata-varvals itd))
+ (levels (alist-get 'show-given-names vv))
+ (remaining-nids (if levels (memq (caar levels) nids) nids))
+ (success nil))
+ (while (and (not success) remaining-nids)
+ (let* ((current-nid (car remaining-nids))
+ (vv (citeproc-itemdata-varvals itd))
+ (levels (alist-get 'show-given-names vv))
+ (current-level (alist-get current-nid levels)))
+ (if (and current-level (>= current-level 2))
+ (pop remaining-nids)
+ (citeproc-itd-inc-disamb-level current-nid itd 'show-given-names)
+ (unless (string= cite (citeproc-itd-plain-cite itd style))
+ (setq success t)
+ (unless (or first-step current-level)
+ (let ((ls (alist-get 'show-given-names vv)))
+ (setf (alist-get 'show-given-names vv)
+ (cons (car ls) (cddr ls))))
+ (setf (citeproc-itemdata-rc-uptodate itd) nil))))))
+ success))
+
+(defun citeproc-itd-addgiven-with-addname (itd style &optional first-step)
+ "Perform a combined disambig. step on itemdata ITD with STYLE.
+If FIRST-STEP is non-nil then (i) add a new name even if the last
+add-given step showed only initials, (ii) don't remove the
+previously added given name. Return nil if no disambig. step
+could be performed and t otherwise."
+ (let* ((vv (citeproc-itemdata-varvals itd))
+ (gn (alist-get 'show-given-names vv))
+ (success nil)
+ (remaining-names t))
+ (if (and (not first-step) gn (= 1 (cdar gn)) (citeproc-itd-add-given itd style))
+ t
+ (while (and (not success) remaining-names)
+ (let ((nids (citeproc-itd-nameids itd style)))
+ (if (citeproc-itd-add-name itd style)
+ (let* ((new-nids (citeproc-itd-nameids itd style))
+ (new-nid (car (cl-set-difference new-nids nids))))
+ ;;next sexp is to direct the add-given function to the just added name
+ (when first-step
+ (setf (alist-get new-nid
+ (alist-get 'show-given-names
+ (citeproc-itemdata-varvals itd)))
+ 0))
+ (when (citeproc-itd-add-given itd style first-step)
+ (setq success t)))
+ (setq remaining-names nil))))
+ success)))
+
+(defun citeproc-disamb--different-cites-p (itds style)
+ "Whether some itemdata in ITDS have different cites with STYLE."
+ (--any-p (not (string= (citeproc-itd-plain-cite it style)
+ (citeproc-itd-plain-cite (car itds) style)))
+ (cdr itds)))
+
+(defun citeproc-disamb--with-method (itds style disamb-fun)
+ "Disambiguate itemdatas in ITDS for STYLE with DISAMB-FUN.
+Return t if the disambiguation was (at least partially)
+successful and nil otherwise."
+ (let ((orig-settings (copy-tree (citeproc-disamb--settings itds)))
+ success
+ (first-step t))
+ (while (and (not success)
+ (--all-p (funcall disamb-fun it style first-step) itds))
+ (setq first-step nil)
+ (when (citeproc-disamb--different-cites-p itds style)
+ (setq success t)))
+ (unless success
+ (citeproc-disamb--restore-settings itds orig-settings))
+ success))
+
+(defun citeproc-disamb--settings (itds)
+ "Return a list with the disamb settings of ITDS."
+ (--map (cons (citeproc-itd-getvar it 'add-names)
+ (citeproc-itd-getvar it 'show-given-names))
+ itds))
+
+(defun citeproc-disamb--restore-settings (itds settings)
+ "Restore the disamb settings of ITDS from SETTINGS.
+SETTINGS should have the structure produced by citeproc--disamb-settings."
+ (cl-loop for itd in itds
+ for (add-names-val . show-given-val) in settings do
+ (citeproc-itd-setvar itd 'add-names add-names-val)
+ (citeproc-itd-setvar itd 'show-given-names show-given-val)))
+
+(defun citeproc-disamb--num-to-yearsuffix (n)
+ "Return year-suffix no. N (starting from 0)."
+ (cond ((< n 26)
+ (char-to-string (+ 97 n)))
+ ((< n 702)
+ (let* ((rem (% n 26))
+ (d (/ (- n rem) 26)))
+ (concat (char-to-string (+ 96 d))
+ (char-to-string (+ 97 rem)))))
+ (t (error "Number too large to convert into a year-suffix"))))
+
+(defun citeproc-disamb--add-yearsuffix (itds _style)
+ "Disambiguate itemdata in ITDS by adding year suffices.
+Return t (for the sake of consistency with other disamb methods)."
+ (--each-indexed (--sort (< (string-to-number (citeproc-itd-getvar it 'citation-number))
+ (string-to-number (citeproc-itd-getvar other 'citation-number)))
+ itds)
+ (citeproc-itd-setvar it 'year-suffix (citeproc-disamb--num-to-yearsuffix it-index))
+ (setf (citeproc-itemdata-rc-uptodate it) nil))
+ t)
+
+(defun citeproc-disamb--set-fields (itds)
+ "Disambiguate ITDS by setting their disambiguate fields."
+ (--each itds
+ (citeproc-itd-setvar it 'disambiguate t)))
+
+(defun citeproc-disamb-amb-itds (itds style name given yearsuff)
+ "Disambiguate ITDS ambigous for STYLE with the given methods.
+NAME, GIVEN and YEARSUFF are generalized booleans specifying
+whether or not the add-name, show-given or add-year-suffix
+disambiguation methods should be used. Return t if the
+disambiguation was (at least partially) successful, nil
+otherwise."
+ (or (and name (citeproc-disamb--with-method itds style 'citeproc-itd-add-name))
+ (and given (citeproc-disamb--with-method itds style 'citeproc-itd-add-given))
+ (and name given
+ (citeproc-disamb--with-method itds style 'citeproc-itd-addgiven-with-addname))
+ (progn
+ (citeproc-disamb--set-fields itds)
+ (citeproc-disamb--different-cites-p itds style))
+ (and yearsuff
+ (citeproc-disamb--add-yearsuffix itds style)
+ (citeproc-disamb--different-cites-p itds style))))
+
+(defun citeproc-amb-itds (itds style)
+ "Return a list of ambigous sets in ITDS for STYLE.
+The returned value is a (possibly empty) list of lists."
+ (let* ((sorted (-sort (lambda (x y)
+ (string< (citeproc-itd-plain-cite x style)
+ (citeproc-itd-plain-cite y style)))
+ itds))
+ (result nil)
+ (remaining (cdr sorted))
+ (act (car sorted))
+ (act-list (list act))
+ (ambig nil))
+ (while remaining
+ (let ((next (car remaining)))
+ (if (string= (citeproc-itd-plain-cite act style)
+ (citeproc-itd-plain-cite next style))
+ (progn
+ (push next act-list)
+ (setq ambig t))
+ (when ambig (push act-list result))
+ (setq act-list (list next)
+ act next
+ ambig nil))
+ (pop remaining)))
+ (when ambig (push act-list result))
+ result))
+
+(defun citeproc-disamb-itds (itds style name given yearsuff)
+ "Disambiguate itemdatas in list ITDS for STYLE.
+NAME, GIVEN and YEARSUFF are generalized booleans specifying
+whether or not the add-name, show-given or add-year-suffix
+disambiguation methods should be used."
+ (let ((amb-itds (citeproc-amb-itds itds style)))
+ (while amb-itds
+ (let ((act-set (pop amb-itds)))
+ (citeproc-disamb-amb-itds act-set style name given yearsuff)
+ (when (citeproc-disamb--different-cites-p act-set style)
+ (-when-let (new-ambs (citeproc-amb-itds act-set style))
+ (setq amb-itds (nconc new-ambs amb-itds))))))))
+
+(provide 'citeproc-disamb)
+
+;;; citeproc-disamb.el ends here
--- /dev/null
+;; citeproc-formatters.el --- output formatters -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017-2021 András Simonyi
+
+;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
+
+;; 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 3 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.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Provides a general framework for defining citeproc-el output formatters, and,
+;; using this framework, defines formatters for the formats `raw' (the rich-text
+;; internal representation), `plain' (plain-text), `html', `org' and `latex'.
+;; Further output formatters can easily be added.
+
+;;; Code:
+
+(require 'let-alist)
+(require 'subr-x)
+(require 's)
+(require 'cl-lib)
+
+(require 'citeproc-s)
+(require 'citeproc-rt)
+
+(cl-defstruct (citeproc-formatter (:constructor citeproc-formatter-create))
+ "Output formatter struct with slots RT, CITE, BIB-ITEM and BIB.
+RT is a one-argument function mapping a rich-text to its
+ formatted version,
+CITE is a one-argument function mapping the output of RT for a
+ citation rich-text to a fully formatted citation,
+BIB-ITEM is a two-argument function mapping the output of RT for
+ a bibliography-item rich-text and a BIB-FORMAT alist (see
+ below) to a fully formatted bibliography item,
+BIB is a two-argument function mapping a list of formatted
+ bibliography items and a FORMATTING-PARAMETERS alist (see
+ `citeproc-render-bib' for details) to a fully formatted
+ bibliography,
+NO-EXTERNAL-LINKS is non-nil if the formatter doesn't support
+ external linking."
+ rt (cite #'identity) (bib-item (lambda (x _) x))
+ (bib (lambda (x _) (mapconcat #'identity x "\n\n")))
+ (no-external-links nil))
+
+(defun citeproc-formatter-fun-create (fmt-alist)
+ "Return a rich-text formatter function based on FMT-ALIST.
+FMT-ALIST is an alist with some or all of the following symbols
+as keys:
+- `unformatted',
+- `font-style-italic', `font-style-oblique', `font-style-normal',
+- `font-variant-small-caps', `font-variant-normal',
+- `font-weight-bold', `font-weight-light', `font-weight-normal',
+- `text-decoration-underline', `text-decoration-normal',
+- `vertical-align-sub', `vertical-align-sup', `vertical-align-baseline',
+- `display-block', `display-left-margin', `display-right-inline',
+ `display-indent',
+- `href',
+- `cited-item-no', `bib-item-no'.
+
+With the exceptions listed below the values should be
+one-argument formatting functions that format the input string
+according to the attribute-value pair specified by the key.
+
+The exceptions are the keys
+`unformatted', for which the value should be a one-argument
+ function converting unformatted text into the required
+ format (e.g., by escaping);
+`href', here the value should be a two-argument function
+ mapping the first argument as anchor text and the second as
+ target URI to a hyperlink representation; and
+`cited-item-no' and `bib-item-no' whose associated values
+ should be two-argument functions, which are called with the
+ already formatted cites/bibliography item text and the number of
+ the bibliography item as a string."
+ (cl-labels
+ ((rt-fmt
+ (rt)
+ (pcase rt
+ ((pred stringp) (funcall (alist-get 'unformatted fmt-alist) rt))
+ ((pred consp)
+ (let ((attrs (car rt))
+ (result (mapconcat #'rt-fmt (cdr rt) "")))
+ (dolist (attr attrs)
+ (let ((key (car attr)))
+ (if (memq key '(href cited-item-no bib-item-no))
+ (when-let ((fmt-fun (alist-get key fmt-alist)))
+ (setq result (funcall fmt-fun result (cdr attr))))
+ (when-let
+ ((fmt-fun
+ (alist-get
+ (pcase attr
+ ('(font-style . "italic") 'font-style-italic)
+ ('(font-weight . "bold") 'font-weight-bold)
+ ('(display . "indent") 'display-indent)
+ ('(display . "left-margin") 'display-left-margin)
+ ('(display . "right-inline") 'display-right-inline)
+ ('(display . "block") 'display-block)
+ ('(vertical-align . "sup") 'vertical-align-sup)
+ ('(vertical-align . "baseline") 'vertical-align-baseline)
+ ('(font-variant . "small-caps") 'font-variant-small-caps)
+ ('(text-decoration . "underline") 'text-decoration-underline)
+ ('(font-style . "oblique") 'font-style-oblique)
+ ('(font-style . "normal") 'font-style-normal)
+ ('(font-variant . "normal") 'font-variant-normal)
+ ('(font-weight . "light") 'font-weight-light)
+ ('(font-weight . "normal") 'font-weight-normal)
+ ('(text-decoration . "normal") 'text-decoration-normal)
+ ('(vertical-align . "sub") 'vertical-align-sub))
+ fmt-alist)))
+ (setq result (funcall fmt-fun result))))))
+ result))
+ (_ rt))))
+ #'rt-fmt))
+
+;;;; Specific formatters
+
+;; Org
+
+(defun citeproc-fmt--org-link (anchor target)
+ "Return an Org link with ANCHOR and TARGET.
+If ANCHOR is string= to TARGET then return ANCHOR."
+ (if (string= anchor target)
+ anchor
+ (concat "[[" target "][" anchor "]]")))
+
+(defconst citeproc-fmt--org-alist
+ `((unformatted . identity)
+ (href . ,#'citeproc-fmt--org-link)
+ (cited-item-no . ,(lambda (x y) (concat "[[citeproc_bib_item_" y "][" x "]]")))
+ (bib-item-no . ,(lambda (x y) (concat "<<citeproc_bib_item_" y ">>" x)))
+ ;; Warning: The next four formatter lines put protective zero-width spaces
+ ;; around the Org format characters ('/' etc.).
+ (font-style-italic . ,(lambda (x) (concat "/" x "/")))
+ (font-style-oblique . ,(lambda (x) (concat "/" x "/")))
+ (font-weight-bold . ,(lambda (x) (concat "*" x "*")))
+ (text-decoration-underline . ,(lambda (x) (concat "_" x "_")))
+ ;; End of zero-width space protected formatters.
+ (font-variant-small-caps . ,(lambda (x) (upcase x)))
+ (vertical-align-sub . ,(lambda (x) (concat "_{" x "}")))
+ (vertical-align-sup . ,(lambda (x) (concat "^{" x "}")))
+ (display-left-margin . ,(lambda (x) (concat x " ")))))
+
+(defvar citeproc-fmt--org-format-rt-1
+ (citeproc-formatter-fun-create citeproc-fmt--org-alist)
+ "Recursive rich-text Org formatter.
+Doesn't do finalization by removing zero-width spaces.")
+
+(defun citeproc-fmt--org-format-rt (rt)
+ "Convert rich-text RT into Org format.
+Performs finalization by removing unnecessary zero-width spaces."
+ (let ((result (funcall citeproc-fmt--org-format-rt-1 rt)))
+ (when (> (length result) 2)
+ ;; First we remove z-w spaces around spaces and before punctuation.
+ (setq result (citeproc-s-replace-all-seq
+ result '((" " . " ") (" " . " ") ("," . ",") (";" . ";")
+ (":" . ":") ("." . "."))))
+ ;; Starting and ending z-w spaces are also removed, but not before an asterisk
+ ;; to avoid creating an Org heading.
+ (when (and (= (aref result 0) 8203)
+ (not (= (aref result 1) ?*)))
+ (setq result (substring result 1)))
+ (when (= (aref result (- (length result) 1)) 8203)
+ (setq result (substring result 0 -1)))
+ ;; Prepend a zero width no-break space when the text starts with
+ ;; superscript to make Org parse it correctly.
+ ;; NOTE: This is a workaround, ideally should be fixed in Org.
+ (when (= (aref result 0) ?^)
+ (setq result (concat "" result))))
+ result))
+
+;; HTML
+
+(defun citeproc-fmt--xml-escape (s)
+ "Return the xml-escaped version of string S.
+Only '&', '<' and '>' are escaped to keep compatibility with the
+CSL tests."
+ (citeproc-s-replace-all-seq s '(("&" . "&") ("<" . "<") (">" . ">"))))
+
+(defconst citeproc-fmt--html-alist
+ `((unformatted . citeproc-fmt--xml-escape)
+ (href . ,(lambda (x y) (concat "<a href=\"" y "\">" x "</a>")))
+ (cited-item-no . ,(lambda (x y) (concat "<a href=\"#citeproc_bib_item_" y "\">"
+ x "</a>")))
+ (bib-item-no . ,(lambda (x y) (concat "<a id=\"citeproc_bib_item_" y "\"></a>"
+ x)))
+ (font-style-italic . ,(lambda (x) (concat "<i>" x "</i>")))
+ (font-style-oblique . ,(lambda (x)
+ (concat "<span style=\"font-style:oblique;\"" x "</span>")))
+ (font-variant-small-caps . ,(lambda (x)
+ (concat
+ "<span style=\"font-variant:small-caps;\">" x "</span>")))
+ (font-weight-bold . ,(lambda (x) (concat "<b>" x "</b>")))
+ (text-decoration-underline .
+ ,(lambda (x)
+ (concat
+ "<span style=\"text-decoration:underline;\">" x "</span>")))
+ (vertical-align-sub . ,(lambda (x) (concat "<sub>" x "</sub>")))
+ (vertical-align-sup . ,(lambda (x) (concat "<sup>" x "</sup>")))
+ (vertical-align-baseline . ,(lambda (x) (concat "<span style=\"baseline\">" x "</span>")))
+ (display-left-margin . ,(lambda (x) (concat "\n <div class=\"csl-left-margin\">"
+ x "</div>")))
+ (display-right-inline . ,(lambda (x) (concat "<div class=\"csl-right-inline\">"
+ x "</div>\n ")))
+ (display-block . ,(lambda (x) (concat "\n\n <div class=\"csl-block\">"
+ x "</div>\n")))
+ (display-indent . ,(lambda (x) (concat "<div class=\"csl-indent\">" x "</div>\n ")))))
+
+(defconst citeproc-fmt--csl-test-alist
+ `((unformatted . citeproc-fmt--xml-escape)
+ (cited-item-no . ,(lambda (x y) (concat "<a href=\"#citeproc_bib_item_" y "\">"
+ x "</a>")))
+ (bib-item-no . ,(lambda (x y) (concat "<a id=\"citeproc_bib_item_" y "\"></a>"
+ x)))
+ (font-style-italic . ,(lambda (x) (concat "<i>" x "</i>")))
+ (font-style-oblique . ,(lambda (x)
+ (concat "<span style=\"font-style:oblique;\"" x "</span>")))
+ (font-variant-small-caps . ,(lambda (x)
+ (concat
+ "<span style=\"font-variant:small-caps;\">" x "</span>")))
+ (font-weight-bold . ,(lambda (x) (concat "<b>" x "</b>")))
+ (text-decoration-underline .
+ ,(lambda (x)
+ (concat
+ "<span style=\"text-decoration:underline;\">" x "</span>")))
+ (vertical-align-sub . ,(lambda (x) (concat "<sub>" x "</sub>")))
+ (vertical-align-sup . ,(lambda (x) (concat "<sup>" x "</sup>")))
+ (vertical-align-baseline . ,(lambda (x) (concat "<span class=\"baseline\">" x "</span>")))
+ (display-left-margin . ,(lambda (x) (concat "\n <div class=\"csl-left-margin\">"
+ x "</div>")))
+ (display-right-inline . ,(lambda (x) (concat "<div class=\"csl-right-inline\">"
+ x "</div>\n ")))
+ (display-block . ,(lambda (x) (concat "\n\n <div class=\"csl-block\">"
+ x "</div>\n")))
+ (display-indent . ,(lambda (x) (concat "<div class=\"csl-indent\">" x "</div>\n ")))))
+
+(defun citeproc-fmt--html-bib-formatter (items _bib-format)
+ "Return a html bibliography from already formatted ITEMS."
+ (concat "<div class=\"csl-bib-body\">\n"
+ (mapconcat (lambda (i)
+ (concat " <div class=\"csl-entry\">" i "</div>\n"))
+ items
+ "")
+ "</div>"))
+
+;; LaTeX
+
+(defconst citeproc-fmt--latex-esc-regex
+ (regexp-opt '("_" "&" "#" "%" "$" "{" "}" ))
+ "Regular expression matching characters to be escaped in LaTeX output.")
+
+(defun citeproc-fmt--latex-escape (s)
+ "Return the LaTeX-escaped version of string S."
+ (replace-regexp-in-string citeproc-fmt--latex-esc-regex "\\\\\\&" s))
+
+(defconst citeproc-fmt--latex-uri-esc-regex
+ (regexp-opt '("#" "%"))
+ "Regular expression matching characters to be escaped in URIs for LaTeX output.")
+
+(defun citeproc-fmt--latex-href (text uri)
+ (let ((escaped-uri (replace-regexp-in-string
+ citeproc-fmt--latex-uri-esc-regex "\\\\\\&" uri)))
+ (if (string-prefix-p "http" text)
+ (concat "\\url{" escaped-uri "}")
+ (concat "\\href{" escaped-uri "}{" text "}"))))
+
+(defconst citeproc-fmt--latex-alist
+ `((unformatted . ,#'citeproc-fmt--latex-escape)
+ (href . ,#'citeproc-fmt--latex-href)
+ (font-style-italic . ,(lambda (x) (concat "\\textit{" x "}")))
+ (font-weight-bold . ,(lambda (x) (concat "\\textbf{" x "}")))
+ (cited-item-no . ,(lambda (x y) (concat "\\citeprocitem{" y "}{" x "}")))
+ (bib-item-no . ,(lambda (x y) (concat "\\hypertarget{citeproc_bib_item_" y "}{"
+ x "}")))
+ (font-variant-small-caps . ,(lambda (x) (concat "\\textsc{" x "}")))
+ (text-decoration-underline . ,(lambda (x) (concat "\\underline{" x "}")))
+ (vertical-align-sup . ,(lambda (x) (concat "\\textsuperscript{" x "}")))
+ (display-left-margin . ,(lambda (x) (concat x " ")))
+ (vertical-align-sub . ,(lambda (x) (concat "\\textsubscript{" x "}")))
+ (font-style-oblique . ,(lambda (x) (concat "\\textsl{" x "}")))))
+
+;; Org-LaTeX
+
+(defconst citeproc-fmt--org-latex-alist
+ `((unformatted . ,#'citeproc-fmt--latex-escape)
+ (href . ,#'citeproc-fmt--latex-href)
+ (font-style-italic . ,(lambda (x) (concat "\\textit{" x "}")))
+ (font-weight-bold . ,(lambda (x) (concat "\\textbf{" x "}")))
+ (cited-item-no . ,(lambda (x y) (concat "\\cslcitation{" y "}{" x "}")))
+ (bib-item-no . ,(lambda (x y) (concat "\\cslbibitem{" y "}{" x "}")))
+ (font-variant-small-caps . ,(lambda (x) (concat "\\textsc{" x "}")))
+ (text-decoration-underline . ,(lambda (x) (concat "\\underline{" x "}")))
+ (vertical-align-sup . ,(lambda (x) (concat "\\textsuperscript{" x "}")))
+ (display-left-margin . ,(lambda (x) (concat "\\cslleftmargin{" x "}")))
+ (display-right-inline . ,(lambda (x) (concat "\\cslrightinline{" x "}")))
+ (display-block . ,(lambda (x) (concat "\\cslblock{" x "}")))
+ (display-indent . ,(lambda (x) (concat "\\cslindent{" x "}")))
+ (vertical-align-sub . ,(lambda (x) (concat "\\textsubscript{" x "}")))
+ (font-style-oblique . ,(lambda (x) (concat "\\textsl{" x "}")))))
+
+(defun citeproc-fmt--org-latex-bib-formatter (items bib-format)
+ "Return an Org LaTeX bibliography of ITEMS formatted in BIB-FORMAT."
+ (let-alist bib-format
+ (let ((hanging-indent (if .hanging-indent "1" "0"))
+ (entry-spacing (if (and .entry-spacing (<= 1 .entry-spacing))
+ (number-to-string (- .entry-spacing 1))
+ "0")))
+ (concat "\\begin{cslbibliography}{" hanging-indent "}{" entry-spacing "}\n"
+ (mapconcat #'identity items "\n\n")
+ "\n\n\\end{cslbibliography}\n"))))
+
+;; Org-ODT
+
+(defconst citeproc-fmt--org-odt-alist
+ `((unformatted . citeproc-fmt--xml-escape)
+ (href . ,(lambda (x y) (concat "<text:a xlink:type=\"simple\" xlink:href=\""
+ y "\">" x "</text:a>")))
+ (cited-item-no
+ . ,(lambda (x y) (concat "<text:a xlink:type=\"simple\" xlink:href=\"#citeproc_bib_item_"
+ y "\">" x "</text:a>")))
+ (bib-item-no
+ . ,(lambda (x y)
+ (concat "<text:bookmark-start text:name=\"OrgXref.citeproc_bib_item_" y "\"/>"
+ "<text:bookmark text:name=\"citeproc_bib_item_" y "\"/>"
+ "<text:bookmark-end text:name=\"OrgXref.citeproc_bib_item_" y "\"/>" x)))
+ (font-style-italic
+ . ,(lambda (x) (concat "<text:span text:style-name=\"Emphasis\">" x "</text:span>")))
+ (font-style-oblique
+ . ,(lambda (x) (concat "<text:span text:style-name=\"Emphasis\">" x "</text:span>")))
+ ;; NOTE: small caps support requires the availability of the OrgSmallcaps ODT style
+ ;; this requires an addition to or replacement of the default OrgOdtStyles.xml
+ (font-variant-small-caps
+ . ,(lambda (x) (concat "<text:span text:style-name=\"OrgSmallCaps\">" x "</text:span>")))
+ (font-weight-bold
+ . ,(lambda (x) (concat "<text:span text:style-name=\"Bold\">" x "</text:span>")))
+ (text-decoration-underline
+ . ,(lambda (x) (concat "<text:span text:style-name=\"Underline\">" x "</text:span>")))
+ (vertical-align-sub
+ . ,(lambda (x) (concat "<text:span text:style-name=\"OrgSubscript\">" x "</text:span>")))
+ (vertical-align-sup
+ . ,(lambda (x)
+ (concat "<text:span text:style-name=\"OrgSuperscript\">" x "</text:span>")))
+ ;; TODO:
+ ;; - display-left-margin
+ ;; - display-right-inline
+ ;; - display-block
+ ;; - display-indent
+ ))
+
+(defun citeproc-fmt--org-odt-bib-formatter (items _bib-format)
+ "Return a html bibliography from already formatted ITEMS."
+ (mapconcat (lambda (i)
+ (concat "<text:p text:style-name=\"Text_20_body\">" i "</text:p>"))
+ items
+ "\n"))
+
+;; Define the formatters alist
+
+(defvar citeproc-fmt--formatters-alist
+ `((org-odt . ,(citeproc-formatter-create
+ :rt (citeproc-formatter-fun-create citeproc-fmt--org-odt-alist)
+ :bib #'citeproc-fmt--org-odt-bib-formatter
+ ))
+ (html . ,(citeproc-formatter-create
+ :rt (citeproc-formatter-fun-create citeproc-fmt--html-alist)
+ :bib #'citeproc-fmt--html-bib-formatter))
+ (csl-test . ,(citeproc-formatter-create
+ :rt (citeproc-formatter-fun-create citeproc-fmt--csl-test-alist)
+ :bib #'citeproc-fmt--html-bib-formatter
+ :no-external-links t))
+ (raw . ,(citeproc-formatter-create :rt #'identity :bib (lambda (x _) x)))
+ (org . ,(citeproc-formatter-create :rt #'citeproc-fmt--org-format-rt))
+ (org-latex . ,(citeproc-formatter-create
+ :rt (citeproc-formatter-fun-create citeproc-fmt--org-latex-alist)
+ :bib #'citeproc-fmt--org-latex-bib-formatter))
+ (latex . ,(citeproc-formatter-create
+ :rt (citeproc-formatter-fun-create citeproc-fmt--latex-alist)
+ :bib (lambda (x _) (concat (mapconcat #'identity x "\n\n")
+ "\\bigskip"))))
+ (plain . ,(citeproc-formatter-create :rt #'citeproc-rt-to-plain
+ :no-external-links t)))
+ "Alist mapping supported output formats to formatter structs.")
+
+(defun citeproc-formatter-for-format (format)
+ "Return the formatter struct belonging to FORMAT.
+FORMAT is a symbol"
+ (if-let ((formatter (alist-get format citeproc-fmt--formatters-alist)))
+ formatter
+ (error "No formatter for citeproc format `%s'" format)))
+
+(provide 'citeproc-formatters)
+
+;;; citeproc-formatters.el ends here
--- /dev/null
+;;; citeproc-generic-elements.el --- render generic CSL elements -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017-2021 András Simonyi
+
+;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
+
+;; 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 3 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.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Functions corresponding to the generic CSL rendering elements cs:layout,
+;; cs:group and cs:text. With the exception of `citeproc--layout' they return a
+;; (CONTENT . CONTENT-TYPE) pair, where CONTENT is the rendered rich-text output
+;; and CONTENT-TYPE is one of the symbols `text-only', `empty-vars' and
+;; `present-var.' In contrast, `citeproc--layout' returns only the rendered
+;; rich-text content.
+
+;;; Code:
+
+(require 'dash)
+(require 'let-alist)
+(require 's)
+
+(require 'citeproc-rt)
+(require 'citeproc-context)
+(require 'citeproc-macro)
+
+(defun citeproc--layout (attrs context &rest body)
+ "Render the content of a layout element with ATTRS and BODY."
+ (let* ((attrs (if (eq (citeproc-context-mode context) 'bib) attrs
+ nil)) ; No attrs if mode is cite -- they are used for citations
+ (spliced-body (citeproc-lib-splice-into body 'splice))
+ (suffix (alist-get 'suffix attrs))
+ (attrs-wo-suffix (--remove (eq (car it) 'suffix) attrs))
+ (rendered-body (--map (car it) spliced-body)))
+ ;; Handle second-field align
+ (when (and (alist-get 'second-field-align (citeproc-context-opts context))
+ (> (length rendered-body) 1))
+ (setq rendered-body `((((display . "left-margin")) ,(car rendered-body))
+ (((display . "right-inline")) ,@(cdr rendered-body)))))
+ (let* ((affix-rendered (citeproc-rt-render-affixes
+ (citeproc-rt-dedup (citeproc-rt-join-formatted attrs-wo-suffix rendered-body
+ context))))
+ (last-elt (and (listp affix-rendered) (-last-item affix-rendered)))
+ (last-display (and (consp last-elt) (car last-elt)
+ (--any-p (eq (car it) 'display) (car last-elt)))))
+ (when suffix
+ (if last-display
+ ;; If the last element has a display attribute then we have to append the
+ ;; suffix string to this last element
+ (setf (nth (1- (length affix-rendered)) affix-rendered)
+ (-snoc (-last-item affix-rendered) suffix))
+ ;; Else we simply append it to the already rendered content
+ (setq affix-rendered (if (listp affix-rendered)
+ (-snoc affix-rendered suffix)
+ (concat affix-rendered suffix)))))
+ affix-rendered)))
+
+(defun citeproc--group (attrs context &rest body)
+ "Render the content of a group element with ATTRS and BODY."
+ (-let* ((spliced-body (citeproc-lib-splice-into body 'splice))
+ (types (--map (cdr it) spliced-body))
+ (type (cond ((--all? (eq it 'text-only) types)
+ 'text-only)
+ ((--any? (eq it 'present-var) types)
+ 'present-var)
+ (t 'empty-vars))))
+ (cons (if (or (eq type 'text-only)
+ (eq type 'present-var))
+ (citeproc-rt-join-formatted attrs (--map (car it) spliced-body) context)
+ nil)
+ type)))
+
+(defconst citeproc-generic-elements--url-prefix-re "https?://\\S *\\'"
+ "Regex matching an URL prefix at the end of a string.")
+
+(defun citeproc--text (attrs context &rest _body)
+ "Render the content of a text element with ATTRS and BODY."
+ (let-alist attrs
+ (let ((content nil)
+ (type 'text-only)
+ (no-external-links (citeproc-context-no-external-links context)))
+ (cond (.value (setq content .value))
+ (.variable
+ (let ((val (citeproc-var-value (intern .variable) context (citeproc-lib-intern
+ .form))))
+ (setq content val)
+ (cond
+ (val (let ((var (intern .variable)))
+ (setq type 'present-var)
+ (push `(rendered-var . ,var) attrs)
+ (when (and (not no-external-links)
+ (memq var citeproc--linked-vars))
+ (let ((target
+ (concat
+ (alist-get var citeproc--link-prefix-alist
+ "")
+ content)))
+ (-when-let (match-pos
+ (and .prefix (s-matched-positions-all
+ citeproc-generic-elements--url-prefix-re
+ .prefix)))
+ ;; If the prefix ends with an URL then it is moved
+ ;; from the prefix to the rendered variable
+ ;; content.
+ (let ((start (caar match-pos)))
+ (setq content (concat (substring .prefix start) content))
+ (push (cons 'prefix (substring .prefix 0 start))
+ attrs)))
+ (push (cons 'href target) attrs)))))
+ ;; Don't report empty var for year-suffix, see issue #70.
+ ((not (string= .variable "year-suffix")) (setq type 'empty-vars)))))
+ (.term (setq .form (if .form (intern .form) 'long)
+ .plural (if (or (not .plural)
+ (string= .plural "false"))
+ 'single 'multiple)
+ content (let ((cont (citeproc-term-inflected-text
+ .term .form .plural context)))
+ ;; Annotate the 'no date' term as if it'd be
+ ;; the value of the 'issue' variable to
+ ;; handle implicit year suffix addition and
+ ;; suppression issues.
+ (if (string= .term "no date")
+ (progn
+ (setq type 'present-var)
+ `(((rendered-var . issued)) ,cont))
+ cont))))
+ (.macro (let ((macro-val (citeproc-macro-output .macro context)))
+ (setq content (car macro-val))
+ (setq type (cdr macro-val)))))
+ ;; We stop if only the title had to be rendered.
+ (let ((result (cons (citeproc-rt-format-single attrs content context) type)))
+ (citeproc-context-maybe-stop-rendering
+ 'title context result (or (and .variable (intern .variable)) t))))))
+
+(provide 'citeproc-generic-elements)
+
+;;; citeproc-generic-elements.el ends here
--- /dev/null
+;;; citeproc-itemdata.el --- represent and access bibliography items -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017 András Simonyi
+
+;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
+
+;; 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 3 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.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Structure type and functions to handle data about bibliography items.
+
+;;; Code:
+
+(require 'citeproc-rt)
+(require 'citeproc-context)
+
+(cl-defstruct (citeproc-itemdata (:constructor citeproc-itemdata-create))
+ "Struct for storing bibliography item data.
+VARVALS is an alist containg variable-name symbols as keys and
+ their values for the item as values,
+RAWCITE is the cached cite of the item in internal rich-text
+ format,
+RC-UPTODATE is t iff the RAWCITE field is up-to-date,
+RAWBIBITEM is the cached bibliograhy item in internal rich-text
+ format.
+SORT-KEY is the bibliography sort-key of the item,
+OCCURRED-BEFORE is used during bibliography generation to
+ indicate whether the item was referred to earlier. If the first
+ occurrence is in a note then the actual value is the
+ note-number,
+DISAMB-POS contains the position on which cite disambiguation is
+ based. Possible values are 'first, 'ibid and 'subsequent,
+SUBBIB-NOS is a list of numeric indexes of sub-bibliographies
+ in which the item occurs,
+UNCITED is t iff the item has no associated citation."
+ varvals rawcite rawbibitem rc-uptodate sort-key occurred-before
+ disamb-pos subbib-nos uncited)
+
+(defun citeproc-itd-getvar (itd var)
+ "Return itemdata ITD's value for VAR ."
+ (alist-get var (citeproc-itemdata-varvals itd)))
+
+(defun citeproc-itd-setvar (itd var val)
+ "Set itemdata ITD's value for VAR to VAL."
+ (setf (alist-get var (citeproc-itemdata-varvals itd) nil t) val
+ (citeproc-itemdata-rc-uptodate itd) nil))
+
+(defun citeproc-itd-rt-cite (itd style)
+ "Return the rich-text cite of itemdata ITD using STYLE."
+ (if (citeproc-itemdata-rc-uptodate itd)
+ (citeproc-itemdata-rawcite itd)
+ (let ((rc (citeproc-render-varlist-in-rt
+ (cons (cons 'position (citeproc-itemdata-disamb-pos itd))
+ (citeproc-itemdata-varvals itd))
+ style
+ 'cite 'display 'no-links t)))
+ (setf (citeproc-itemdata-rawcite itd) rc
+ (citeproc-itemdata-rc-uptodate itd) t)
+ rc)))
+
+(defun citeproc-itd-plain-cite (itd style)
+ "Return the plain text cite of itemdata ITD using STYLE."
+ (citeproc-rt-to-plain (citeproc-itd-rt-cite itd style)))
+
+(defun citeproc-itd-namevars (itd style)
+ "Rendered namevars in the cite of itemdata ITD using STYLE."
+ (citeproc-rt-rendered-name-vars (citeproc-itd-rt-cite itd style)))
+
+(defun citeproc-itd-nameids (itd style)
+ "Rendered name ids in the cite of itemdata ITD using STYLE."
+ (citeproc-rt-rendered-name-ids (citeproc-itd-rt-cite itd style)))
+
+(defun citeproc-itd-update-disamb-pos (itd pos)
+ "Update the highest position of ITD with position POS."
+ (let ((old (citeproc-itemdata-disamb-pos itd)))
+ (unless (eq old 'subsequent)
+ (let ((new (pcase pos
+ ('first 'first)
+ ((or 'ibid 'ibid-with-locator) 'ibid)
+ (_ 'subsequent))))
+ (setf (citeproc-itemdata-disamb-pos itd)
+ (cond ((memq old '(nil first)) new)
+ ((eq new 'subsequent) 'subsequent)
+ (t 'ibid)))))))
+
+(provide 'citeproc-itemdata)
+
+;;; citeproc-itemdata.el ends here
--- /dev/null
+;; citeproc-itemgetters.el --- functions for constructing itemgetters -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017-2021 András Simonyi
+
+;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
+
+;; 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 3 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.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Functions for constructing various types of bibliographic itemgetter
+;; functions. The returned itemgetter functions can, in turn, be used to create
+;; `citeproc-style' and `citeproc-proc' structures.
+
+;;; Code:
+
+(require 'dash)
+(require 'org)
+;; Handle the fact that org-bibtex has been renamed to ol-bibtex -- for the time
+;; being we support both feature names.
+(or (require 'ol-bibtex nil t)
+ (require 'org-bibtex))
+(require 'json)
+(require 'bibtex)
+(require 'parsebib)
+
+(require 'citeproc-bibtex)
+(require 'citeproc-biblatex)
+
+(defun citeproc-itemgetters--parsebib-buffer (entries strings)
+ "Parse a BibTeX/biblatex buffer with Parsebib."
+ ;; Note: this is needed to support different Parsebib versions in use.
+ (cond ((fboundp 'parsebib-parse-buffer)
+ (parsebib-parse-buffer entries strings t t))
+ ((fboundp 'parsebib-parse-bib-buffer)
+ (parsebib-parse-bib-buffer :entries entries :strings strings
+ :expand-strings t :inheritance t))
+ (t (error "No Parsebib buffer parsing function is available"))))
+
+(defun citeproc-hash-itemgetter-from-csl-json (file)
+ "Return a hash-based getter for csl json bibliography FILE."
+ (let* ((json-array-type 'list)
+ (json-key-type 'symbol)
+ (item-list (json-read-file file))
+ (hash (make-hash-table :test 'equal)))
+ (--each item-list
+ (puthash (alist-get 'id it) it hash))
+ (lambda (itemids) (--map (cons it (gethash it hash))
+ itemids))))
+
+(defun citeproc-itemgetter-from-csl-json (file)
+ "Return an item-getter for csl json bibliography FILE."
+ (lambda (itemids)
+ (let* ((json-array-type 'list)
+ (json-key-type 'symbol)
+ (item-list (json-read-file file))
+ result)
+ (dolist (item item-list result)
+ (let ((id (alist-get 'id item)))
+ (when (member id itemids)
+ (push (cons id item) result)))))))
+
+(defun citeproc-itemgetter-from-bibtex (file-or-files)
+ "Return a getter for BibTeX bibliography FILE-OR-FILES."
+ (if (listp file-or-files)
+ (lambda (itemids)
+ (let (result
+ (remaining-ids (cl-copy-list itemids))
+ (remaining-files file-or-files))
+ (while (and remaining-ids remaining-files)
+ (let ((file (pop remaining-files)))
+ (with-temp-buffer
+ (insert-file-contents file)
+ (goto-char (point-min))
+ (bibtex-set-dialect 'BibTeX t)
+ (bibtex-map-entries
+ (lambda (key _beg _end)
+ (when (member key itemids)
+ (push (cons key (citeproc-bt-entry-to-csl (bibtex-parse-entry)))
+ result)
+ (setq remaining-ids (delete key remaining-ids))))))))
+ result))
+ (lambda (itemids)
+ (let (result)
+ (with-temp-buffer
+ (insert-file-contents file-or-files)
+ (goto-char (point-min))
+ (bibtex-set-dialect 'BibTeX t)
+ (bibtex-map-entries
+ (lambda (key _beg _end)
+ (when (member key itemids)
+ (push (cons key (citeproc-bt-entry-to-csl (bibtex-parse-entry)))
+ result)))))
+ result))))
+
+(defun citeproc-itemgetter-from-org-bibtex (file-or-files)
+ "Return a getter for org-bibtex bibliography FILE-OR-FILES."
+ (let ((files (if (listp file-or-files)
+ file-or-files
+ (list file-or-files))))
+ (lambda (itemids)
+ (let (result)
+ (org-map-entries
+ (lambda ()
+ (-when-let (key-w-entry (citeproc-bt-from-org-headline itemids))
+ (push (cons (car key-w-entry)
+ (citeproc-bt-entry-to-csl (cdr key-w-entry)))
+ result)))
+ t files)
+ result))))
+
+(defun citeproc-hash-itemgetter-from-any (file-or-files &optional no-sentcase-wo-langid)
+ "Return a getter for FILE-OR-FILES in any supported format.
+The format is determined on the basis of file extensions.
+Supported formats:
+- CSL-JSON (.json extension) the recommended native format;
+- BibTeX/biblatex (.bib or .bibtex extension),
+- org-bibtex (.org extension).
+If NO-SENTCASE-WO-LANGID is non-nil then title fields in items
+without a `langid' field are not converted to sentence-case."
+ (let ((files (if (listp file-or-files)
+ file-or-files
+ (list file-or-files)))
+ (cache (make-hash-table :test #'equal))
+ (bt-entries (make-hash-table :test #'equal))
+ (bt-strings (make-hash-table :test #'equal)))
+ (dolist (file files)
+ (pcase (file-name-extension file)
+ ("json"
+ (let ((json-array-type 'list)
+ (json-key-type 'symbol))
+ (dolist (item (json-read-file file))
+ (puthash (cdr (assq 'id item)) item cache))))
+ ((and (or "bib" "bibtex") ext)
+ (with-temp-buffer
+ (insert-file-contents file)
+ (bibtex-set-dialect (if (string= ext "bib") 'biblatex 'BibTeX) t)
+ (citeproc-itemgetters--parsebib-buffer bt-entries bt-strings)))
+ ("org"
+ (org-map-entries
+ (lambda ()
+ (-when-let (key-w-entry (citeproc-bt-from-org-headline))
+ (condition-case err
+ (puthash (car key-w-entry) (citeproc-blt-entry-to-csl
+ (cdr key-w-entry))
+ cache)
+ (error
+ (user-error
+ "Couldn't parse the bib(la)tex entry with key '%s', the error was: %s"
+ (car key-w-entry) err)))))
+ t (list file)))
+ (ext
+ (user-error "Unknown bibliography extension: %S" ext))))
+ (maphash
+ (lambda (key entry)
+ (condition-case err
+ (puthash key (citeproc-blt-entry-to-csl entry nil no-sentcase-wo-langid)
+ cache)
+ (error
+ (user-error
+ "Couldn't parse the bib(la)tex entry with key '%s', the error was: %s"
+ key err))))
+ bt-entries)
+ (lambda (x)
+ (pcase x
+ ('itemids
+ (hash-table-keys cache))
+ ((pred listp) (mapcar (lambda (id)
+ (cons id (gethash id cache)))
+ x))
+ (_ (error "Unsupported citeproc itemgetter retrieval method"))))))
+
+(provide 'citeproc-itemgetters)
+
+;;; citeproc-itemgetters.el ends here
--- /dev/null
+;;; citeproc-lib.el --- misc functions and variables for citeproc-el -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017-2021 András Simonyi
+
+;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
+
+;; 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 3 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.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; General utility functions used in citeproc-el.
+
+;;; Code:
+
+(require 'dash)
+(require 's)
+
+(defconst citeproc--number-vars
+ '(chapter-number citation-number collection-number edition first-reference-note-number
+ issue number number-of-pages number-of-volumes page page-first
+ part-number printing-number section supplement-number version volume)
+ "CSL number variables."
+ ;; Note: `locator', which is also on the official list, is omitted because
+ ;; it's treated specially in the code.
+ )
+
+(defconst citeproc--date-vars
+ '(accessed available-date event-date issued original-date submitted locator-date)
+ "CSL date variables.")
+
+(defconst citeproc--name-vars
+ '(author chair collection-editor compiler composer container-author contributor
+ curator director editor editorial-director editor-translator executive-producer
+ guest host illustrator interviewer narrator organizer original-author
+ performer producer recipient reviewed-author script-writer series-creator
+ translator)
+ "CSL name variables.")
+
+(defconst citeproc--linked-vars
+ '(DOI PMCID PMID URL)
+ "Variables whose rendered content should be linked.
+The ordering is according to priority ")
+
+(defconst citeproc--link-prefix-alist
+ '((DOI . "https://doi.org/")
+ (PMID . "https://www.ncbi.nlm.nih.gov/pubmed/")
+ (PMCID . "https://www.ncbi.nlm.nih.gov/pmc/articles/"))
+ "Alist mapping variable names to uri prefixes.")
+
+(defun citeproc-lib-parse-xml-file (file)
+ "Return the parsed xml representation of FILE."
+ (with-temp-buffer
+ (insert-file-contents file)
+ (libxml-parse-xml-region (point-min) (point-max))))
+
+(defun citeproc-lib-remove-xml-comments (tree)
+ "Remove comments from xml TREE."
+ (let ((head (car tree))
+ (attrs (cadr tree))
+ (body (cddr tree))
+ result)
+ (while body
+ (pcase (car body)
+ ((pred atom) (push (pop body) result))
+ (`(comment . ,_) (pop body))
+ (_ (push (citeproc-lib-remove-xml-comments (pop body)) result))))
+ (let ((full-result (cons head (cons attrs (nreverse result)))))
+ ;; Handle the problem of the top element added by the libxml parser when
+ ;; there is a comment after the xml declaration.
+ (if (eq (car full-result) 'top)
+ (caddr full-result)
+ full-result))))
+
+(defun citeproc-lib-parse-html-frag (s)
+ "Return the parsed representation of html in string S."
+ (with-temp-buffer
+ (insert s)
+ (libxml-parse-html-region (point-min) (point-max))))
+
+(defun citeproc-lib-intern (s)
+ "Intern S if it is a string, return nil if it is nil."
+ (cond ((not s) nil)
+ ((stringp s) (intern s))
+ (t (error "Function citeproc-lib-intern was called with an argument that is neither string nor nil"))))
+
+(defun citeproc-lib-named-parts-to-alist (e)
+ "Collect the attrs of parsed xml element E's enclosed elements.
+The attributes are collected into an alist consisting
+of (PARTNAME . ATTRS) pairs, where PARTNAME is the value of the
+enclosed element's `name' attr"
+ (--map (cons (intern (alist-get 'name it))
+ (assq-delete-all 'name it))
+ (mapcar #'cadr (-remove #'stringp (cddr e)))))
+
+(defun citeproc-lib-lex-compare (l1 l2 cmp-fun sort-orders)
+ "Whether list L1 lexicographically precedes list L2.
+CMP-FUN is a three-valued (1, 0, -1) comparator function,
+SORT-ORDERS is a list of sort orders (see the bib- and
+cite-sort-orders slots of `citeproc-style' for details). Return t
+iff L1 is strictly ordered before L2, nil otherwise."
+ (unless sort-orders
+ (setq sort-orders (make-list (length l1) t)))
+ (let (result)
+ (while (and l1 (not result))
+ (let ((comp
+ (funcall cmp-fun (pop l1) (pop l2) (not (pop sort-orders)))))
+ (unless (= comp 0)
+ (setq result comp))))
+ (equal result 1)))
+
+(defun citeproc-lib-splice-into (list tag)
+ "Splice elements with car TAG into LIST."
+ (let (result)
+ (dolist (elt list)
+ (if (and (consp elt) (eq tag (car elt)))
+ (dolist (e (cdr elt))
+ (push e result))
+ (push elt result)))
+ (nreverse result)))
+
+(defun citeproc-lib-add-splice-tag (list tag)
+ "Add TAG as car if LIST is not a singleton.
+Return the first element if LIST is singleton."
+ (if (cdr list) (cons tag list) (car list)))
+
+(defun citeproc-lib-numeric-p (val)
+ "Return whether VAL is numeric content.
+VAL has numeric content if it is a number or a string containing
+numeric content."
+ (or (numberp val)
+ (and (stringp val)
+ (s-matches-p "\\`[[:alpha:]]?[[:digit:]]+[[:alpha:]]*\\(\\( *\\([,&-]\\|--\\) *\\)?[[:alpha:]]?[[:digit:]]+[[:alpha:]]*\\)?\\'"
+ val))))
+
+(provide 'citeproc-lib)
+
+;;; citeproc-lib.el ends here
--- /dev/null
+;; citeproc-locale.el --- CSL locale related functions -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017-2022 András Simonyi
+
+;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
+
+;; 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 3 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.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; In addition to some locale handling helpers, this file provides the function
+;; `citeproc-locale-getter-from-dir', which constructs locale getter functions
+;; that retrieve locales from a given directory.
+
+;;; Code:
+
+(require 'dash)
+(require 'f)
+(require 's)
+
+(require 'citeproc-lib)
+(require 'citeproc-term)
+
+(defconst citeproc-locale--default-variants-alist
+ '(("af" . "ZA") ("ca" . "AD") ("cs" . "CZ") ("cy" . "GB")
+ ("da" . "DK") ("en" . "US") ("el" . "GR") ("et" . "EE")
+ ("fa" . "IR") ("he" . "IR") ("ja" . "JP") ("km" . "KH")
+ ("ko" . "KR") ("nb" . "NO") ("nn" . "NO") ("sl" . "SI")
+ ("sr" . "RS") ("sv" . "SE") ("uk" . "UA") ("vi" . "VN")
+ ("zh" . "CN"))
+ "Alist mapping locales to their default variants.
+Only those locales are given for which the default variant is not
+simply the result of upcasing.")
+
+(defconst citeproc-locale--simple-locales
+ '("la" "eu" "ar")
+ "List of simple locale names (without dash).")
+
+(defun citeproc-locale--extend (loc)
+ "Extend simple locale LOC to default variant."
+ (let ((variant (assoc-default loc citeproc-locale--default-variants-alist)))
+ (concat loc "-" (or variant (s-upcase loc)))))
+
+(defun citeproc-locale--compatible-p (l1 l2)
+ "Whether locales L1 and L2 are compatible."
+ (or (not (and l1 l2))
+ (s-prefix-p l1 l2)
+ (s-prefix-p l2 l1)))
+
+(defun citeproc-locale-getter-from-dir (dir)
+ "Return a locale getter getting parsed locales from a local DIR.
+If the requested locale couldn't be read then return the parsed
+en-US locale, which must exist, and warn the user."
+ (let ((default-loc-file (f-join dir "locales-en-US.xml")))
+ (lambda (loc)
+ (let* ((ext-loc (if (or (member loc citeproc-locale--simple-locales)
+ (s-contains-p "-" loc))
+ loc
+ (citeproc-locale--extend loc)))
+ (loc-file (concat dir "/locales-" ext-loc ".xml"))
+ (loc-available (f-readable-p loc-file)))
+ (citeproc-lib-remove-xml-comments
+ (citeproc-lib-parse-xml-file
+ (if loc-available loc-file
+ (if (not (f-readable-p default-loc-file))
+ (error
+ "The default CSL locale file %s doesn't exist or is unreadable"
+ default-loc-file)
+ (display-warning
+ 'citeproc
+ (format
+ "Could not read CSL locale file %s, using the fallback en-US locale"
+ loc-file))
+ default-loc-file))))))))
+
+(defun citeproc-locale-termlist-from-xml-frag (frag)
+ "Transform xml FRAG representing citeproc--terms into a citeproc-term list."
+ (--mapcat (if (eq 'term (car it))
+ (citeproc-term--from-xml-frag (cdr it))
+ nil)
+ frag))
+
+(provide 'citeproc-locale)
+
+;;; citeproc-locale.el ends here
--- /dev/null
+;; citeproc-macro.el --- functions to render CSL macros -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017 András Simonyi
+
+;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
+
+;; 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 3 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.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Functions to render the output of CSL macros.
+
+;;; Code:
+
+(require 'citeproc-lib)
+(require 'citeproc-rt)
+(require 'citeproc-context)
+
+;;; For macro evaluation
+(defun citeproc--macro (attrs context &rest body)
+ "Render the content of a macro element with ATTRS and BODY."
+ (let* ((spliced-body (citeproc-lib-splice-into body 'splice))
+ (val (citeproc-rt-typed-join attrs spliced-body context)))
+ (if (eq 'empty-vars (cdr val))
+ (cons nil 'text-only)
+ val)))
+
+(defun citeproc-macro-output (macro context)
+ "Return the output of MACRO.
+MACRO is the macro's name as a string and the returned value is a
+(RICH-TEXT-CONTENT . CONTENT-TYPE) cons cell."
+ (let ((macro-fun (assoc-default macro (citeproc-context-macros context))))
+ (if macro-fun
+ (funcall macro-fun context)
+ (error "There is no macro called `%s' in style" macro))))
+
+(defun citeproc-macro-output-as-text (macro context)
+ "Return the output of MACRO as plain text.
+MACRO is the macro's name as a string."
+ (citeproc-rt-to-plain (citeproc-rt-render-affixes
+ (car (citeproc-macro-output macro context)))))
+
+(provide 'citeproc-macro)
+
+;;; citeproc-macro.el ends here
--- /dev/null
+;;; citeproc-name.el --- CSL name and label rendering -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017 András Simonyi
+
+;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
+
+;; 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 3 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.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Functions to render CSL name and label elements.
+
+;;; Code:
+
+(require 'subr-x)
+(require 'let-alist)
+(require 'dash)
+(require 's)
+
+(require 'citeproc-lib)
+(require 'citeproc-s)
+(require 'citeproc-rt)
+(require 'citeproc-context)
+(require 'citeproc-term)
+
+(defvar citeproc-name-postprocess-functions nil
+ "A list of functions to postprocess rendered names.
+Each function takes three arguments:
+- the rich-text rendering of a name to be post-processed,
+- the rendered name as an alist with CSL name-part
+ keys (`family', `given' etc.), and
+- the rendering context, as a `citeproc-context' structure.
+The output of each function should be the post-processed
+rich-text, and the functions are applied in the order they appear
+in the list.")
+
+;; OPTIMIZE: Name count could be sped up by only counting the names to be
+;; rendered without actually rendering them
+(defun citeproc-name-render-vars
+ (varstring attrs name-attrs name-part-attrs et-al-attrs with-label
+ label-before-names label-attrs context)
+ "Render namevars contained in VARSTRING according to the given attrs.
+VARSTRING is a string containing variable names separated by
+spaces. Labels are also rendered (with formatting according to
+LABEL-ATTRS) if WITH-LABEL is t."
+ (let* ((vars (-map 'intern (s-split " " varstring)))
+ (present-vars (--filter (citeproc-var-value it context) vars))
+ ed-trans)
+ (when (and (memq 'editor present-vars)
+ (memq 'translator present-vars)
+ (= 2 (length present-vars))
+ (equal (--map (alist-get 'name-id it)
+ (citeproc-var-value 'editor context))
+ (--map (alist-get 'name-id it)
+ (citeproc-var-value 'translator context))))
+ (setq present-vars '(editor)
+ ed-trans t))
+ (unless (alist-get 'delimiter attrs)
+ (-when-let (names-delim (alist-get 'names-delimiter (citeproc-context-opts context)))
+ (push (cons 'delimiter names-delim) attrs)))
+ (if present-vars
+ (cons (citeproc-rt-join-formatted
+ attrs
+ (--map (citeproc-name--render-var it name-attrs name-part-attrs
+ et-al-attrs with-label
+ label-before-names
+ label-attrs
+ context
+ ed-trans)
+ present-vars)
+ context)
+ 'present-var)
+ (cons nil 'empty-vars))))
+
+(defun citeproc-name--render-var (var attrs name-part-attrs et-al-attrs with-label
+ label-before-names
+ label-attrs context &optional ed-trans)
+ "Render the value of csl name variable VAR according to given attrs.
+VAR is a symbol.
+
+Note: The label (if there is one) is prepended to the name(s) if
+the form is verb and also when the label element was before the
+names element in the style. The latter is not allowed in the
+standard, so can be considered an extension. It's supported
+because some styles rely on it, notably that of the journal
+Nature."
+ ;; Push the current add-names offset for VAR to the ATTRS
+ (-when-let (add-names-alist (citeproc-var-value 'add-names context))
+ (-when-let (add-names-val (alist-get var add-names-alist))
+ (push `(add-names . ,add-names-val) attrs)))
+ (let* ((var-value (citeproc-var-value var context))
+ (rendered-names (citeproc-name--render-names
+ var-value attrs et-al-attrs name-part-attrs
+ context)))
+ (when (atom rendered-names) (setq rendered-names (list nil rendered-names)))
+ (push (list 'rendered-names) (car rendered-names))
+ (push `(variable . ,(if ed-trans "editortranslator" (symbol-name var)))
+ label-attrs)
+ (let ((plural-val (alist-get 'plural label-attrs)))
+ (when (or (not plural-val) (string= plural-val "contextual"))
+ (push `(plural . ,(if (> (length var-value) 1) "always" "never"))
+ label-attrs)))
+ (if with-label
+ (let ((rendered-label (car (citeproc--label label-attrs context))))
+ (citeproc-rt-join-formatted `((rendered-var . ,var))
+ (if label-before-names
+ (list rendered-label rendered-names)
+ (list rendered-names rendered-label))
+ context))
+ (push (cons 'rendered-var var) (car rendered-names))
+ rendered-names)))
+
+(defun citeproc-name--render-names (names attrs et-al-attrs name-part-attrs context)
+ "Render NAMES according to the given attrs."
+ (let* ((all-attrs (-concat attrs (citeproc-context-opts context)))
+ (rmode (citeproc-context-render-mode context))
+ (sort-o (if (eq rmode 'sort) "all" ;; special setting for sort mode
+ (alist-get 'name-as-sort-order all-attrs)))
+ (names-count (length names))
+ (formatted-first (citeproc-name--render (car names) attrs name-part-attrs
+ sort-o context)))
+ (if (= 1 names-count) formatted-first
+ (let-alist all-attrs
+ (let ((delimiter (or .delimiter .name-delimiter ", "))
+ (add-names (or .add-names 0))
+ (position (citeproc-var-value 'position context)))
+ (unless (or (null position) (eq position 'first))
+ (setq .et-al-min (or .et-al-subsequent-min .et-al-min)
+ .et-al-use-first (or .et-al-subsequent-use-first .et-al-use-first)))
+ (setq .et-al-min (or .names-min .et-al-min)
+ .et-al-use-first (or .names-use-first .et-al-use-first)
+ .et-al-use-last (or (string= .names-use-last "true")
+ (string= .et-al-use-last "true")))
+ (let* ((et-al-min-val
+ ;; If et-al should be ignored then we set this to an unreachable number.
+ (if (alist-get 'ignore-et-al (citeproc-context-vars context))
+ 100
+ (citeproc-s-nil-or-s-to-num .et-al-min)))
+ (et-al-use-first-val (+ add-names
+ (citeproc-s-nil-or-s-to-num .et-al-use-first)))
+ (et-al (and .et-al-min .et-al-use-first
+ (>= names-count et-al-min-val)
+ (< et-al-use-first-val names-count)))
+ (middle-end-pos (if et-al et-al-use-first-val (- names-count 1)))
+ (sort-o-latters (string= sort-o "all"))
+ (formatted-middle
+ (if (< middle-end-pos 2)
+ nil
+ (citeproc-rt-join-formatted
+ `((delimiter . ,delimiter) (prefix . ,delimiter))
+ (--map (citeproc-name--render it attrs name-part-attrs
+ sort-o-latters context)
+ (-slice names 1 middle-end-pos))
+ context)))
+ (last-after-inverted (or sort-o-latters
+ (and (string= sort-o "first")
+ (null formatted-middle))))
+ (last-delim (citeproc-lib-intern (if et-al .delimiter-precedes-et-al
+ .delimiter-precedes-last)))
+ (last-pref (if (or (and (or (not last-delim) (eq last-delim 'contextual))
+ (> middle-end-pos 1))
+ (eq last-delim 'always)
+ (and (eq last-delim 'after-inverted-name)
+ last-after-inverted))
+ delimiter
+ " "))
+ (formatted-last
+ (cond (et-al (if .et-al-use-last
+ (citeproc-rt-join-formatted
+ nil
+ (list
+ delimiter "… "
+ (citeproc-name--render (-last-item names)
+ attrs name-part-attrs
+ sort-o-latters context))
+ context)
+ (citeproc-name--render-et-al (cons `(prefix . ,last-pref)
+ et-al-attrs)
+ context)))
+ (.and
+ (let ((and-str (if (string= .and "text")
+ (citeproc-term-get-text "and" context)
+ "&")))
+ (citeproc-rt-join-formatted
+ `((prefix . ,last-pref))
+ (list and-str " "
+ (citeproc-name--render
+ (-last-item names) attrs
+ name-part-attrs sort-o-latters context))
+ context)))
+ (t
+ (citeproc-rt-join-formatted
+ nil
+ (list delimiter
+ (citeproc-name--render (-last-item names)
+ attrs name-part-attrs
+ sort-o-latters context))
+ context)))))
+ (citeproc-rt-join-formatted
+ (--remove (eq 'delimiter (car it)) attrs)
+ (list formatted-first formatted-middle formatted-last)
+ context)))))))
+
+(defun citeproc-name--render (name attrs name-part-attrs sort-o context)
+ "Render NAME according to the given attributes."
+ (let* ((format-attrs
+ (--filter (memq (car it) (-concat '(prefix suffix) citeproc-rt-format-attrs))
+ attrs))
+ (result (citeproc-rt-format-single
+ (cons `(name-id . ,(alist-get 'name-id name)) format-attrs)
+ (citeproc-name--render-formatted
+ (citeproc-name--format-nameparts name name-part-attrs context)
+ attrs sort-o context)
+ context)))
+ (dolist (fn citeproc-name-postprocess-functions)
+ (setq result (funcall fn result name context)))
+ result))
+
+(defun citeproc-name--parts-w-sep (c1 c2 sep context)
+ "Join name-parts in lists C1 C2 with spaces and then with SEP."
+ (let ((joined-c1 (citeproc-rt-join-formatted '((delimiter . " ")) c1 context)))
+ (if (-none-p 'cadr c2)
+ joined-c1
+ (citeproc-rt-join-formatted
+ `((delimiter . ,sep))
+ (list joined-c1
+ (citeproc-rt-join-formatted '((delimiter . " ")) c2 context))
+ context))))
+
+(defun citeproc-name--render-formatted (name-alist attrs sort-o context)
+ "Render formatted name described by NAME-ALIST according to ATTRS.
+NAME-ALIST is an alist with symbol keys corresponding to
+name-parts like `family' etc. and values are simple rich-text
+contents of the form (ATTRS CONTENT) where content must be a
+single string. SORT-O is a boolean determining whether to use
+sort order."
+ (-let* ((global-opts (citeproc-context-opts context))
+ ((&alist 'family f
+ 'given g-uninited
+ 'suffix s
+ 'dropping-particle d
+ 'non-dropping-particle n
+ 'name-id nid)
+ name-alist)
+ ((&alist 'sort-separator sort-sep
+ 'initialize init
+ 'initialize-with init-with
+ 'form form
+ 'name-form name-form)
+ (-concat attrs global-opts))
+ (sort-sep (or sort-sep ", "))
+ (init (not (string= init "false")))
+ (d-n-d (intern (alist-get 'demote-non-dropping-particle global-opts)))
+ (id (cadr nid))
+ (show-given (citeproc-name-show-givenname-level id context))
+ (form (if show-given 'long
+ (intern (or form name-form "long"))))
+ (rmode (citeproc-context-render-mode context)))
+ (if (citeproc-name--lat-cyr-greek-p name-alist)
+ (let ((g
+ (cond ((or (null g-uninited)
+ (and show-given (= show-given 2)))
+ g-uninited)
+ ((and init-with init)
+ (list (citeproc-rt-attrs g-uninited)
+ (citeproc-name--initialize
+ (citeproc-rt-first-content g-uninited)
+ init-with
+ (string= "false"
+ (alist-get 'initialize-with-hyphen
+ global-opts)))))
+ (init-with
+ (list (citeproc-rt-attrs g-uninited)
+ (citeproc-name--initials-add-suffix
+ init-with
+ (citeproc-rt-first-content g-uninited))))
+ (t g-uninited))))
+ (if (eq form 'long)
+ (if sort-o
+ (if (or (eq d-n-d 'never)
+ (and (eq d-n-d 'sort-only) (eq rmode 'display)))
+ (citeproc-name--parts-w-sep
+ (citeproc-name--conc-nps n f) (list g d s) sort-sep
+ context)
+ (citeproc-name--parts-w-sep (list f) (list g d n s) sort-sep context))
+ (citeproc-rt-join-formatted
+ '((delimiter . " ")) `(,g ,@(citeproc-name--conc-nps
+ d n f) ,s)
+ context))
+ (citeproc-rt-join-formatted
+ '((delimiter . " ")) (citeproc-name--conc-nps n f) context)))
+ (if (eq form 'long)
+ (citeproc-rt-join-formatted '((delimiter . " ")) (list f g-uninited) context)
+ f))))
+
+(defun citeproc-name--conc-nps (&rest nps)
+ "Concatenate particles in name-parts NPS if they end with apostrophe."
+ (let ((nonnils (delq nil nps)))
+ (if (cdr nonnils)
+ (let* ((len (length nonnils))
+ (particle (nth (- len 2) nonnils))
+ (particle-str (if (listp particle) (cadr particle) particle)))
+ (if (string= "ʼ" (substring particle-str -1))
+ (let* ((family (car (last nonnils)))
+ (result (list (list nil particle family))))
+ (when (> 2 len) (push (car nonnils) result))
+ result)
+ nonnils))
+ nonnils)))
+
+(defun citeproc-name--lat-cyr-greek-p (name-alist)
+ "Return t if NAME-ALIST is cyrillic/latin/greek and nil otherwise.
+NAME-ALIST is like in `citeproc-name--render-formatted'"
+ (--all-p (or (not (stringp it)) (string-match "^\\(\\cl\\|\\cy\\|\\cg\\|ʼ\\)*$"
+ it))
+ (-map (lambda (x)
+ (if (listp (cdr x)) (cl-caddr x)
+ (cdr x)))
+ name-alist)))
+
+(defun citeproc-name--initialize (names suffix &optional remove-hyphens)
+ "Initialize NAMES and add SUFFIX.
+NAMES is a string containing one or more space-separated names,
+while SUFFIX is either nil or a string (e.g. \".\"). If the
+optional REMOVE-HYPHENS is non-nil then don't keep hyphens
+between initalized given names, e.g., initialize Jean-Paul to
+J.P. instead of the default J.-P."
+ (let ((trimmed-suffix (s-trim suffix)))
+ (concat (s-join
+ suffix
+ (--map
+ (if (s-match "-" it)
+ (citeproc-name--initialize-hyphenated it suffix remove-hyphens)
+ (s-left 1 it))
+ (s-split " +" names)))
+ trimmed-suffix)))
+
+(defun citeproc-name--initialize-hyphenated (name suffix &optional remove-hyphens)
+ "Initialize space-less but hyphenated NAME with SUFFIX.
+If the optional REMOVE-HYPHENS is non-nil then don't keep hyphens
+between the initalized given names, e.g., initialize Jean-Paul to
+J.P. instead of the default J.-P."
+ (let ((inner-suffix (s-trim suffix)))
+ (s-join (if remove-hyphens inner-suffix
+ (concat inner-suffix "-"))
+ (--map (s-left 1 it)
+ (s-split "-" name)))))
+
+(defun citeproc-name--initials-add-suffix (suffix names)
+ "Add SUFFIX to initials in NAMES.
+NAMES is a string containing one or more space-separated names,
+while SUFFIX is a string (e.g. \".\")."
+ (let ((suffix (s-trim suffix)))
+ (mapconcat (lambda (x)
+ (if (and (cdr x) (s-match "^[[:alpha:]]$" (car x)))
+ (concat (car x) suffix)
+ (car x)))
+ (citeproc-s-slice-by-matches names "[ \\-]" 0 t)
+ "")))
+
+(defun citeproc-name--format-nameparts (name-alist name-part-attrs context)
+ "Format nameparts in NAME-ALIST according to NAME-PART-ATTRS.
+Return a new name alist containg the same keys with formatted
+contents."
+ (-let (((&alist 'given given-attrs
+ 'family family-attrs)
+ name-part-attrs))
+ (--map (-let (((n-part . content) it))
+ (cons n-part
+ (cond ((and given-attrs
+ (memq n-part '(given dropping-particle)))
+ (citeproc-rt-format-single given-attrs content context))
+ ((and family-attrs
+ (memq n-part '(family non-dropping-particle)))
+ (citeproc-rt-format-single family-attrs content context))
+ (t (list nil content)))))
+ name-alist)))
+
+(defun citeproc-name--render-et-al (attrs context)
+ "Render the `et al' part of a name acc. to ATTRS."
+ (let ((rmode (citeproc-context-render-mode context)))
+ (if (eq rmode 'sort) ""
+ (let ((term (or (alist-get 'term attrs)
+ "et-al")))
+ (citeproc-rt-format-single attrs
+ (citeproc-term-get-text term context)
+ context)))))
+
+(defun citeproc-name-show-givenname-level (id context)
+ "Return the disambiguation level of name with ID."
+ (alist-get id (alist-get 'show-given-names (citeproc-context-vars context))))
+
+(defun citeproc--var-plural-p (var context)
+ "Return whether the content of variable VAR is plural.
+VAR is a symbol."
+ (let ((content (citeproc-rt-to-plain (citeproc-var-value var context))))
+ (if (or (string= var "number-of-pages")
+ (string= var "number-of-volumes"))
+ (> (string-to-number content) 1)
+ (string-match-p
+ (concat "[[:digit:]] *\\([-,;–&—―]+\\|[,;]? *"
+ (citeproc-term-get-text "and" context)
+ "\\) *[a-zA-Z]?[[:digit:]]")
+ content))))
+
+(defun citeproc--label (attrs context &rest _body)
+ "Render a CSL label element with the given ATTRS in CONTEXT."
+ (-let* (((&alist 'variable variable
+ 'form form
+ 'plural plural)
+ attrs)
+ (label (intern variable))
+ (number nil))
+ (if (or (eq label 'editortranslator)
+ (and label (citeproc-var-value label context)))
+ (progn
+ (if form (setq form (intern form))
+ (setq form 'long))
+ (when (string= variable "locator")
+ (setq variable (citeproc-locator-label context)))
+ (cond ((string= plural "never") (setq number 'single))
+ ((string= plural "always") (setq number 'multiple))
+ (t (setq number
+ (if (citeproc--var-plural-p label context)
+ 'multiple
+ 'single))))
+ ;; Add rendered locator label info in cite mode.
+ (when (and (eq label 'locator)
+ (eq (citeproc-context-mode context) 'cite))
+ (push '(rendered-locator-label . t) attrs))
+ (cons (citeproc-rt-format-single attrs (citeproc-term-inflected-text
+ variable form number context)
+ context)
+ 'text-only))
+ (cons nil 'text-only))))
+
+(provide 'citeproc-name)
+
+;;; citeproc-name.el ends here
--- /dev/null
+;;; citeproc-number.el --- render CSL number elements -*- lexical-binding: t; -*-
+
+;; Copyright "(C) 2017 András Simonyi
+
+;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
+
+;; 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 3 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.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Functions to render CSL number elements.
+
+;;; Code:
+
+(require 'subr-x)
+(require 'rst)
+(require 's)
+
+(require 'citeproc-context)
+(require 'citeproc-lib)
+(require 'citeproc-s)
+(require 'citeproc-rt)
+
+(defun citeproc-number-extract (val)
+ "Return the parse of string VAL holding numeric content."
+ (cdr (s-match
+ "\\`\\([[:alpha:]]?[[:digit:]]+[[:alpha:]]*\\)\\(?:\\(?: *\\([,&-–—―]\\|--\\) *\\)\\([[:alpha:]]?[[:digit:]]+[[:alpha:]]*\\)\\)?\\'"
+ val)))
+
+(defun citeproc--number (attrs context &rest _body)
+ "Render a cs:number element with the given ATTRS in CONTEXT."
+ (-let* (((&alist 'variable var
+ 'form form)
+ attrs)
+ (variable (intern var))
+ (value (citeproc-var-value variable context))
+ (form (citeproc-lib-intern form)))
+ (if (not value)
+ (cons nil 'empty-var)
+ (let ((result-attrs
+ (cons `(rendered-var . ,variable) attrs))
+ (result-cont
+ (citeproc-number-var-value value variable form context)))
+ (cons (citeproc-rt-format-single result-attrs result-cont context)
+ 'present-var)))))
+
+(defconst citeproc--format-numsep-alist
+ '(("&" . " & ")
+ ("," . ", ")
+ ("-" . "-")
+ ("--" . "-")
+ ("—" . "-")
+ ("―" . "-"))
+ "Alist specifying the proper formatting of number-pair separators.")
+
+(defun citeproc-number-var-value (value variable form context)
+ "Return the numeric VALUE of VARIABLE formatted in FORM.
+VARIABLE is a symbol."
+ (cond ((not value) nil)
+ ((numberp value) (number-to-string value))
+ (t (--if-let (citeproc-number-extract value)
+ (let ((formatted-first
+ (citeproc-number--format (car it) form variable context)))
+ (if (> (length it) 1)
+ (concat
+ formatted-first
+ (assoc-default (cadr it) citeproc--format-numsep-alist)
+ (citeproc-number--format (cl-caddr it) form variable context))
+ formatted-first))
+ value))))
+
+(defun citeproc-number--format (s form term context)
+ "Render the number in string S for TERM in format FORM."
+ (if (s-matches-p "[[:alpha:]]" s) s
+ (pcase form
+ ('roman (downcase (rst-arabic-to-roman (string-to-number s))))
+ ('ordinal (citeproc-number--format-as-ordinal s term context))
+ ('long-ordinal (citeproc-number--format-as-long-ordinal s term context))
+ (_ s))))
+
+(defun citeproc-number--format-as-ordinal (s term context)
+ "Format numeric string S as ordinal agreeing with TERM."
+ (let* ((terms (citeproc-context-terms context))
+ (padded (if (= 1 (length s))
+ (concat "0" s)
+ s))
+ (gender (citeproc-term-get-gender term context))
+ (matches
+ (--filter (and (string= (s-left 8 (citeproc-term-name it)) "ordinal-")
+ (citeproc-number--ordinal-matches-p padded gender it))
+ terms))
+ (suffix
+ (citeproc-term-text
+ (if (not matches)
+ (-when-let (ordinal-matches
+ (--filter (string= (citeproc-term-name it) "ordinal")
+ terms))
+ (-if-let (match (--first (eq (citeproc-term-gender-form it) gender)
+ ordinal-matches))
+ match
+ (car ordinal-matches)))
+ (let ((first-term (car matches)))
+ (-if-let (second-term (cadr matches))
+ (if (= (elt (citeproc-term-name first-term) 8) ?0)
+ second-term
+ first-term)
+ first-term))))))
+ (concat s suffix)))
+
+(defconst citeproc-number--ordinal-match-alist
+ '((last-two-digits . 2)
+ (last-digit . 1)
+ (whole-number . nil))
+ "Alist mapping ordinal match attributes to the required match lengths.")
+
+(defun citeproc-number--ordinal-matches-p (s gender ord-term)
+ "Whether S term with GENDER matches ordinal-term ORD-TERM."
+ (and (eq gender (citeproc-term-gender-form ord-term))
+ (let ((match (citeproc-term-match ord-term))
+ (term-num (s-right 2 (citeproc-term-name ord-term))))
+ (unless match
+ (setq match
+ (if (= (elt (citeproc-term-name ord-term) 8) ?0)
+ 'last-digit
+ 'last-two-digits)))
+ (let ((l (assoc-default match citeproc-number--ordinal-match-alist)))
+ (string= (citeproc-s-tail s l)
+ (citeproc-s-tail term-num l))))))
+
+(defun citeproc-number--format-as-long-ordinal (s term context)
+ "Format numeric string S as a long ordinal agreeing with TERM."
+ (let ((num-val (string-to-number s)))
+ (if (> num-val 10)
+ (citeproc-number--format-as-ordinal s term context)
+ (when (= 1 (length s)) (setq s (concat "0" s)))
+ (let* ((name (concat "long-ordinal-" s))
+ (gender (citeproc-term-get-gender term context))
+ (match (--first (and (string= (citeproc-term-name it) name)
+ (eq (citeproc-term-gender-form it) gender))
+ (citeproc-context-terms context))))
+ (if match
+ (citeproc-term-text match)
+ (citeproc-term-get-text name context))))))
+
+(provide 'citeproc-number)
+
+;;; citeproc-number ends here
--- /dev/null
+;; -*- no-byte-compile: t; lexical-binding: nil -*-
+(define-package "citeproc" "20260113.1047"
+ "A CSL 1.0.2 Citation Processor."
+ '((emacs "26")
+ (dash "2.13.0")
+ (s "1.12.0")
+ (f "0.18.0")
+ (queue "0.2")
+ (string-inflection "1.0")
+ (org "9")
+ (parsebib "2.4")
+ (compat "28.1"))
+ :url "https://github.com/andras-simonyi/citeproc-el"
+ :commit "4bde999a41803fe519ea80eab8b813d53503eebd"
+ :revdesc "4bde999a4180"
+ :keywords '("bib")
+ :authors '(("András Simonyi" . "andras.simonyiNOSPAMgmail.com"))
+ :maintainers '(("András Simonyi" . "andras.simonyiNOSPAMgmail.com")))
--- /dev/null
+;;; citeproc-prange.el --- page-range rendering -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017 András Simonyi
+
+;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
+
+;; 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 3 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.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Functions to render CSL page-ranges.
+
+;;; Code:
+
+(require 'citeproc-s)
+
+(defun citeproc-prange--end-significant (start end len)
+ "Return the significant digits of the end in page range START END.
+START and END are strings of equal length containing integers. If
+the significant part of END is shorter than LEN then add
+insignificant digits from END until the string is LEN long or
+there are no more digits left."
+ (let ((first (min (max 1 (1+ (- (length end) len)))
+ (abs (compare-strings start nil nil end nil nil)))))
+ (substring end (1- first))))
+
+(defun citeproc-prange--end-complete (start end len)
+ "Complete the closing form of a START END pagerange to LEN."
+ (citeproc-prange--end-significant start (citeproc-s-fill-copy end start) len))
+
+(defun citeproc-prange--end-expanded (_start end end-pref)
+ "Render the end of range _START END in `expanded' format.
+END-PREF is an optional non-numeric prefix preceding END. All
+arguments are strings, END has the same length as START."
+ (concat end-pref end))
+
+(defun citeproc-prange--end-minimal (start end _end-pref)
+ "Render the end of range START END in `minimal' format.
+END-PREFIX is an optional non-numeric prefix preceding END. All
+arguments are strings, END has the same length as START."
+ (citeproc-prange--end-significant start end 1))
+
+(defun citeproc-prange--end-minimal-two (start end _end-pref)
+ "Render the end of range START END in `minimal-two' format.
+END-PREFIX is an optional non-numeric prefix preceding END. All
+arguments are strings, END has the same length as START."
+ (citeproc-prange--end-significant start end 2))
+
+(defun citeproc-prange--end-chicago (start end _end-pref &optional 15th-ed)
+ "Render the end of range START END in `chicago' format.
+END-PREFIX is an optional non-numeric prefix preceding END. All
+arguments are strings, END has the same length as START. If
+optional 15TH-ED is non-nil then use the special 4digit rule of
+the 15th edition."
+ (let ((len (length start)))
+ (cond ((or (< len 3) (string= (substring start -2) "00"))
+ end)
+ ((string= (substring start -2 -1) "0")
+ (citeproc-prange--end-significant start end 1))
+ ((and 15th-ed (= 4 (length start)))
+ (let ((min-two (citeproc-prange--end-significant start end 2)))
+ (if (> (length min-two) 2) end min-two)))
+ (t (citeproc-prange--end-significant start end 2)))))
+
+(defconst citeproc-prange-formatters-alist
+ `((chicago . ,(lambda (start end end-pref)
+ (citeproc-prange--end-chicago start end end-pref t)))
+ (chicago-15 . ,(lambda (start end end-pref)
+ (citeproc-prange--end-chicago start end end-pref t)))
+ (chicago-16 . citeproc-prange--end-chicago)
+ (minimal . citeproc-prange--end-minimal)
+ (minimal-two . citeproc-prange--end-minimal-two)
+ (expanded . citeproc-prange--end-expanded))
+ "Alist mapping page range formats to formatter functions.")
+
+(defun citeproc-prange-render (p format sep)
+ "Render page range P in FORMAT with separator SEP."
+ (with-temp-buffer
+ (insert p)
+ (goto-char 0)
+ (while (search-forward-regexp
+ "\\([[:digit:]]*[[:alpha:]]\\)?\\([[:digit:]]+\\)\\( ?\\)\\([-–—]+\\)\\( ?\\)\\([[:digit:]]*[[:alpha:]]\\)?\\([[:digit:]]+\\)"
+ nil t)
+ (let* ((start-pref (match-string 1))
+ (start-num (match-string 2))
+ (orig-dash (match-string 4))
+ (orig-sep (concat (match-string 3) orig-dash (match-string 5)))
+ (end-pref (match-string 6))
+ (end-num (match-string 7))
+ (end (concat end-pref end-num))
+ (old-sep-w-end (concat orig-sep end))
+ ;; Note: To conform with the official CSL tests we don't replace the separating
+ ;; dash with SEP if collapse cannot be applied because of incompatible prefixes
+ ;; but we still remove spaces surrounding the dash. It would make far more
+ ;; sense to replace the dash as well.
+ (new-sep-w-end (cond ((not (string= start-pref end-pref))
+ (concat orig-dash end))
+ ;; Deal with degenerate single page "ranges"
+ ((string= start-num end-num)
+ "")
+ ((or (not format) (> (length end-num) (length start-num)))
+ (concat sep end))
+ (t (concat
+ sep
+ (funcall (alist-get format
+ citeproc-prange-formatters-alist)
+ start-num
+ (citeproc-s-fill-copy end-num start-num)
+ end-pref))))))
+ (unless (string-equal new-sep-w-end old-sep-w-end)
+ (delete-char (- (length old-sep-w-end)))
+ (insert new-sep-w-end))))
+ (buffer-string)))
+
+(provide 'citeproc-prange)
+
+;;; citeproc-prange.el ends here
--- /dev/null
+;;; citeproc-proc.el --- construct and manage citation processors -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017 András Simonyi
+
+;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
+
+;; 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 3 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.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Structure type and functions to construct citation processor objects, add or
+;; clear stored bibliography items, and disambiguate and finalize the rendering
+;; of the stored items.
+
+;;; Code:
+
+(require 'subr-x)
+(require 'dash)
+(require 'cl-lib)
+(require 'queue)
+(require 's)
+
+(require 'citeproc-date)
+(require 'citeproc-itemdata)
+(require 'citeproc-disamb)
+
+(cl-defstruct (citeproc-proc (:constructor citeproc-proc--create))
+ "Citation processor struct.
+STYLE is a `citeproc-style' struct,
+GETTER is a bibliography item getter,
+ITEMDATA is a hash table that maps itemids to `citeproc-itemdata'
+ structs,
+CITATIONS is a queue containing citations,
+NAMES is hash table that maps name alists to ids,
+FINALIZED is non-nil iff the processor is finalized
+ (bibliography items are properly sorted, citation positions are
+ updated etc),
+UNCITED is a list of lists of uncited itemids to be added during
+ finalization,
+BIB-FILTERS is a list of filters defining sub-bibliographies."
+ style getter itemdata citations names finalized uncited bib-filters)
+
+(defun citeproc-proc--internalize-name (name proc)
+ "Find or add name-alist NAME in/to the names stored in PROC.
+Return an internalized version which contains the name-id, and is
+sorted."
+ (let* ((sorted (sort name (lambda (x y)
+ (string< (car x) (car y)))))
+ (names (citeproc-proc-names proc))
+ (val (gethash sorted names)))
+ (cons (cons 'name-id
+ (or val (puthash sorted (hash-table-count names) names)))
+ sorted)))
+
+(defconst citeproc-proc--nonstd-csl-vars-alist
+ '((shortTitle . title-short) (journalAbbreviation . container-title-short))
+ "Alist mapping non-standard citeproc.js vars to their standard CSL peers.")
+
+(defun citeproc-proc--internalize-item (proc item)
+ "Return the internal form of a CSL json ITEM for PROC."
+ (let* (label
+ page-first
+ (result
+ (--map
+ (let* ((orig-var (car it))
+ (var (-if-let (mapped (alist-get orig-var
+ citeproc-proc--nonstd-csl-vars-alist))
+ mapped
+ orig-var))
+ (value (citeproc-proc--parse-csl-var-val (cdr it) var proc)))
+ (pcase var
+ ('page (-when-let (page-first-match (s-match "[[:digit:]]+" value))
+ (setq page-first (car page-first-match))))
+ ('label (setq label t)))
+ (cons var value))
+ item)))
+ (when page-first (push (cons 'page-first page-first) result))
+ (unless label (push (cons 'label "page") result))
+ ;; Generate the editor-translator variable if needed
+ ;; (required by CSL 1.02)
+ (when-let* (((null (alist-get 'editor-translator result)))
+ (editor (alist-get 'editor result))
+ (translator (alist-get 'translator result))
+ ((string= (alist-get 'name-id editor)
+ (alist-get 'name-id translator))))
+ (push (cons 'editor-translator editor) result))
+ result))
+
+(defun citeproc-proc--put-item (proc item itemid &optional uncited)
+ "Put parsed csl-json ITEM with ITEMID into PROC.
+Return the added itemdata structure."
+ (let* ((int-vars (citeproc-proc--internalize-item proc item))
+ (itemdata (citeproc-itemdata-create :varvals int-vars :uncited uncited)))
+ (citeproc-proc-put-itd-put itemid itemdata proc)
+ (citeproc-itd-setvar itemdata 'citation-number
+ (number-to-string (hash-table-count
+ (citeproc-proc-itemdata proc))))
+ (setf (citeproc-proc-finalized proc) nil)
+ itemdata))
+
+(defun citeproc-proc-put-item-by-id (proc itemid)
+ "Put item with ITEMID into the itemlist of PROC.
+Return the itemdata struct that was added."
+ (let ((item (cdar (funcall (citeproc-proc-getter proc)
+ (list itemid)))))
+ (citeproc-proc--put-item proc
+ (or item `((unprocessed-with-id . ,itemid)))
+ itemid)))
+
+(defun citeproc-proc-put-items-by-id (proc itemids)
+ "Add items with ITEMIDS into the itemlist of PROC."
+ (let* ((received (funcall (citeproc-proc-getter proc) itemids))
+ ;; OPTIMIZE: putting the received items into the original order could/should be
+ ;; made more efficient
+ (items (--map (cons it (assoc-default it received))
+ itemids)))
+ (cl-loop for (itemid . item) in items do
+ (citeproc-proc--put-item proc
+ (or item `((unprocessed-with-id . ,itemid)))
+ itemid))))
+
+(defun citeproc-proc-put-itd-put (id data proc)
+ "Put the DATA of item with ID in processor PROC."
+ (let ((itemdata (citeproc-proc-itemdata proc)))
+ (puthash id data itemdata)))
+
+(defun citeproc-proc-process-uncited (proc)
+ "Add uncited items to the itemdata in PROC."
+ (when-let ((unciteds (citeproc-proc-uncited proc)))
+ (let* ((itemids (cl-delete-duplicates (apply #'append unciteds))))
+ (when (member "*" itemids)
+ (setq itemids (funcall (citeproc-proc-getter proc) 'itemids)))
+ (let* ((itemdata (citeproc-proc-itemdata proc))
+ (new-ids (--remove (gethash it itemdata) itemids))
+ (id-items (funcall (citeproc-proc-getter proc) new-ids)))
+ (pcase-dolist (`(,id . ,item) id-items)
+ (citeproc-proc--put-item
+ proc
+ (or item `((unprocessed-with-id . ,id)))
+ id t))))))
+
+(defun citeproc-proc-delete-occurrence-info (proc)
+ "Remove all itemdata occurrence info from PROC."
+ (maphash (lambda (_ itd)
+ (setf (citeproc-itemdata-occurred-before itd) nil))
+ (citeproc-proc-itemdata proc)))
+
+(defun citeproc-proc--parse-csl-json-name (rep)
+ "Parse the json representation REP of a csl name variable."
+ (if-let ((literal (alist-get 'literal rep)))
+ (list (cons 'family (citeproc-s-smart-apostrophes literal)))
+ (let ((filtered (-remove (lambda (x) (eq (car x) 'isInstitution)) rep)))
+ (--map (cons
+ (car it)
+ (let ((text-field (cdr it)))
+ (if (stringp text-field)
+ (citeproc-s-smart-apostrophes text-field)
+ text-field)))
+ filtered))))
+
+(defun citeproc-proc--parse-csl-var-val (rep var proc)
+ "Parse the json representation REP of csl variable VAR.
+VAR is a csl variable as symbol;
+REP is its value in standard csl json representation as parsed by
+ the Emacs `json' library;
+PROC is the target citeproc-processor of the internal representation.
+Return the PROC-internal representation of REP."
+ (cond ((memq var citeproc--name-vars)
+ (--map (citeproc-proc--internalize-name
+ (citeproc-proc--parse-csl-json-name it)
+ proc)
+ rep))
+ ((memq var citeproc--date-vars)
+ (citeproc-date-parse rep))
+ ;;FIXME: We handle here the id... do we need it in the itemdata at all?
+ ((or (memq var citeproc--number-vars) (eq 'id var))
+ (citeproc-s-from-num-or-s rep))
+ ((stringp rep)
+ (let* ((w-aposts (citeproc-s-smart-apostrophes rep))
+ (rt (citeproc-rt-from-str w-aposts)))
+ (if (s-contains-p "\"" rep)
+ (let* ((terms (citeproc-style-terms (citeproc-proc-style proc)))
+ (oq (citeproc-term-text-from-terms "open-quote" terms))
+ (cq (citeproc-term-text-from-terms "close-quote" terms)))
+ (citeproc-rt-change-case
+ rt (lambda (x) (citeproc-s-smart-quotes x oq cq))))
+ rt)))
+ (t rep)))
+
+(defun citeproc-proc-disamb (proc)
+ "Disambiguate the items stored in PROC."
+ (let* ((cite-opts (citeproc-style-cite-opts (citeproc-proc-style proc)))
+ (name (string= "true" (alist-get 'disambiguate-add-names cite-opts)))
+ (given (string= "true" (alist-get 'disambiguate-add-givenname cite-opts)))
+ (yearsuff (string= "true" (alist-get 'disambiguate-add-year-suffix cite-opts))))
+ (citeproc-disamb-itds (hash-table-values (citeproc-proc-itemdata proc))
+ (citeproc-proc-style proc)
+ name given yearsuff)))
+
+(defun citeproc-proc-byte-compile (proc)
+ "Byte-compile all lambdas in PROC."
+ (let* ((style (citeproc-proc-style proc))
+ (bib-sort (citeproc-style-bib-sort style))
+ (cite-sort (citeproc-style-cite-sort style)))
+ (setf (citeproc-style-macros style)
+ (--map (cons (car it) (byte-compile (cdr it)))
+ (citeproc-style-macros style))
+ (citeproc-style-cite-layout style)
+ (byte-compile (citeproc-style-cite-layout style))
+ (citeproc-style-bib-layout style)
+ (byte-compile (citeproc-style-bib-layout style)))
+ (when bib-sort (setf (citeproc-style-bib-sort style) (byte-compile bib-sort)))
+ (when cite-sort (setf (citeproc-style-cite-sort style) (byte-compile cite-sort)))))
+
+(defun citeproc-proc-filtered-bib-p (proc)
+ "Return whether PROC has nontrivial filters"
+ (let ((filters (citeproc-proc-bib-filters proc)))
+ (and filters (not (equal filters '(nil))))))
+
+(defun citeproc-proc-max-offset (itds)
+ "Return the maximal first field width of bibitems in ITDS.
+ITDS should be the value of the itemdata field of a citeproc-proc
+structure."
+ (cl-loop for itd being the hash-values of itds
+ when (listp (citeproc-itemdata-rawbibitem itd)) maximize
+ (length (citeproc-rt-to-plain (cadr (citeproc-itemdata-rawbibitem itd))))))
+
+(provide 'citeproc-proc)
+
+;;; citeproc-proc.el ends here
--- /dev/null
+;; citeproc-rt.el --- citeproc-el rich-text functions -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017-2021 András Simonyi
+
+;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
+
+;; 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 3 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.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Functions operating on rich-text contents. In citeproc-el, rich-texts are
+;; represented either by strings or by lists of the form (ATTRS RT_1 RT_2...)
+;; where ATTRS is an alist consisting of (FORMAT-ATTR . VALUE) pairs and RT_1,
+;; RT_2... are all rich-texts. The constants `citeproc-rt-format-attrs' and
+;; `citeproc-rt-ext-format-attrs' define the list of normal and extended format
+;; attributes, respectively. As a degenerate case, nil is also a legitimate
+;; rich-text.
+
+;;; Code:
+
+(require 'subr-x)
+(require 'dash)
+(require 'cl-lib)
+(require 'let-alist)
+(require 's)
+(require 'compat)
+
+(require 'citeproc-s)
+(require 'citeproc-lib)
+
+(defconst citeproc-rt-format-attrs
+ '(font-variant font-style font-weight text-decoration vertical-align font-variant
+ display rendered-var name-id quotes cited-item-no bib-item-no
+ rendered-names href stopped-rendering rendered-locator-label)
+ "The rich-text content format attributes (used in raw output).")
+
+(defconst citeproc-rt-ext-format-attrs
+ (-concat '(prefix suffix delimiter subst quotes) citeproc-rt-format-attrs)
+ "The list of extended format attributes.")
+
+(defun citeproc-rt-to-plain (rt)
+ "Return the plain-text content of rich-text RT."
+ (if (listp rt)
+ (mapconcat 'citeproc-rt-to-plain
+ (cdr rt)
+ "")
+ rt))
+
+(defun citeproc-rt-attrs (rt)
+ "Return the attrs of rich content RT."
+ (if (listp rt) (car rt) nil))
+
+(defun citeproc-rt-first-content (rt)
+ "Return the first content element of rich content RT."
+ (if (listp rt) (cadr rt) rt))
+
+(defun citeproc-rt-select-attrs (attrs keep)
+ "Select attr-val pairs from alist ATTRS whose attr is in KEEP."
+ (--filter (memq (car it) keep)
+ attrs))
+
+(defun citeproc-rt-join-strings (rt)
+ "Concatenate consecutive strings in rich-text RT."
+ (cond ((< (length rt) 2)
+ rt)
+ ((and (char-or-string-p (car rt))
+ (char-or-string-p (cadr rt)))
+ (citeproc-rt-join-strings (cons (concat (car rt)
+ (cadr rt))
+ (cddr rt))))
+ (t (cons (car rt)
+ (citeproc-rt-join-strings (cdr rt))))))
+
+(defun citeproc-rt-splice-unformatted (rt)
+ "Splice the body of its unformatted elements into rich-text RT."
+ (if (and (consp rt) (not (alist-get 'delimiter (car rt))))
+ (cons (car rt)
+ (--mapcat (if (citeproc-rt-formatting-empty-p it)
+ (cdr it)
+ (list it))
+ (cdr rt)))
+ rt))
+
+(defun citeproc-rt-formatting-empty-p (rt)
+ "Is the formatting of rich-text RT empty/redundant?"
+ (and (consp rt) (or (not (caar rt))
+ (and (eq (cl-caaar rt) 'delimiter)
+ (= (length (car rt)) 1)
+ (= (length rt) 2)))))
+
+(defun citeproc-rt-reduce-content (rt)
+ "Reduce rich-text RT if it has no attributes or body.
+Return the original RT if it has non-empty attrs and content."
+ (cond ((not (cdr rt)) nil)
+ ((and (not (car rt)) (= (length rt) 2)) (cadr rt))
+ (t rt)))
+
+(defun citeproc-rt-simplify-shallow (rt)
+ "Simplify the first level of rich-text RT."
+ (citeproc-rt-reduce-content (citeproc-rt-join-strings
+ (citeproc-rt-splice-unformatted rt))))
+
+(defun citeproc-rt-simplify-deep (rt)
+ "Simplify all levels of rich-text RT."
+ (if (not (consp rt)) rt
+ (-let* (((attrs . conts) rt)
+ (simplifieds (--map (citeproc-rt-simplify-deep it)
+ conts)))
+ (citeproc-rt-reduce-content
+ (citeproc-rt-join-strings
+ (citeproc-rt-splice-unformatted (cons attrs simplifieds)))))))
+
+(defun citeproc-rt-map-strings (fun rts &optional skip-nocase)
+ "Map through FUN all strings in rich-texts RTS.
+Return a new rich-text with all S content strings replaced by the
+value of FUN applied to S. No formatting is changed. If optional
+SKIP-NOCASE is non-nil then skip spans with the `nocase'
+attribute set to non-nil."
+ (--map (citeproc-rt-format it fun skip-nocase) rts))
+
+(defun citeproc-rt-format (rt fun &optional skip-nocase)
+ "Format all plain text in RT with FUN.
+If optional SKIP-NOCASE is non-nil then skip spans with the
+`nocase' attribute set to non-nil."
+ (pcase rt
+ (`nil nil)
+ ((pred listp) (if (and skip-nocase (alist-get 'nocase (car rt)))
+ rt
+ (cons (car rt) (citeproc-rt-map-strings fun (cdr rt) skip-nocase))))
+ (_ (funcall fun rt))))
+
+(defun citeproc-rt-replace-all-sim (replacements regex rts)
+ "Make all REPLACEMENTS simultaneously in the strings of rich-texts RTS."
+ (citeproc-rt-map-strings (lambda (x) (citeproc-s-replace-all-sim x regex replacements))
+ rts))
+
+(defun citeproc-rt-strip-periods (rts)
+ "Remove all periods from rich-texts RTS."
+ (citeproc-rt-map-strings (lambda (x) (string-replace "." "" x)) rts))
+
+(defun citeproc-rt-length (rt)
+ "Return the length of rich-text RT as a string."
+ (if (listp rt)
+ (-sum (mapcar #'citeproc-rt-length (cdr rt)))
+ (length rt)))
+
+(defun citeproc-rt--update-from-plain-1 (rt p start &optional skip-nocase)
+ "Update rich-text RT from plain text P from position START in P.
+The length of the plain text content of RT must not be less than
+the length of P. If optional SKIP-NOCASE is non-nil then skip
+spans with the `nocase' attribute set to non-nil.
+ Return an (UPDATED . NEXT) pair where UPDATED is the updated
+rich-text and NEXT is the first position in P which was not used
+for the update."
+ (pcase rt
+ (`nil nil)
+ ((pred listp)
+ (if (and skip-nocase (alist-get 'nocase (car rt)))
+ (cons rt (+ start (citeproc-rt-length rt)))
+ (let ((act-start start))
+ (cons (cons (car rt)
+ (--map (-let (((updated . next)
+ (citeproc-rt--update-from-plain-1
+ it p act-start skip-nocase)))
+ (setq act-start next)
+ updated)
+ (cdr rt)))
+ act-start))))
+ (_ (let ((end (+ start (length rt))))
+ (cons (substring p start end) end)))))
+
+(defun citeproc-rt-update-from-plain (rt p &optional skip-nocase)
+ "Update rich-text RT from plain text P.
+The length of the plain text content of RT must not be less than
+the length of P. Return the updated rich-text. If optional
+SKIP-NOCASE is non-nil then skip spans with the `nocase'
+attribute set to non-nil."
+ (car (citeproc-rt--update-from-plain-1 rt p 0 skip-nocase)))
+
+(defun citeproc-rt-change-case (rt case-fun)
+ "Change the case of rich text RT with CASE-FUN.
+CASE-FUN is a function taking a string as its argument and
+returning a string of the same length."
+ (let ((plain (citeproc-rt-to-plain rt)))
+ (citeproc-rt-update-from-plain rt (funcall case-fun plain) t)))
+
+(defun citeproc-rt-pred-counts-tree (rt pred)
+ "Return a dominated count tree for rich text RT based on PRED.
+The returned tree has the same structure as RT but the car of
+each subtree is a number indicating the maximal number of nodes
+on any dominated branch for which PRED holds."
+ (if (consp rt)
+ (let ((children-vals (--map (citeproc-rt-pred-counts-tree it pred)
+ (cdr rt))))
+ (cons (-max (cl-mapcar (lambda (rich count)
+ (+ (if (listp count) (car count) count)
+ (if (funcall pred rich) 1 0)))
+ (cdr rt)
+ children-vals))
+ children-vals))
+ 0))
+
+(defun citeproc-rt-flip-italics (rt)
+ "Flip the italic attribute of rich text RT."
+ (if (listp rt)
+ (cons (if (citeproc-rt-in-italics-p rt)
+ (--remove (eq (car it) 'font-style) (car rt))
+ (cons '(font-style . "italic") (car rt)))
+ (cdr rt))
+ `(((font-style . "italic")) ,rt)))
+
+(defun citeproc-rt-in-italics-p (rt)
+ "Whether rich text RT has italic font style as attribute."
+ (and (listp rt)
+ (string= (alist-get 'font-style (car rt)) "italic")))
+
+(defun citeproc-rt-italics-flipflop (rt)
+ "Return a flipflopped italics version of rich text RT."
+ (if (and rt (listp rt))
+ (let ((italics-counts-tree
+ (citeproc-rt-pred-counts-tree rt 'citeproc-rt-in-italics-p)))
+ (if (> (+ (car italics-counts-tree)
+ (if (citeproc-rt-in-italics-p rt) 1 0))
+ 1)
+ (citeproc-rt--italics-flipflop-1 rt italics-counts-tree)
+ rt))
+ rt))
+
+(defun citeproc-rt--italics-flipflop-1 (rt italics-counts-tree)
+ "Flipflop italics in RT using info from ITALICS-COUNTS-TREE."
+ (let ((rt-italic (citeproc-rt-in-italics-p rt)))
+ (if (or (not (listp rt))
+ (not (listp italics-counts-tree))
+ (< (+ (car italics-counts-tree)
+ (if rt-italic 1 0))
+ 2)) rt
+ (if rt-italic
+ (cons (--remove (eq (car it) 'font-style) (car rt))
+ (cl-mapcar (lambda (r i)
+ (citeproc-rt--italics-flipflop-1
+ (citeproc-rt-flip-italics r) i))
+ (cdr rt)
+ (cdr italics-counts-tree)))
+ (cons (car rt)
+ (cl-mapcar (lambda (r i) (citeproc-rt--italics-flipflop-1 r i))
+ (cdr rt)
+ (cdr italics-counts-tree)))))))
+
+(defun citeproc-rt-from-str (s)
+ "Parse a html or plain text string S into rich text."
+ (if (and s (s-matches-p "</[[:alnum:]]+>" s))
+ (let* ((parsed (citeproc-lib-parse-html-frag s))
+ (body (cddr (cl-caddr parsed)))
+ (stripped (if (and (consp (car body)) (eq (caar body) 'p))
+ (cl-cddar body)
+ body)))
+ (if (= 1 (length stripped))
+ (citeproc-rt-from-html (car stripped))
+ (cons nil (mapcar 'citeproc-rt-from-html stripped))))
+ s))
+
+(defconst citeproc-rt-from-html-alist
+ '(((i . nil) . (font-style . "italic"))
+ ((b . nil) . (font-weight . "bold"))
+ ((span . ((style . "font-variant:small-caps;"))) . (font-variant . "small-caps"))
+ ((sc . nil) . (font-variant . "small-caps"))
+ ((sup . nil) . (vertical-align . "sup"))
+ ((sub . nil) . (vertical-align . "sub"))
+ ((span . ((class . "nocase"))) . (nocase . t))
+ ((span . ((class . "underline"))) . (text-decoration . "underline")))
+ "A mapping from html tags and attrs to rich text attrs.")
+
+(defun citeproc-rt-from-html (h)
+ "Convert simple html H to rich text."
+ (if (listp h)
+ (cons (-if-let (attr (assoc-default (cons (car h) (cadr h))
+ citeproc-rt-from-html-alist))
+ (list attr)
+ '(nil))
+ (mapcar #'citeproc-rt-from-html (cddr h)))
+ h))
+
+(defun citeproc-rt--cquote-pstns-1 (rt offset)
+ "Return closing quote positions in rich text RT with OFFSET.
+The positions are in the plain text of RT and only those
+positions are returned which are associated with a CSL
+`quotes'=\"yes\" attribute."
+ (if (listp rt)
+ (let ((inner (let ((act-offset offset)
+ pstns)
+ (--each (cdr rt)
+ (-let (((p . next)
+ (citeproc-rt--cquote-pstns-1 it act-offset)))
+ (setq pstns (nconc pstns p)
+ act-offset next)))
+ (cons pstns act-offset))))
+ (if (string= (alist-get 'quotes (car rt)) "true")
+ (-let (((inner-pstns . inner-offset) inner))
+ (cons (cons (1- inner-offset) inner-pstns)
+ inner-offset))
+ inner))
+ (cons nil (+ offset (length rt)))))
+
+(defun citeproc-rt--cquote-pstns (rt)
+ "Return a list of closing quote positions in RT.
+The positions are in the plain text of RT and only those
+positions are returned which are associated with a CSL
+`quotes'=\"yes\" attribute. Numbering starts from 1.
+The positions are in decreasing order."
+ (sort (car (citeproc-rt--cquote-pstns-1 rt 1)) '>))
+
+(defun citeproc-rt-punct-in-quote (rt)
+ "Put commas and periods inside quotes in rich text RT."
+ (-if-let (pstns (citeproc-rt--cquote-pstns rt))
+ (let ((plain (citeproc-rt-to-plain rt)))
+ (citeproc-rt-update-from-plain
+ rt
+ (with-temp-buffer
+ (insert plain)
+ (dolist (pos pstns)
+ (goto-char (1+ pos))
+ (when (memq (char-after) '(?, ?.))
+ (call-interactively 'transpose-chars)))
+ (buffer-string))))
+ rt))
+
+(defun citeproc-rt-find-first-node (rt pred)
+ "Return the first node of RT for which PRED holds.
+Return nil if no such node was found."
+ (if (funcall pred rt) rt
+ (pcase rt
+ ;; process further if internal node with content
+ (`(,_ . ,body)
+ (let (found)
+ (while (and (not found) body)
+ (setq found (citeproc-rt-find-first-node (car body) pred))
+ (pop body))
+ found))
+ ;; leaf or node with no content
+ (_ nil))))
+
+(defun citeproc-rt-transform-first (rt pred transform)
+ "Apply TRANSFORM to the first node of RT for which PRED is non-nil.
+PRED and TRANSFORM are functions taking a rich-text node as their
+sole argument. Return a (RESULT . SUCCESS) pair where RESULT is
+the resulting rich-text and SUCCESS is non-nil iff the
+transformation was successfully carried out (i.e., a node
+satisfying PRED was found)."
+ (if (funcall pred rt) (cons (funcall transform rt) t)
+ (pcase rt
+ ;; process further if internal node with content
+ (`(,attrs . ,body)
+ (let* (success
+ (new-body
+ (--map (if success it
+ (-let (((it-res . it-success)
+ (citeproc-rt-transform-first it pred transform)))
+ (setq success it-success)
+ it-res))
+ body)))
+ (cons (cons attrs new-body) success)))
+ ;; leaf or node with no content
+ (_ (cons rt nil)))))
+
+(defun citeproc-rt-add-year-suffix (rt ys)
+ "Attempt to add year suffix YS to rich-text RT.
+Return an (RT . SUCCESS) pair, where RT is the resulting
+rich-text, and SUCCESS is non-nil iff the year-suffix has been
+successfully added."
+ (cl-flet ((rendered-date-var-p
+ (node)
+ (and (consp node)
+ (memq (alist-get 'rendered-var (car node)) citeproc--date-vars)))
+ (add-suffix
+ (node)
+ (let ((content (cadr node)))
+ (if (equal content "<suppressed-date>")
+ (list (car node) ys)
+ (let ((full-ys (if (or (not (stringp content))
+ (s-matches-p "[[:digit:]]$" content))
+ ys
+ (concat "-" ys))))
+ (-snoc node `(((rendered-var . year-suffix)) ,full-ys)))))))
+ (citeproc-rt-transform-first rt #'rendered-date-var-p #'add-suffix)))
+
+(defun citeproc-rt-replace-first-names (rt replacement)
+ "Replace RT's first name-var content with REPLACEMENT.
+Return an (RT . SUCCESS) pair, where RT is the resulting
+rich-text, and SUCCESS is non-nil iff the replacement has been
+successful."
+ (cl-flet ((rendered-name-var-p
+ (node)
+ (and (consp node)
+ (assoc 'rendered-names (car node))))
+ (replace (_node) replacement))
+ (citeproc-rt-transform-first rt #'rendered-name-var-p #'replace)))
+
+(defun citeproc-rt-count-names (rt)
+ "Return a count of the rendered names in RT."
+ (if (consp rt)
+ (if (alist-get 'name-id (car rt)) 1
+ (apply #'+ (mapcar #'citeproc-rt-count-names (cdr rt))))
+ 0))
+
+(defun citeproc-rt-cull-spaces-puncts (rt)
+ "Remove unnecessary characters from rich-text RT."
+ (let* ((plain (citeproc-rt-to-plain rt))
+ (updated (citeproc-rt-update-from-plain
+ rt (citeproc-s-cull-spaces-puncts plain))))
+ (citeproc-rt-format updated
+ (lambda (x) (replace-regexp-in-string "\7f+" "" x)))))
+
+(defun citeproc-rt-render-affixes (rt &optional shallow)
+ "Render the affixes in rich-text RT.
+If SHALLOW is non-nil then render only the affixes for the first
+level."
+ (if (not (consp rt))
+ rt
+ (-let* (((attrs . contents) rt)
+ (rendered
+ (if shallow ; We do the recursive call depending on SHALLOW
+ contents
+ (-non-nil (--map (citeproc-rt-render-affixes it) contents)))))
+ (if rendered
+ (let-alist attrs
+ (let ((delimited (if .delimiter
+ (cdr (--mapcat (list .delimiter it) rendered))
+ rendered)))
+ (if (or .suffix .prefix)
+ (let (result
+ outer-attrs
+ (inner-attrs
+ (citeproc-rt-select-attrs attrs citeproc-rt-format-attrs)))
+ (when .display ; The display attribute should encompass affixes
+ (setq outer-attrs (list (cons 'display .display))
+ inner-attrs (--remove (eq (car it) 'display) inner-attrs)))
+ (when .suffix (push .suffix result))
+ (push (cons inner-attrs
+ delimited)
+ result)
+ (when .prefix (push .prefix result))
+ (cons outer-attrs result))
+ (cons (citeproc-rt-select-attrs attrs citeproc-rt-format-attrs)
+ delimited))))
+ nil))))
+
+(defun citeproc-rt-dedup (rt)
+ "Remove duplicate substituted renderings from content RT."
+ (car (citeproc-rt--dedup-single rt nil)))
+
+(defun citeproc-rt--dedup-single (rt substs)
+ "Remove duplicate subst. var renderings from RT.
+SUBSTS contains an initial list of vars to be removed. Return
+a (<deduplicated content of RT> <substitued vars in RT> <vars in RT>) list."
+ (if (not (consp rt))
+ (list rt nil nil)
+ (-let* (((attrs . cs) rt)
+ ((&alist 'subst subst
+ 'rendered-var var)
+ attrs))
+ (if (and var (memq var substs))
+ (list nil nil nil)
+ (-let (((new-c s v) (citeproc-rt--dedup-multi cs substs)))
+ (list (cons (--reject (memq (car it) '(subst rendered-vars)) attrs)
+ new-c)
+ (if subst
+ (-concat v (when var (list var)))
+ s)
+ (-concat v (if var
+ (list var)
+ nil))))))))
+
+(defun citeproc-rt--dedup-multi (cs substs)
+ (if cs
+ (-let* (((c s1 v1) (citeproc-rt--dedup-single (car cs) substs))
+ ((cs s2 v2) (citeproc-rt--dedup-multi (cdr cs) (-concat substs s1))))
+ (list (cons c cs)
+ (-concat s1 s2)
+ (-concat v1 v2)))
+ (list nil nil nil)))
+
+(defun citeproc-rt-finalize (rt &optional punct-in-quote)
+ "Finalize rich text RT.
+If the optional PUNCT-IN-QUOTE is non-nil then put punctuation
+inside quotes.
+
+Note: Finalization doesn't include culling, because some
+rich-text transformations require the state before culling (e.g.
+the replacement of subsequent authors)."
+ ;; The first step is to replace the internally used `modifier letter
+ ;; apostrophe' characters with the normal `right single quotation marks'
+ (citeproc-rt-format (citeproc-rt-simplify-deep
+ (citeproc-rt-italics-flipflop
+ (if punct-in-quote (citeproc-rt-punct-in-quote rt) rt)))
+ (lambda (x) (s-replace "ʼ" "’" x))))
+
+(defun citeproc-rt--attr-values (r attr)
+ "Return the list of ATTR values in raw rich-text content R.
+The values are ordered depth-first."
+ (if (listp r)
+ (let ((val (alist-get attr (car r)))
+ (body-vals (--mapcat (citeproc-rt--attr-values it attr) (cdr r))))
+ (if val (cons val body-vals)
+ body-vals))
+ nil))
+
+(defun citeproc-rt-rendered-name-ids (r)
+ "Return the list of name ids in raw content R."
+ (citeproc-rt--attr-values r 'name-id))
+
+(defun citeproc-rt-rendered-vars (r)
+ "Return the list of rendered vars in raw content R."
+ (citeproc-rt--attr-values r 'rendered-var))
+
+(defun citeproc-rt-rendered-date-vars (r)
+ "Return the list of date vars in raw content R."
+ (--select (memq it citeproc--date-vars) (citeproc-rt-rendered-vars r)))
+
+(defun citeproc-rt-rendered-name-vars (r)
+ "Return the list of name vars in raw content R."
+ (--select (memq it citeproc--name-vars) (citeproc-rt-rendered-vars r)))
+
+;;; Helpers for bibliography rendering
+
+(defun citeproc-rt-subsequent-author-substitute (bib s)
+ "Substitute S for subsequent author(s) in BIB.
+BIB is a list of bib entries in rich-text format. Return the
+modified bibliography."
+ (let (prev-author)
+ (--map
+ (let ((author
+ (citeproc-rt-find-first-node
+ it
+ (lambda (x)
+ (and (consp x) (assoc 'rendered-names (car x)))))))
+ (if (equal author prev-author)
+ (car (citeproc-rt-replace-first-names it s))
+ (prog1 it (setq prev-author author))))
+ bib)))
+
+(defun citeproc-rt-link-title (r target)
+ "Link the rendered title var in rich-text R to TARGET."
+ (cl-flet ((rendered-var-title-p
+ (node)
+ (and (consp node)
+ (eq (alist-get 'rendered-var (car node)) 'title)))
+ (add-link
+ (node)
+ (push (cons 'href target) (car node))))
+ (citeproc-rt-transform-first r #'rendered-var-title-p #'add-link)))
+
+(defun citeproc-rt-locator-p (r)
+ "Return whether rich-text R is a rendered locator."
+ (and (consp r) (string= (alist-get 'rendered-var (car r)) "locator")))
+
+(defun citeproc-rt-locator-label-p (r)
+ "Return whether rich-text R is a rendered locator label."
+ (and (consp r) (alist-get 'rendered-locator-label (car r))))
+
+(defun citeproc-rt-add-locator-label-position (r)
+ "Add information about locator-label position in rich-text R.
+Return value is one of `label', `locator', `label-first',
+`locator-first', `label-only', `locator-only' or nil. This
+information is also added to the tree node attributes."
+ (let ((result
+ (cond
+ ((not (consp r)) nil)
+ ((citeproc-rt-locator-p r) 'locator)
+ ((citeproc-rt-locator-label-p r) 'label)
+ (t (let ((content (cdr r))
+ first second)
+ (while (and content (not (and first second)))
+ (let* ((cur (pop content))
+ (cur-order (citeproc-rt-add-locator-label-position cur)))
+ (pcase cur-order
+ ('label-first (setq first 'label second 'locator))
+ ('locator-first (setq first 'locator second 'label))
+ ((or 'label-only 'label)
+ (if first (setq second 'label)
+ (setq first 'label)))
+ ((or 'locator-only 'locator)
+ (if first (setq second 'locator)
+ (setq first 'locator))))))
+ (cond
+ ((not first) nil)
+ ((not second) (if (eq first 'locator) 'locator-only 'label-only))
+ (t (if (eq first 'locator) 'locator-first 'label-first))))))))
+ (when result (push (cons 'l-l-pos result) (car r)))
+ result))
+
+(defun citeproc-rt-locator-w-label (r)
+ "Return locator with label if found from rich-text R.
+Return R if no locator or locator label was found."
+ (let ((l-l-pos (citeproc-rt-add-locator-label-position r)))
+ (if l-l-pos
+ (citeproc-rt-locator-w-label-1 r l-l-pos)
+ ;; We return the full cite if no locator was found.
+ r)))
+
+(defun citeproc-rt-locator-w-label-1 (r l-l-pos)
+ "Return locator-label span from rich-text fragment R.
+L-L-POS is the global position of locator and label, see the
+documentation of `citeproc-rt-add-locator-label-position' for the
+possible values."
+ (if (or (citeproc-rt-locator-label-p r) (citeproc-rt-locator-p r)) r
+ (pcase-let* ((`(,attrs . ,content) r)
+ (local-llpos (alist-get 'l-l-pos attrs)))
+ (cons attrs
+ (let (result
+ (n-boundaries (if (or (and (eq l-l-pos 'locator-first)
+ (eq local-llpos 'label-only))
+ (and (eq l-l-pos 'label-first)
+ (eq local-llpos 'locator-only)))
+ 1 ; Fragment starts in a between position.
+ 0))) ; Fragment starts in a before position.
+ (while (and content (< n-boundaries 2))
+ (let* ((cur-rt (pop content))
+ (cur-rt-llpos (and (consp cur-rt) (alist-get 'l-l-pos (car cur-rt)))))
+ (cond (cur-rt-llpos
+ ;; Element at boundary
+ (cl-incf n-boundaries
+ (if (or (eq l-l-pos 'locator-only)
+ (memq cur-rt-llpos '(label-first locator-first)))
+ 2
+ 1))
+ (push (citeproc-rt-locator-w-label-1 cur-rt l-l-pos) result))
+ ;; Element in between position, simply pushing
+ ((= n-boundaries 1)
+ (push cur-rt result)))))
+ (nreverse result))))))
+
+(provide 'citeproc-rt)
+
+;;; citeproc-rt.el ends here
--- /dev/null
+;;; citeproc-s.el --- citeproc-el string functions -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017 András Simonyi
+
+;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
+
+;; 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 3 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.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; String utility functions for citeproc-el.
+
+;;; Code:
+
+(require 'thingatpt)
+(require 's)
+(require 'compat)
+
+(defun citeproc-s-camelcase-p (s)
+ "Return whether string S is in camel case."
+ (let ((case-fold-search nil))
+ (and (< 1 (length s))
+ (s-matches-p "[[:upper:]]" (substring s 1))
+ (s-matches-p "[[:lower:]]" s))))
+
+(defun citeproc-s-fill-copy (s1 s2)
+ "Return a copy of string S1 filled by characters from string S2.
+If string S1 is shorter than string S2 then prepend enough
+characters from to beginning of S2 to the beginning of a copy of
+S2 to make their length equal, and return the filled copy."
+ (if (>= (length s1) (length s2)) s1
+ (concat (substring s2 0 (- (length s2) (length s1))) s1)))
+
+(defun citeproc-s-fill-left-to-len (s len &optional char)
+ "Fill string S to length LEN with CHAR from left."
+ (let ((len-s (length s))
+ (char (or char ?0)))
+ (if (>= len-s len) s
+ (concat (make-string (- len len-s) char) s))))
+
+(defun citeproc-s-nil-or-s-to-num (s)
+ "Convert S, which is a string or nil to a number.
+A nil value is converted to 0."
+ (if s (string-to-number s) 0))
+
+(defun citeproc-s-from-num-or-s (x)
+ "Return the content of string or number X as a number."
+ (if (numberp x) (number-to-string x) x))
+
+(defun citeproc-s-content (s)
+ "Return the string content of string or symbol or nil S.
+The string content of nil is defined as \"\"."
+ (pcase s
+ ((\` nil) "")
+ ((pred symbolp) (symbol-name s))
+ (_ s)))
+
+(defun citeproc-s-slice-by-matches (s regexp &optional start annot)
+ "Slice S up at the boundaries of each REGEXP match.
+Optionally start from index START. Matches are also included
+among the slices, but all zero-length slices are omitted. If
+optional ANNOT is non-nil then slices are given as (S . B) cons
+cells where S is the slice string, while B is nil if the S slice
+is a separating REGEXP match and t otherwise."
+ (unless start (setq start 0))
+ (save-match-data
+ (let ((begin (string-match regexp s start)))
+ (if begin
+ (let ((end (match-end 0)))
+ (if (and (= begin start) (= end start))
+ (citeproc-s-slice-by-matches s regexp (1+ start) annot)
+ (let ((result (citeproc-s-slice-by-matches (substring s end)
+ regexp 0 annot)))
+ (unless (= begin end)
+ (let ((slice (substring s begin end)))
+ (push (if annot (list slice) slice) result)))
+ (unless (= 0 begin)
+ (let ((slice (substring s 0 begin)))
+ (push (if annot (cons slice t) slice) result)))
+ result)))
+ (list (if annot (cons s t) s))))))
+
+(defun citeproc-s-tail (s length)
+ "Return the closing substring of string S with length LENGTH.
+Return S if LENGTH is nil or not less than the length of S."
+ (let ((l (length s)))
+ (if (and length (< length l))
+ (substring s (- l length))
+ s)))
+
+(defun citeproc-s-capitalize-first (s)
+ "Capitalize the first word in string S.
+Return the capitalized version of S. If S contains no word or the
+first word is not in lowercase then return S."
+ (if (s-present-p s)
+ (with-temp-buffer
+ (insert s)
+ (goto-char 1)
+ (forward-word)
+ (backward-word)
+ (let ((word (word-at-point)))
+ (when (s-lowercase-p word)
+ (capitalize-word 1)))
+ (buffer-string))
+ s))
+
+(defun citeproc-s-capitalize-all (s)
+ "Capitalize all lowercase words in string S.
+Return the capitalized version of S. If S contains no word or the
+first word is not in lowercase then return S."
+ (if (s-present-p s)
+ (with-temp-buffer
+ (insert s)
+ (goto-char 1)
+ (while (forward-word)
+ (let ((word (word-at-point)))
+ (when (s-lowercase-p word)
+ (capitalize-word -1))))
+ (buffer-string))
+ s))
+
+(defun citeproc-s-sentence-case (s)
+ "Return a sentence-cased version of string S."
+ (if (s-present-p s)
+ (with-temp-buffer
+ (insert s)
+ (goto-char 1)
+ (let ((first t))
+ (while (forward-word)
+ (let ((word (word-at-point)))
+ (cond ((s-uppercase-p word) (capitalize-word -1))
+ ((and first (s-lowercase-p word)) (capitalize-word -1))))
+ (when first (setq first nil))))
+ (buffer-string))
+ s))
+
+(defun citeproc-s-sentence-case-title (s &optional omit-nocase)
+ "Return a sentence-cased version of title string S.
+If optional OMIT-NOCASE is non-nil then omit the nocase tags from the output."
+ (if (s-blank-p s) s
+ (let ((sliced (citeproc-s-slice-by-matches
+ s "\\(<span class=\"nocase\">\\|</span>\\|: +[\"'“‘]*[[:alpha:]]\\)"))
+ (protect-level 0)
+ (first t)
+ result)
+ (dolist (slice sliced)
+ (push
+ (pcase slice
+ ("<span class=\"nocase\">" (cl-incf protect-level) (if omit-nocase nil slice))
+ ("</span>" (cl-decf protect-level) (if omit-nocase nil slice))
+ ;; Don't touch the first letter after a colon since it probably
+ ;; starts a subtitle.
+ ((pred (string-match-p "^: +[\"'“‘]*[[:alpha:]]")) (setq first nil) slice)
+ (_ (cond ((< 0 protect-level) (setq first nil) slice)
+ ((not first) (downcase slice))
+ (t (setq first nil)
+ ;; We upcase the first letter and downcase the rest.
+ (let ((pos (string-match "[[:alpha:]]" slice)))
+ (if pos (concat (substring slice 0 pos)
+ (upcase (substring slice pos (1+ pos)))
+ (downcase (substring slice (1+ pos))))
+ slice))))))
+ result))
+ (apply #'concat (nreverse result)))))
+
+(defconst citeproc-s-english-stopwords
+ '("a" "according to" "across" "afore" "after" "against" "ahead of" "along" "alongside"
+ "amid" "amidst" "among" "amongst" "an" "and" "anenst" "apart from" "apropos"
+ "around" "as" "as regards" "aside" "astride" "at" "athwart" "atop" "back to"
+ "barring" "because of" "before" "behind" "below" "beneath" "beside" "besides"
+ "between" "beyond" "but" "by" "c" "ca" "circa" "close to" "d'" "de" "despite" "down"
+ "due to" "during" "et" "except" "far from" "for" "forenenst" "from" "given" "in"
+ "inside" "instead of" "into" "lest" "like" "modulo" "near" "next" "nor" "of" "off"
+ "on" "onto" "or" "out" "outside of" "over" "per" "plus" "prior to" "pro" "pursuant
+ to" "qua" "rather than" "regardless of" "sans" "since" "so" "such as" "than"
+ "that of" "the" "through" "throughout" "thru" "thruout" "till" "to" "toward" "towards"
+ "under" "underneath" "until" "unto" "up" "upon" "v." "van" "versus" "via" "vis-à-vis"
+ "von" "vs." "where as" "with" "within" "without" "yet"))
+
+(defun citeproc-s-title-case (s)
+ "Return a title-cased version of string S."
+ (if (s-present-p s)
+ (with-temp-buffer
+ (insert s)
+ (goto-char 1)
+ (let ((first t)
+ after-colon)
+ (while (forward-word)
+ (let ((word (word-at-point)))
+ (cond ((and (not (or first after-colon))
+ (member (downcase word) citeproc-s-english-stopwords)
+ ;; Don't downcase A before a period:
+ (or (not (string= word "A"))
+ (= (point) (point-max))
+ (/= (char-after) ?.)))
+ (downcase-word -1))
+ ((s-lowercase-p word)
+ (capitalize-word -1))))
+ (when first (setq first nil))
+ (when (< (point) (point-max))
+ (setq after-colon (or (= (char-after) ?:)
+ (= (char-after) ?.))))))
+ (buffer-string))
+ s))
+
+(defun citeproc-s-smart-quotes (s oq cq)
+ "Replace dumb quotes in string S with smart ones OQ and CQ.
+OQ is the opening quote, CQ is the closing quote to use."
+ (with-temp-buffer
+ (insert s)
+ (goto-char 1)
+ (while (search-forward "\"" nil 1)
+ (let ((w-a-p (word-at-point)))
+ (delete-char -1)
+ (insert (if w-a-p oq cq))))
+ (buffer-string)))
+
+(defun citeproc-s-replace-all-seq (s replacements)
+ "Make replacements in S according to REPLACEMENTS sequentially.
+REPLACEMENTS is an alist with (FROM . TO) elements."
+ (let ((result s))
+ (pcase-dolist (`(,from . ,to) replacements)
+ (setq result (string-replace from to result)))
+ result))
+
+(defun citeproc-s-replace-all-sim (s regex replacements)
+ "Replace all matches of REGEX in S according to REPLACEMENTS simultaneously.
+REPLACEMENTS is an alist with (FROM . TO) elements."
+ (replace-regexp-in-string regex
+ (lambda (match) (cdr (assoc-string match replacements)))
+ s t t))
+
+(defun citeproc-s-smart-apostrophes (s)
+ "Replace dumb apostophes in string S with smart ones.
+The replacement character used is the unicode character `modifier
+letter apostrophe'."
+ (string-replace "'" "ʼ" (string-replace "’" "ʼ" s)))
+
+(defconst citeproc-s--cull-spaces-alist
+ '((" " . " \7f") (";;" . ";\7f") ("..." . ".\7f\7f") (",," . ",\7f") (".." . ".\7f"))
+ "Alist describing replacements for space and punct culling.")
+
+(defconst citeproc-s--cull-spaces-alist-rx
+ (regexp-opt (mapcar #'car citeproc-s--cull-spaces-alist)))
+
+(defun citeproc-s-cull-spaces-puncts (s)
+ "Replace unnecessary characters with delete chars in string S."
+ (let ((result (citeproc-s-replace-all-seq s citeproc-s--cull-spaces-alist)))
+ (dolist (match-rep '(("\\([:;!?]\\):" . "\\1\7f")
+ ("\\([:.;!?]\\)\\." . "\\1\7f")
+ ("\\([:;!]\\)!" . "\7f!")
+ ("\\([:;?]\\)\\?" . "\7f?")
+ ("\\.\\([”’‹›«»]\\)\\." . ".\\1\7f")
+ (",\\([”’‹›«»]\\)," . ",\\1\7f"))
+ result)
+ (setq result (replace-regexp-in-string (car match-rep)
+ (cdr match-rep)
+ result)))))
+
+(provide 'citeproc-s)
+
+;;; citeproc-s.el ends here
--- /dev/null
+;;; citeproc-sort.el --- cite and bibliography sorting -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017 András Simonyi
+
+;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
+
+;; 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 3 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.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Functions to sort cites and bibliography items.
+
+;;; Code:
+
+(require 'subr-x)
+(require 'cl-lib)
+(require 'dash)
+(require 's)
+
+(require 'citeproc-lib)
+(require 'citeproc-s)
+(require 'citeproc-rt)
+(require 'citeproc-macro)
+(require 'citeproc-proc)
+(require 'citeproc-name)
+(require 'citeproc-number)
+
+(defun citeproc--sort (_attrs _context &rest body)
+ "Placeholder function corresponding to the cs:sort element of CSL."
+ body)
+
+(defun citeproc-sort--name-var-key (var context)
+ "Return the sort-key for name-var VAR using CONTEXT.
+VAR is a CSL name-var name as a symbol. The returned value is a
+string containing a semicolon-separated list of all full names in
+sort order."
+ (citeproc-rt-to-plain
+ (citeproc-rt-render-affixes
+ (citeproc-name--render-var var '((form . "long") (name-as-sort-order . "all")
+ (et-al-min . nil) (et-al-use-first . "0")
+ (delimiter . "; "))
+ nil nil nil nil nil context))))
+
+(defun citeproc-sort--date-as-key (d _context)
+ "Render D citeproc-date struct as a sort key."
+ (if d (let ((year (citeproc-date-year d))
+ (month (or (citeproc-date-month d) 0))
+ (day (or (citeproc-date-day d) 0)))
+ ;; We add 5000 as an offset to deal with sorting BC years properly
+ (concat (number-to-string (+ 5000 year))
+ (citeproc-s-fill-left-to-len (number-to-string month) 2 ?0)
+ (citeproc-s-fill-left-to-len (number-to-string day) 2 ?0)))
+ ""))
+
+(defun citeproc-sort--date-var-key (var context)
+ "Return the sort-key for name-var VAR using CONTEXT.
+VAR is a symbol."
+ (-let* (((d1 d2) (citeproc-var-value var context))
+ (rendered-first (citeproc-sort--date-as-key d1 context)))
+ (if d2
+ (concat rendered-first "–" (citeproc-sort--date-as-key d2 context))
+ rendered-first)))
+
+(defun citeproc--key (attrs context &rest _body)
+ "Return a sort key corresponding to ATTRS and CONTEXT."
+ (-let (((&alist 'macro macro
+ 'variable var)
+ attrs)
+ (global-attrs (--filter (memq (car it)
+ '(names-min names-use-first names-use-last))
+ attrs)))
+ (if var (let ((var-sym (intern var)))
+ (cond
+ ((memq var-sym citeproc--number-vars)
+ ;; OPTIMIZE: This is way too complicated to simply get a filled
+ ;; numeric value..
+ (citeproc-s-fill-left-to-len
+ (citeproc-number-var-value
+ (citeproc-var-value var-sym context) var-sym 'numeric context)
+ 5))
+ ((memq var-sym citeproc--date-vars)
+ (citeproc-sort--date-var-key var-sym context))
+ ((memq var-sym citeproc--name-vars)
+ (citeproc-sort--name-var-key var-sym context))
+ (t (citeproc-rt-to-plain (citeproc-var-value var-sym context)))))
+ (let ((new-context (citeproc-context--create
+ :vars (citeproc-context-vars context)
+ :macros (citeproc-context-macros context)
+ :terms (citeproc-context-terms context)
+ :date-text (citeproc-context-date-text context)
+ :date-numeric (citeproc-context-date-numeric context)
+ :opts (nconc global-attrs (citeproc-context-opts context))
+ :mode (citeproc-context-mode context)
+ :render-mode 'sort
+ :render-year-suffix nil)))
+ (citeproc-macro-output-as-text macro new-context)))))
+
+(defun citeproc-sort--compare-keys (k1 k2 &optional desc)
+ "Return 1, 0 or -1 depending on the sort-order of keys K1 and K2.
+If optional DESC is non-nil then reverse the comparison for
+descending sort."
+ (cond ((string-collate-equalp k1 k2) 0)
+ ((s-blank? k1) -1)
+ ((s-blank? k2) 1)
+ (t (* (if (string-collate-lessp k1 k2) 1 -1)
+ (if desc -1 1)))))
+
+(defun citeproc-sort--compare-keylists (k1 k2 sort-orders)
+ "Whether keylist K1 precedes keylist K2 in the sort order.
+SORT-ORDERS is a list of sort orders to use (see the bib- and
+cite-sort-orders slots of `citeproc-style' for details)."
+ (citeproc-lib-lex-compare k1 k2 #'citeproc-sort--compare-keys sort-orders))
+
+(defun citeproc-sort--render-keys (style var-alist mode)
+ "Render the sort keys of an item with STYLE and VAR-ALIST.
+MODE is either `cite' or `bib'."
+ (let ((context (citeproc-context-create var-alist style mode 'sort))
+ (sort (cl-ecase mode
+ (cite (citeproc-style-cite-sort style))
+ (bib (citeproc-style-bib-sort style)))))
+ (if sort (funcall sort context) nil)))
+
+(defun citeproc-itd-update-sortkey (itd style)
+ "Update the sort key of itemdata ITD for STYLE."
+ (setf (citeproc-itemdata-sort-key itd)
+ (citeproc-sort--render-keys style (citeproc-itemdata-varvals itd) 'bib)))
+
+(defun citeproc-proc-update-sortkeys (proc)
+ "Update all sort keys of the itemdata in PROC."
+ (let ((style (citeproc-proc-style proc))
+ (itds (citeproc-proc-itemdata proc)))
+ (maphash (lambda (_id itd)
+ (citeproc-itd-update-sortkey itd style))
+ itds)))
+
+(defun citeproc-sort-itds-on-citnum (itds)
+ "Sort itemdata struct list ITDS according to citation number."
+ (sort itds
+ (lambda (x y)
+ (< (string-to-number (citeproc-itd-getvar x 'citation-number))
+ (string-to-number (citeproc-itd-getvar y 'citation-number))))))
+
+(defun citeproc-sort-itds-on-subbib (itd1 itd2)
+ "Sort itemdata structs ITD1 ITD2 according to subbib order."
+ (let ((idx1 (car (citeproc-itemdata-subbib-nos itd1)))
+ (idx2 (car (citeproc-itemdata-subbib-nos itd2))))
+ (and idx1
+ (or (null idx2) (< idx1 idx2)))))
+
+(defun citeproc-sort-itds (itds sort-orders)
+ "Sort the itemdata struct list ITDS according to SORT-ORDERS."
+ (sort itds
+ (lambda (x y)
+ (citeproc-sort--compare-keylists (citeproc-itemdata-sort-key x)
+ (citeproc-itemdata-sort-key y)
+ sort-orders))))
+
+(defun citeproc-proc-sort-itds (proc)
+ "Sort the itemdata in PROC."
+ (let ((is-sorted-bib (citeproc-style-bib-sort (citeproc-proc-style proc)))
+ (is-filtered (citeproc-proc-filtered-bib-p proc)))
+ (when (or is-sorted-bib is-filtered)
+ (let* ((itds (citeproc-sort-itds-on-citnum
+ (hash-table-values (citeproc-proc-itemdata proc)))))
+ (when is-sorted-bib
+ (let ((sort-orders (citeproc-style-bib-sort-orders
+ (citeproc-proc-style proc))))
+ (setq itds (citeproc-sort-itds itds sort-orders))))
+ ;; Additionally sort according to subbibliographies if there are filters.
+ (when is-filtered
+ (setq itds (sort itds #'citeproc-sort-itds-on-subbib)))
+ ;; Set the CSL citation-number field according to the sort order.
+ (--each-indexed itds
+ (citeproc-itd-setvar it 'citation-number
+ (number-to-string (1+ it-index))))))))
+
+(provide 'citeproc-sort)
+
+;;; citeproc-sort.el ends here
--- /dev/null
+;; citeproc-style.el --- CSL style structure and related functions -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017 András Simonyi
+
+;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
+
+;; 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 3 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.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Structure type and functions for constructing and accessing CSL style
+;; objects.
+
+;;; Code:
+
+(require 'subr-x)
+(require 'let-alist)
+(require 'dash)
+(require 'cl-lib)
+(require 's)
+
+(require 'citeproc-lib)
+(require 'citeproc-locale)
+
+(cl-defstruct (citeproc-style (:constructor citeproc-style--create))
+ "A struct representing a parsed and localized CSL style.
+CATEGORY is the style's category as a string,
+INFO is the style's general info (currently simply the
+ corresponding fragment of the parsed xml),
+OPTS, BIB-OPTS, CITE-OPTS and LOCALE-OPTS are alists of general
+ and bibliography-, cite- and locale-specific CSL options,
+BIB-SORT, BIB-LAYOUT, CITE-SORT and CITE-LAYOUT are anonymous
+ functions for calculating sort-keys and rendering,
+BIB-SORT-ORDERS and CITE-SORT-ORDERS are the lists of sort orders
+ for bibliography and cite sort (the value is a list containg t
+ or nil as its n-th element depending on whether the sort for on
+ the n-th key should be in ascending or desending order,
+CITE-LAYOUT-ATTRS contains the attributes of the citation layout
+ as an alist,
+DATE-TEXT and DATE-NUMERIC are the style's date formats,
+LOCALE contains the locale to be used or nil if not set,
+MACROS is an alist with macro names as keys and corresponding
+ anonymous rendering functions,
+TERMS is the style's parsed term-list,
+USES-YS-VAR is non-nil iff the style uses the YEAR-SUFFIX
+ CSL-variable."
+ category info opts bib-opts bib-sort bib-sort-orders
+ bib-layout cite-opts cite-sort cite-sort-orders
+ cite-layout cite-layout-attrs locale-opts macros terms
+ uses-ys-var date-text date-numeric locale)
+
+(defun citeproc-style-parse (style)
+ "Return the parsed representation of csl STYLE.
+STYLE is either a path to a style file or a style as a string.
+Returns a (YEAR-SUFF-P . PARSED-STYLE) cons cell. YEAR-SUFF-P is
+non-nil if the style uses the `year-suffix' csl var; PARSED-STYLE
+is the parsed form of the xml STYLE-FILE."
+ (let ((xml-input (s-matches-p " ?<" style)))
+ (with-temp-buffer
+ (let ((case-fold-search t))
+ (if xml-input (insert style)
+ (insert-file-contents style))
+ (goto-char 1)
+ (cons (re-search-forward "variable=\"year-suffix\"" nil t)
+ (citeproc-lib-remove-xml-comments
+ (libxml-parse-xml-region (point-min) (point-max))))))))
+
+;; TODO: Parse and store info in a more structured and sensible form. Also,
+;; currently the first in-style locale is loaded that is compatible with the
+;; locale to be used. In theory, there may be more than one compatible in-style
+;; locales that should be merged in an order reflecting their closeness to the
+;; requested locale.
+(defun citeproc-create-style-from-locale (parsed-style year-suffix locale)
+ "Create a citation style from parsed xml style PARSED-STYLE.
+YEAR-SUFFIX specifies whether the style explicitly uses the
+`year-suffix' csl variable. LOCALE is the locale for which
+in-style locale information will be loaded (if available)."
+ (let* ((style (citeproc-style--create))
+ (style-opts (cadr parsed-style))
+ locale-loaded)
+ (setf (citeproc-style-opts style) style-opts
+ (citeproc-style-uses-ys-var style) year-suffix
+ (citeproc-style-locale style)
+ (or locale (alist-get 'default-locale style-opts)))
+ (--each (cddr parsed-style)
+ (pcase (car it)
+ ('info
+ (let* ((info-lst (cddr it))
+ (category-info (cl-find-if
+ (lambda (x) (and (eq 'category (car x))
+ (eq 'citation-format (caaadr x))))
+ info-lst))
+ (category (cdaadr category-info)))
+ (setf (citeproc-style-category style) category)))
+ ('locale
+ (let ((lang (alist-get 'lang (cadr it))))
+ (when (and (citeproc-locale--compatible-p lang locale)
+ (not locale-loaded))
+ (citeproc-style--update-locale style it)
+ (setq locale-loaded t))))
+ ('citation
+ (citeproc-style--update-cite-info style it))
+ ('bibliography
+ (citeproc-style--update-bib-info style it))
+ ('macro
+ (citeproc-style--update-macros style it))))
+ style))
+
+(defun citeproc-style--parse-layout-and-sort-frag (frag)
+ "Parse a citation or bibliography style xml FRAG.
+Return an alist with keys `layout', `opts', `layout-attrs', `sort'
+and `sort-orders'."
+ (let* ((opts (cadr frag))
+ (sort-p (eq (cl-caaddr frag) 'sort))
+ (layout (citeproc-style--transform-xmltree
+ (elt frag (if sort-p 3 2))))
+ (layout-attrs (cl-cadadr (cl-caddr layout)))
+ sort sort-orders)
+ (when sort-p
+ (let* ((sort-frag (cl-caddr frag)))
+ (setq sort (citeproc-style--transform-xmltree sort-frag)
+ sort-orders (--map (not (string= "descending" (alist-get 'sort (cadr it))))
+ (cddr sort-frag)))))
+ `((opts . ,opts) (layout . ,layout) (layout-attrs . ,layout-attrs)
+ (sort . ,sort) (sort-orders . ,sort-orders))))
+
+(defun citeproc-style--update-cite-info (style frag)
+ "Update the cite info of STYLE on the basis of its parsed FRAG."
+ (let-alist (citeproc-style--parse-layout-and-sort-frag frag)
+ (setf (citeproc-style-cite-opts style) .opts
+ (citeproc-style-cite-layout style) .layout
+ (citeproc-style-cite-layout-attrs style) .layout-attrs
+ (citeproc-style-cite-sort style) .sort
+ (citeproc-style-cite-sort-orders style) .sort-orders)))
+
+(defun citeproc-style--update-bib-info (style frag)
+ "Update the bib info of STYLE on the basis of its parsed FRAG."
+ (let-alist (citeproc-style--parse-layout-and-sort-frag frag)
+ (setf (citeproc-style-bib-opts style) .opts
+ (citeproc-style-bib-layout style) .layout
+ (citeproc-style-bib-sort style) .sort
+ (citeproc-style-bib-sort-orders style) .sort-orders)))
+
+(defun citeproc-style--update-macros (style frag)
+ "Update the macro info of STYLE on the basis of its parsed FRAG."
+ (let ((name (cl-cdaadr frag)))
+ (setf (car frag) 'macro)
+ (setf (cadr frag) nil)
+ (push (cons name (citeproc-style--transform-xmltree frag))
+ (citeproc-style-macros style))))
+
+(defun citeproc-style--update-locale (style frag)
+ "Update locale info in STYLE using xml fragment FRAG.
+FRAG should be a parsed locale element from a style or a locale."
+ (--each (cddr frag)
+ (pcase (car it)
+ ('style-options (setf (citeproc-style-locale-opts style)
+ (-concat (citeproc-style-locale-opts style)
+ (cadr it))))
+ ('date
+ (citeproc-style--update-locale-date style it))
+ ('terms
+ (let ((parsed-terms (citeproc-locale-termlist-from-xml-frag (cddr it))))
+ (setf (citeproc-style-terms style)
+ (if (citeproc-style-terms style)
+ (citeproc-term-list-update parsed-terms (citeproc-style-terms style))
+ parsed-terms)))))))
+
+(defun citeproc-style--update-locale-date (style frag)
+ "Update date info in STYLE using xml fragment FRAG.
+FRAG should be a parsed locale element from a style or a locale."
+ (let* ((date-attrs (cadr frag))
+ (form (alist-get 'form date-attrs))
+ (date-format (cons date-attrs
+ (citeproc-lib-named-parts-to-alist frag))))
+ (if (string= form "text")
+ (unless (citeproc-style-date-text style)
+ (setf (citeproc-style-date-text style) date-format))
+ (unless (citeproc-style-date-numeric style)
+ (setf (citeproc-style-date-numeric style) date-format)))))
+
+(defconst citeproc-style--opt-defaults
+ '((cite-opts near-note-distance "5")
+ (locale-opts punctuation-in-quote "false")
+ (locale-opts limit-day-ordinals-to-day-1 "false")
+ (bib-opts hanging-indent "false")
+ (bib-opts line-spacing "1")
+ (bib-opts entry-spacing "1")
+ (opts initialize-with-hyphen "true")
+ (opts demote-non-dropping-particle "display-and-sort"))
+ "Global style options.
+Specified as a list of (STYLE-SLOT OPTION-NAME OPTION-DEFAULT)
+lists.
+
+Note: Collapse-related options are not specified here since their
+default settings are interdependent.")
+
+(defun citeproc-style--set-opt (style opt-slot opt value)
+ "Set OPT in STYLE's OPT-SLOT to VALUE."
+ (setf (cl-struct-slot-value 'citeproc-style opt-slot style)
+ (cons (cons opt value)
+ (cl-struct-slot-value 'citeproc-style opt-slot style))))
+
+(defun citeproc-style--set-opt-defaults (style)
+ "Set missing options of STYLE to their default values."
+ (cl-loop
+ for (slot option value) in citeproc-style--opt-defaults do
+ (let ((slot-value (cl-struct-slot-value 'citeproc-style slot style)))
+ (unless (alist-get option slot-value)
+ (setf (cl-struct-slot-value 'citeproc-style slot style)
+ (cons (cons option value) slot-value)))))
+ (let* ((cite-opts (citeproc-style-cite-opts style))
+ (collapse (alist-get 'collapse cite-opts)))
+ (when (and collapse (not (string= collapse "citation-number")))
+ (let ((cite-layout-dl
+ (alist-get 'delimiter (citeproc-style-cite-layout-attrs style)))
+ (cite-group-dl
+ (alist-get 'cite-group-delimiter cite-opts)))
+ (unless cite-group-dl
+ (citeproc-style--set-opt style 'cite-opts 'cite-group-delimiter ", "))
+ (unless (alist-get 'after-collapse-delimiter cite-opts)
+ (citeproc-style--set-opt
+ style 'cite-opts 'after-collapse-delimiter cite-layout-dl))
+ (when (and (member collapse '("year-suffix" "year-suffix-ranged"))
+ (null (alist-get 'year-suffix-delimiter cite-opts)))
+ (citeproc-style--set-opt
+ style 'cite-opts 'year-suffix-delimiter cite-layout-dl))))))
+
+(defun citeproc-style--transform-xmltree (tree)
+ "Transform parsed csl xml fragment TREE into a lambda."
+ `(lambda (context) ,(citeproc-style--transform-xmltree-1 tree)))
+
+(defun citeproc-style--transform-xmltree-1 (tree)
+ "Transform parsed xml fragment TREE into an eval-able form.
+Symbols in car position are prefixed with `citeproc--' and the
+symbol `context' is inserted everywhere after the second (attrs)
+position and before the (possibly empty) body."
+ (pcase tree
+ ((pred atom) tree)
+ (`(names . ,_) (citeproc-style--transform-names tree))
+ (_
+ `(,(intern (concat "citeproc--" (symbol-name (car tree))))
+ ,(list 'quote (cadr tree))
+ context
+ ,@(mapcar #'citeproc-style--transform-xmltree-1 (cddr tree))))))
+
+(defun citeproc-style--transform-names (frag)
+ "Transform the content of a cs:names CSL element xml FRAG."
+ (let* ((names-attrs (cadr frag))
+ (body (-remove #'stringp (cddr frag)))
+ (vars (alist-get 'variable names-attrs))
+ substs name-attrs name-parts et-al-attrs
+ is-label label-attrs label-before-names)
+ (--each body
+ (pcase (car it)
+ ('name
+ (setq name-attrs (cadr it)
+ name-parts (citeproc-lib-named-parts-to-alist it)
+ label-before-names t))
+ ('et-al
+ (setq et-al-attrs (cadr it)))
+ ('label
+ (setq is-label t
+ label-attrs (cadr it)
+ label-before-names nil))
+ ('substitute
+ (setq substs
+ (mapcar
+ (lambda (x)
+ (if (eq (car x) 'names)
+ `(citeproc-name-render-vars
+ ,(alist-get 'variable (cadr x))
+ names-attrs name-attrs name-parts et-al-attrs
+ is-label label-before-names label-attrs context)
+ (citeproc-style--transform-xmltree-1 x)))
+ (cddr it))))))
+ `(if (citeproc-var-value 'suppress-author context) (cons nil 'empty-vars)
+ (let* ((names-attrs ',names-attrs)
+ (name-attrs ',name-attrs)
+ (count (string= (alist-get 'form name-attrs) "count"))
+ (et-al-attrs ',et-al-attrs)
+ (name-parts ',name-parts)
+ (label-attrs ',label-attrs)
+ (is-label ,is-label)
+ (label-before-names ,label-before-names)
+ (val (citeproc-name-render-vars
+ ,vars names-attrs name-attrs name-parts et-al-attrs
+ is-label label-before-names label-attrs context))
+ (result (if (car val)
+ val
+ (-if-let ((cont . type) (--first (car it)
+ (list ,@substs)))
+ (cons (cons (list '(subst . t)) (list cont)) type)
+ (cons nil 'empty-vars))))
+ (final (if count
+ (let* ((number (citeproc-rt-count-names (car result)))
+ (str (if (= 0 number) "" (number-to-string number))))
+ (cons str (cdr result)))
+ result)))
+ ;; Handle `author' citation mode by stopping if needed
+ (citeproc-context-maybe-stop-rendering 'names context final)))))
+
+(defun citeproc-style-cite-note (style)
+ "Return whether csl STYLE is a note style."
+ (string= (citeproc-style-category style) "note"))
+
+(defun citeproc-style-cite-superscript-p (style)
+ "Return whether csl STYLE has a superscript citaton layout."
+ (string= (alist-get 'vertical-align (citeproc-style-cite-layout-attrs style))
+ "sup"))
+
+(defun citeproc-style-global-opts (style layout)
+ "Return the global opts in STYLE for LAYOUT.
+LAYOUT is either `bib' or `cite'."
+ (-concat (cl-ecase layout
+ (bib (citeproc-style-bib-opts style))
+ (cite (citeproc-style-cite-opts style)))
+ (citeproc-style-opts style)))
+
+(defun citeproc-style-bib-opts-to-formatting-params (bib-opts)
+ "Convert BIB-OPTS to a formatting parameters alist."
+ (let ((result
+ (cl-loop
+ for (opt . val) in bib-opts
+ if (memq opt
+ '(hanging-indent line-spacing entry-spacing second-field-align))
+ collect (cons opt
+ (pcase val
+ ("true" t)
+ ("false" nil)
+ ("flush" 'flush)
+ ("margin" 'margin)
+ (_ (string-to-number val)))))))
+ (if (alist-get 'second-field-align result)
+ result
+ (cons (cons 'second-field-align nil)
+ result))))
+
+(provide 'citeproc-style)
+
+;;; citeproc-style.el ends here
--- /dev/null
+;;; citeproc-subbibs.el --- support for subbibliographies -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2021-2022 András Simonyi
+
+;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
+
+;; 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 3 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.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Support for generating subbibliographies based on filtering items.
+
+;;; Code:
+
+(require 'subr-x)
+(require 'compat)
+(require 'dash)
+
+(require 'citeproc-proc)
+(require 'citeproc-itemdata)
+
+(defun citeproc-sb--match-p (vv filter)
+ "Return whether var-vals alist VV matches all conditions in FILTER.
+FILTER should be an alist containing symbol keys and string
+values, each pair describing an atomic condition to be
+satisified. For a list and description of the supported keys
+see the documentation of `citeproc-add-subbib-filters'."
+ (let* ((csl-type (alist-get 'type vv))
+ (type (or (alist-get 'blt-type vv) csl-type))
+ (keyword (alist-get 'keyword vv))
+ (keywords (and keyword (mapcar #'string-clean-whitespace
+ (split-string keyword "[,;]" t)))))
+ (--every-p
+ (pcase it
+ (`(type . ,key) (string= type key))
+ (`(nottype . ,key) (not (string= type key)))
+ (`(keyword . ,key) (member key keywords))
+ (`(notkeyword . ,key) (not (member key keywords)))
+ (`(filter . ,key) (funcall (intern key) vv))
+ (`(csltype . ,key) (string= csl-type key))
+ (`(notcsltype . ,key) (not (string= csl-type key)))
+ (`(,key . ,_) (error "Unsupported Citeproc filter keyword `%s'" key)))
+ filter)))
+
+(defun citeproc-sb-add-subbib-info (proc)
+ "Add subbibliography information to the items in PROC."
+ (when (citeproc-proc-filtered-bib-p proc)
+ (let ((filters (citeproc-proc-bib-filters proc)))
+ (maphash
+ (lambda (_ itemdata)
+ (let* ((varvals (citeproc-itemdata-varvals itemdata))
+ (subbib-nos
+ (-non-nil
+ (--map-indexed
+ (when (citeproc-sb--match-p varvals it) it-index)
+ filters))))
+ (setf (citeproc-itemdata-subbib-nos itemdata) subbib-nos)))
+ (citeproc-proc-itemdata proc)))))
+
+(defun citeproc-sb-prune-unrendered (proc)
+ "Remove all itemdata about unrendered items from PROC.
+An item is unrendered if
+- there are subbibfilters but none of them matches it, and
+- it is not cited."
+ (when (citeproc-proc-filtered-bib-p proc)
+ (let ((itemdata (citeproc-proc-itemdata proc)))
+ (maphash
+ (lambda (id data)
+ (when (and (citeproc-itemdata-uncited data)
+ (null (citeproc-itemdata-subbib-nos data)))
+ (remhash id itemdata)))
+ itemdata))))
+
+(provide 'citeproc-subbibs)
+
+;;; citeproc-subbibs.el ends here
--- /dev/null
+;;; citeproc-term.el --- functions for term localization -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017 András Simonyi
+
+;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
+
+;; 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 3 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.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Functions for localizing the terms of a CSL style according to a locale.
+
+;;; Code:
+
+(require 'dash)
+(require 'cl-lib)
+(require 'let-alist)
+
+(require 'citeproc-lib)
+(require 'citeproc-s)
+
+(cl-defstruct (citeproc-term (:constructor citeproc-term--create))
+ "A struct representing a localized term."
+ (name nil) (form nil) (number nil) (gender nil) (gender-form nil)
+ (match nil) (text nil))
+
+(defun citeproc-term--compare (t1 t2)
+ "Compare terms T1 and T2.
+The comparison is based on the term fields except the last one,
+and relies on the alphabetical ordering of fields' string
+content (see the function `citeproc-lib-s-content'). Return 1, -1
+or 0 iff T1 precedes, succeeds or is equal according to the
+ordering."
+ (cond ((not t2) 1)
+ ((not t1) -1)
+ (t (let ((idx 1)
+ (result 0))
+ (while (and (= result 0) (< idx 7))
+ (let ((s1 (citeproc-s-content (aref t1 idx)))
+ (s2 (citeproc-s-content (aref t2 idx))))
+ (cond ((string< s1 s2) (setq result 1))
+ ((string> s1 s2) (setq result -1))))
+ (cl-incf idx)) result))))
+
+(defun citeproc-term-list--sort (tl)
+ "Sort termlist TL in place using `citeproc-term--compare'."
+ (cl-sort tl (lambda (x y) (> (citeproc-term--compare x y) -1))))
+
+(defun citeproc-term-list-update (tl1 tl2 &optional sorted-input)
+ "Return a term list which is TL1 updated with term list TL2.
+TL1 and TL2 are list of citeproc-term structs. The order of terms
+in the returned term list is undetermined. If the optional
+SORTED-INPUT is non-nil then the term lists are supposed to be
+already sorted according to `citeproc-term--compare', otherwise
+they are sorted in-place."
+ (let (result)
+ (unless sorted-input
+ (setq tl1 (citeproc-term-list--sort tl1)
+ tl2 (citeproc-term-list--sort tl2)))
+ (while (or tl1 tl2)
+ (let* ((t1 (car tl1))
+ (t2 (car tl2))
+ (cmp (citeproc-term--compare t1 t2)))
+ (cond ((= cmp 1) (push t1 result) (pop tl1))
+ ((= cmp -1) (push t2 result) (pop tl2))
+ (t (push t2 result) (pop tl1) (pop tl2)))))
+ result))
+
+(defun citeproc-term--from-xml-frag (frag)
+ "Transform xml FRAG representing a term into a citeproc-term struct."
+ (let-alist (car frag)
+ (-let* ((.form (or .form "long"))
+ (term (citeproc-term--create
+ :name .name
+ :form (citeproc-lib-intern .form)
+ :gender (citeproc-lib-intern .gender)
+ :match (citeproc-lib-intern .match)
+ :gender-form (citeproc-lib-intern .gender-form))))
+ (if (= (length frag) 2)
+ (progn
+ (setf (citeproc-term-text term) (cadr frag))
+ (list term))
+ (setf (citeproc-term-text term) (cl-caddr (cadr frag)))
+ (setf (citeproc-term-number term) 'single)
+ (let ((multi-term (copy-citeproc-term term)))
+ (setf (citeproc-term-text multi-term) (cl-caddr (cl-caddr frag)))
+ (setf (citeproc-term-number multi-term) 'multiple)
+ (list term multi-term))))))
+
+(defun citeproc-term-text-from-terms (term terms)
+ "Return the first text associated with TERM in TERMS.
+Return nil if TERM is not in TERMS."
+ (-if-let (match (--first (string= term (citeproc-term-name it))
+ terms))
+ (citeproc-term-text match)
+ nil))
+
+(provide 'citeproc-term)
+
+;;; citeproc-term.el ends here
--- /dev/null
+;; citeproc-test-human.el --- support tests in CSL suite format -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017-2021 András Simonyi
+
+;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
+
+;; 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 3 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.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Functions to create ERT tests from tests in CSL test suite format. The
+;; official tests can be found at
+;; <https://github.com/citation-style-language/test-suite>.
+
+;;; Code:
+
+(require 'f)
+(require 's)
+(require 'json)
+(require 'ert)
+(require 'string-inflection)
+
+(require 'citeproc)
+
+(defvar citeproc-test-human--locale-dir "./test/locales")
+
+(defun citeproc-test-human--parse-testfile (file)
+ "Return a parsed form of CSL test FILE."
+ (let (result
+ (json-array-type 'list)
+ (json-key-type 'symbol))
+ (with-temp-buffer
+ (insert-file-contents file)
+ (goto-char 1)
+ (setq result (list (cons 'YEAR-SUFF
+ (re-search-forward "variable=\"year-suffix\"" nil t))))
+ (goto-char 1)
+ (while (re-search-forward ">>=+ \\{1,2\\}\\([[:graph:]]+\\) =+>>" nil t)
+ (let ((section (intern (buffer-substring (nth 2 (match-data))
+ (nth 3 (match-data)))))
+ (start (1+ (point)))
+ end)
+ (re-search-forward "<<=" nil t)
+ (setq end (- (car (match-data)) 1))
+ (push (cons section (pcase section
+ ('OUTPUT-FORMAT
+ (intern (buffer-substring-no-properties start end)))
+ ('CSL (buffer-substring-no-properties start end))
+ ((or 'INPUT 'CITATIONS 'CITATION-ITEMS)
+ (goto-char (- start 1)) (json-read))
+ (_ (buffer-substring start end))))
+ result))))
+ result))
+
+(defun citeproc-test-human--create-getter (items)
+ "Return a getter function for ITEMS.
+ITEMS is the parsed representation of the `INPUT' section of a
+CSL test."
+ (lambda (itemids)
+ (let (result)
+ (dolist (item items result)
+ (let ((id (citeproc-s-from-num-or-s (alist-get 'id item))))
+ (when (member id itemids)
+ (push (cons id item) result)))))))
+
+(defun citeproc-test-human--proc-from-style (style parsed-input)
+ "Create a processor from STYLE and PARSED-INPUT."
+ (citeproc-create style
+ (citeproc-test-human--create-getter parsed-input)
+ (citeproc-locale-getter-from-dir citeproc-test-human--locale-dir)))
+
+(defun citeproc-test-human--proc-from-testfile (file)
+ "Create an (itemless) processor from a test FILE."
+ (let ((style-string (alist-get 'CSL (citeproc-test-human--parse-testfile file)))
+ (locale-getter (citeproc-locale-getter-from-dir citeproc-test-human--locale-dir)))
+ (citeproc-create style-string nil locale-getter)))
+
+(defun citeproc-test-human--parse-citation (ct-desc &optional cites-only)
+ "Parse test citations description CT-DESC.
+Return a list of citation structures. If CITES-ONLY is non-nil
+then the input is list of cites."
+ (if cites-only
+ (citeproc-citation-create
+ :cites (-map #'citeproc-test-human--normalize-cite ct-desc))
+ (let ((citation-info (car ct-desc)))
+ (let-alist (alist-get 'properties citation-info)
+ (citeproc-citation-create
+ :cites (-map #'citeproc-test-human--normalize-cite
+ (alist-get 'citationItems citation-info))
+ :note-index .noteIndex
+ :mode (citeproc-lib-intern .mode)
+ :capitalize-first .capitalize-first
+ :suppress-affixes .suppress-affixes
+ :ignore-et-al .ignore-et-al)))))
+
+(defun citeproc-test-human--normalize-cite (cite)
+ "Normalize a test CITE."
+ (--map (let ((val (cdr it)))
+ (if (numberp val) (cons (car it) (number-to-string val)) it))
+ cite))
+
+(defun citeproc-test-human--run-parsed (parsed)
+ "Run the parsed CSL test PARSED.
+Return the resulting output."
+ (-let* (((&alist 'CSL style
+ 'INPUT input
+ 'MODE mode
+ 'CITATION-ITEMS citation-items
+ 'CITATIONS citations
+ 'OUTPUT-FORMAT output-format)
+ parsed)
+ (output-format (or output-format 'csl-test))
+ (proc (citeproc-test-human--proc-from-style style input)))
+ (--each input
+ (citeproc-proc-put-item-by-id proc
+ (citeproc-s-from-num-or-s (alist-get 'id it))))
+ (when (string= mode "citation")
+ (cond
+ (citation-items
+ (citeproc-append-citations (--map (citeproc-test-human--parse-citation it t)
+ citation-items)
+ proc))
+ (citations
+ (citeproc-append-citations (mapcar #'citeproc-test-human--parse-citation citations)
+ proc))
+ (t (citeproc-append-citations (list (citeproc-test-human--parse-citation input t))
+ proc))))
+ (let ((output (if (string= mode "citation")
+ (citeproc-render-citations proc output-format
+ (when (eq 'csl-test output-format)
+ 'no-links))
+ (car (citeproc-render-bib proc output-format 'no-links)))))
+ (if (string= mode "citation") (s-join "\n" output) output))))
+
+(defun citeproc-test-human--expected-from-parsed (parsed)
+ "Return the expected output of parsed CSL test PARSED."
+ (let ((expected (alist-get 'RESULT parsed)))
+ (if (or (string= (s-left 5 expected) "..[0]")
+ (string= (s-left 5 expected) ">>[0]"))
+ (s-join "\n" (--map (substring it 6)
+ (split-string expected "\n")))
+ expected)))
+
+(defun citeproc-test-human-create-from-file (file expected-fails &optional name-prefix)
+ "Create an ERT test from a CSL test FILE.
+If optional NAME-PREFIX is non-nil then it is added the name of
+the created test after the obligatory `citeproc'."
+ (let* ((parsed (citeproc-test-human--parse-testfile file))
+ (expected (citeproc-test-human--expected-from-parsed parsed))
+ (file-name (f-filename file))
+ (test-name (intern
+ (concat "citeproc-"
+ (if name-prefix (concat name-prefix "-") "")
+ (string-inflection-kebab-case-function
+ (substring file-name 0 -4)))))
+ (expected-fail (memq test-name expected-fails)))
+ (eval `(ert-deftest ,test-name ()
+ :expected-result ,(if expected-fail :failed :passed)
+ (let ((citeproc-disambiguation-cite-pos 'subsequent))
+ (should (string=
+ ,expected
+ (citeproc-test-human--run-parsed ',parsed))))))))
+
+(defun citeproc-test-human---read-expected-fails (expected-fails-file)
+ "Read the list of tests expected to fail from EXPECTED-FAILS-FILE."
+ (let* ((list-as-str (with-temp-buffer
+ (insert-file-contents expected-fails-file)
+ (buffer-string)))
+ (split (split-string list-as-str "\n")))
+ (--map (intern it) (butlast split))))
+
+(defun citeproc-test-human-create-from-dir (dir &optional
+ expected-fails-file name-prefix)
+ "Create all CSL tests from DIR.
+Each file in DIR having the `txt' extension is read as a
+human-readable CSL test, and a corresponding ERT test is created.
+The created test's name will be constructed by prefixing the
+test's filename (without the extension) with `citeproc-'. If the
+optional EXPECTED-FAILS-FILE is non-nil then read that file as a
+list of tests whose failure is expected. If optional NAME-PREFIX
+is non-nil then it is added the names of the created tests after
+the obligatory `citeproc'. The file should contain one test-name
+per line (together with the `citeproc-' prefix)."
+ (let ((expected-fails
+ (if expected-fails-file
+ (citeproc-test-human---read-expected-fails expected-fails-file)
+ nil)))
+ (dolist (test-file (f-glob (concat dir "/*.txt")))
+ (citeproc-test-human-create-from-file test-file expected-fails
+ name-prefix))))
+
+(provide 'citeproc-test-human)
+
+;;; citeproc-test-human.el ends here
--- /dev/null
+;;; citeproc.el --- A CSL 1.0.2 Citation Processor -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017-2024 András Simonyi
+
+;; Author: András Simonyi <andras.simonyiNOSPAMgmail.com>
+;; Maintainer: András Simonyi <andras.simonyiNOSPAMgmail.com>
+;; URL: https://github.com/andras-simonyi/citeproc-el
+;; Keywords: bib
+;; Package-Requires: ((emacs "26") (dash "2.13.0") (s "1.12.0") (f "0.18.0") (queue "0.2") (string-inflection "1.0") (org "9") (parsebib "2.4")(compat "28.1"))
+;; Package-Version: 20260113.1047
+;; Package-Revision: 4bde999a4180
+
+;; 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 3 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.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; citeproc-el is a library for rendering citations and bibliographies in styles
+;; described in the Citation Style Language (CSL).
+
+;;; Code:
+
+(require 'dash)
+(require 'queue)
+
+(require 'citeproc-rt)
+(require 'citeproc-locale)
+(require 'citeproc-style)
+(require 'citeproc-choose)
+(require 'citeproc-generic-elements)
+(require 'citeproc-context)
+(require 'citeproc-itemdata)
+(require 'citeproc-proc)
+(require 'citeproc-cite)
+(require 'citeproc-sort)
+(require 'citeproc-formatters)
+(require 'citeproc-itemgetters)
+(require 'citeproc-subbibs)
+
+;;; Public API
+
+(defun citeproc-create (style it-getter loc-getter &optional loc force-loc)
+ "Return a CSL processor for a given STYLE, IT-GETTER and LOC-GETTER.
+STYLE is either a path to a CSL style file or a CSL style as a
+ string.
+IT-GETTER is an item-getter function that takes a list of itemid
+ strings as its sole argument and returns an alist in which the
+ given itemids are the keys and the values are the parsed csl
+ json descriptions of the corresponding bibliography items (keys
+ are symbols, arrays and hashes should be represented as lists
+ and alists, respecively).
+LOC-GETTER is a function that takes a locale string (e.g.
+ \"en-GB\") as an argument and returns a corresponding parsed
+ CSL locale (as parsed by Emacs's `libxml-parse-xml-region').
+Optional LOC is the locale to use if the style doesn't specify a
+ default one. Defaults to \"en-US\".
+If optional FORCE-LOC is non-nil then use locale LOC even if
+ STYLE specifies a different one as default. Defaults to nil."
+ (let ((style (citeproc-create-style style loc-getter loc force-loc))
+ (names (make-hash-table :test 'equal))
+ (itemdata (make-hash-table :test 'equal))
+ (citations (make-queue)))
+ (citeproc-proc--create :style style :getter it-getter :names names
+ :itemdata itemdata :citations citations :finalized t)))
+
+(defun citeproc-append-citations (citations proc)
+ "Append CITATIONS to the list of citations in PROC.
+CITATIONS is a list of `citeproc-citation' structures."
+ (let ((itemdata (citeproc-proc-itemdata proc))
+ ids)
+ ;; Collect new itemids
+ (dolist (citation citations)
+ (dolist (cite (citeproc-citation-cites citation))
+ (push (alist-get 'id cite) ids)))
+ (let* ((uniq-ids (delete-dups (nreverse ids))) ; reverse pushed ids
+ (new-ids (--remove (gethash it itemdata) uniq-ids)))
+ ;; Add all new items in one pass
+ (citeproc-proc-put-items-by-id proc new-ids)
+ ;; Internalize the cites dealing with locator-extra if present, add itemdata to
+ ;; the cite structs and add them to the cite queue.
+ (dolist (citation citations)
+ (setf (citeproc-citation-cites citation)
+ (--map (cons (cons 'itd (gethash (alist-get 'id it) itemdata))
+ (citeproc-cite--internalize-locator it))
+ (citeproc-citation-cites citation)))
+ (queue-append (citeproc-proc-citations proc) citation))
+ (setf (citeproc-proc-finalized proc) nil))))
+
+(defun citeproc-add-uncited (itemids proc)
+ "Add uncited bib items with ITEMIDS to PROC.
+As an extension, an itemid can be the string \"*\" which has the
+effect of adding all items available in the itemgetter."
+ ;; We simply store the added ids here, real processing is performed when the
+ ;; processor is finalized.
+ (push itemids (citeproc-proc-uncited proc))
+ (setf (citeproc-proc-finalized proc) nil))
+
+(defun citeproc-add-subbib-filters (filters proc)
+ "Add sub-bibliography FILTERS to PROC.
+FILTERS should be a list of alists containing symbol keys and
+string values, each pair describing an atomic condition to be
+satisified by the printed entries. The following keys are
+supported:
+- `type': print only entries of the given type. Type is the
+ bib(la)tex entry type if available, otherwise the CSL type is
+ used as fallback;
+- `nottype': print only entries not of the given type. Type is
+ the bib(la)tex entry type if available, otherwise the CSL type
+ is used as fallback;
+- `csltype', `notcsltype': same as `type' and `nottype' but uses
+ the entries' CSL type even if the bib(la)tex type is also
+ available;
+- `keyword': print only entries with the given keyword;
+- `notkeyword': print only entries without the given keyword;
+- `filter': print only entries for which the function named by
+ the key returns a non-nil value."
+ (setf (citeproc-proc-bib-filters proc) filters
+ (citeproc-proc-finalized proc) nil))
+
+(defun citeproc-render-citations (proc format &optional internal-links)
+ "Render all citations in PROC in the given FORMAT.
+Return a list of formatted citations.
+ If the optional INTERNAL-LINKS is `bib-links' then link cites
+to the bibliography regardless of the style type, if `no-links'
+then don't add internal links, if nil or `auto' then add internal
+links based on the style type (cite-cite links for note styles
+and cite-bib links else). For legacy reasons, any other value is
+treated as `no-links'."
+ (citeproc-proc-finalize proc)
+ (--map (citeproc-citation--render-formatted-citation it proc format internal-links)
+ (queue-head (citeproc-proc-citations proc))))
+
+(defun citeproc-render-bib (proc format &optional internal-links
+ no-external-links bib-formatter-fun)
+ "Render a bibliography of items in PROC in FORMAT.
+For the optional INTERNAL-LINKS argument see
+`citeproc-render-citations'. If the optional NO-EXTERNAL-LINKS is
+non-nil then don't generate external links. If the optional
+BIB-FORMATTER-FUN is given then it will be used to join the
+bibliography items instead of the content of the chosen
+formatter's `bib' slot (see `citeproc-formatter' for details).
+
+Returns an error message string if the style of PROC doesn't
+contain a bibliography section. Otherwise it returns
+a (FORMATTED-BIBLIOGRAPHY . FORMATTING-PARAMETERS) cons cell,
+where FORMATTED-BIBLIOGRAPHY is either a single bibliography or a
+list of sub-bibliograhies if filters were added to the processor,
+and FORMATTING-PARAMETERS is an alist containing the following
+formatting parameters keyed to the parameter names as symbols:
+- `max-offset' (integer): The width of the widest first field in
+ the bibliography, measured in characters.
+- `line-spacing' (integer): Vertical line distance specified as a
+ multiple of standard line height.
+- `entry-spacing' (integer): Vertical distance between
+ bibliographic entries, specified as a multiple of standard line
+ height.
+- `second-field-align' (`flush'or `margin'): The position of
+ second-field alignment.
+- `hanging-indent' (boolean): Whether the bibliography items should
+ be rendered with hanging-indents."
+ (if (null (citeproc-style-bib-layout (citeproc-proc-style proc)))
+ "[NO BIBLIOGRAPHY LAYOUT IN CSL STYLE]"
+ (citeproc-proc-finalize proc)
+ (let* ((formatter (citeproc-formatter-for-format format))
+ (rt-formatter (citeproc-formatter-rt formatter))
+ (bib-formatter (or bib-formatter-fun
+ (citeproc-formatter-bib formatter)))
+ (bibitem-formatter (citeproc-formatter-bib-item formatter))
+ (formatter-no-external-links (citeproc-formatter-no-external-links
+ formatter))
+ (style (citeproc-proc-style proc))
+ (bib-opts (citeproc-style-bib-opts style))
+ (punct-in-quote (string= (alist-get 'punctuation-in-quote
+ (citeproc-style-locale-opts style))
+ "true"))
+ (itemdata (citeproc-proc-itemdata proc))
+ (filters (citeproc-proc-bib-filters proc)))
+ ;; Render raw bibitems for each itemdata struct and store them in the
+ ;; `rawbibitem' slot.
+ (maphash (lambda (_ itd)
+ (setf (citeproc-itemdata-rawbibitem itd)
+ (citeproc-rt-finalize
+ (citeproc-render-varlist-in-rt
+ (citeproc-itemdata-varvals itd)
+ style 'bib 'display internal-links
+ (or formatter-no-external-links no-external-links))
+ punct-in-quote)))
+ itemdata)
+ (let* ((raw-bib
+ (if (citeproc-proc-filtered-bib-p proc)
+ ;; There are filters, we need to select and sort the subbibs.
+ (let* ((nr-of-filters (length filters))
+ (result (make-list nr-of-filters nil))
+ ;; We store boolean to-be-sorted flags for each sub-bib
+ (to-be-sorted (make-bool-vector nr-of-filters nil))
+ (bib-sort (citeproc-style-bib-sort (citeproc-proc-style proc))))
+ ;; Put the itds into subbib lists.
+ (maphash
+ (lambda (_ itd)
+ (let ((subbib-nos (citeproc-itemdata-subbib-nos itd)))
+ ;; Set to-be-sorted for later subbibs if itemdata
+ ;; occcurs in more than one.
+ (when-let ((later-subbib-nos (cdr subbib-nos)))
+ (dolist (subbib-no later-subbib-nos)
+ (setf (elt to-be-sorted subbib-no) t)))
+ ;; Push the item in all corresponding subbibs.
+ (dolist (subbib-no subbib-nos)
+ (push itd (elt result subbib-no)))))
+ itemdata)
+ ;; Sort the itds in each individual list
+ (setq result
+ (--map-indexed
+ (if (and bib-sort (elt to-be-sorted it-index))
+ ;; Subbib contains earlier item, needs to sorted.
+ (citeproc-sort-itds it (citeproc-style-bib-sort-orders
+ (citeproc-proc-style proc)))
+ ;; No earlier item, sorting on citation-number.
+ (citeproc-sort-itds-on-citnum it))
+ result))
+ ;; Generate the raw bibs.
+ (--map (mapcar #'citeproc-itemdata-rawbibitem it) result))
+ ;; No filters, so raw-bib is a list containing a single raw bibliograhy.
+ (list (mapcar #'citeproc-itemdata-rawbibitem
+ (citeproc-sort-itds-on-citnum (hash-table-values itemdata))))))
+ ;; Perform author-substitution.
+ (substituted
+ (-if-let (subs-auth-subst
+ (alist-get 'subsequent-author-substitute bib-opts))
+ (--map (citeproc-rt-subsequent-author-substitute it subs-auth-subst)
+ raw-bib)
+ raw-bib))
+ ;; Calculate formatting params.
+ ;; NOTE: This is the only place where we check whether there are
+ ;; bibliography items in the processor, even though the empty case
+ ;; could be handled way more efficiently.
+ (max-offset (if (and (alist-get 'second-field-align bib-opts)
+ (not (hash-table-empty-p itemdata)))
+ (citeproc-proc-max-offset itemdata)
+ 0))
+ (format-params (cons (cons 'max-offset max-offset)
+ (citeproc-style-bib-opts-to-formatting-params bib-opts)))
+ (formatted-bib
+ (--map (funcall bib-formatter
+ (mapcar
+ (lambda (x)
+ (funcall
+ bibitem-formatter
+ (funcall
+ rt-formatter (citeproc-rt-cull-spaces-puncts x))
+ format-params))
+ it)
+ format-params)
+ substituted)))
+ ;; Generate final return value.
+ (cons (if filters formatted-bib (car formatted-bib))
+ format-params)))))
+
+(defun citeproc-clear (proc)
+ "Remove all bibliographic and citation data from PROC."
+ (clrhash (citeproc-proc-itemdata proc))
+ (clrhash (citeproc-proc-names proc))
+ (queue-clear (citeproc-proc-citations proc))
+ (setf (citeproc-proc-finalized proc) t))
+
+;; For one-off renderings
+
+(defun citeproc-create-style (style locale-getter &optional locale force-locale)
+ "Compile style in STYLE into a citeproc-style struct.
+STYLE is either a path to a CSL style file, or a style as a
+string. LOCALE-GETTER is a getter function for locales, the
+optional LOCALE is a locale to prefer. If FORCE-LOCALE is non-nil
+then use LOCALE even if the style's default locale is different."
+ (-let* (((year-suffix . parsed-style) (citeproc-style-parse style))
+ (default-locale (alist-get 'default-locale (cadr parsed-style)))
+ (preferred-locale (if force-locale locale (or default-locale
+ locale
+ "en-US")))
+ (act-parsed-locale (funcall locale-getter preferred-locale))
+ (act-locale (alist-get 'lang (cadr act-parsed-locale)))
+ (style (citeproc-create-style-from-locale
+ parsed-style
+ (not (not year-suffix)) act-locale)))
+ (citeproc-style--update-locale style act-parsed-locale)
+ (citeproc-style--set-opt-defaults style)
+ (setf (citeproc-style-locale style) (or locale act-locale))
+ style))
+
+;; REVIEW: this should be rethought -- should we apply the specific wrappers as
+;; well?
+(defun citeproc-render-item (item-data style mode format
+ &optional no-external-links)
+ "Render a bibliography item described by ITEM-DATA with STYLE.
+ITEM-DATA is the parsed form of a bibliography item description
+ in CSL-JSON format,
+STYLE is a `citeproc-style' structure,
+MODE is one of the symbols `bib' or `cite',
+FORMAT is a symbol representing a supported output format.
+If the optional NO-EXTERNAL-LINKS is non-nil then don't generate
+external links in the item."
+ (let ((internal-varlist (--map-when (memq (car it) citeproc--date-vars)
+ (cons (car it)
+ (citeproc-date-parse (cdr it)))
+ item-data)))
+ (funcall (citeproc-formatter-rt (citeproc-formatter-for-format format))
+ (citeproc-rt-cull-spaces-puncts
+ (citeproc-rt-finalize
+ (citeproc-render-varlist-in-rt
+ internal-varlist style mode 'display 'no-links no-external-links))))))
+
+(provide 'citeproc)
+
+;;; citeproc.el ends here
projects / emacsconfig.git / commitdiff