;;; citeproc-cite.el --- cite and citation rendering -*- lexical-binding: t; -*- ;; Copyright (C) 2017-2024 András Simonyi ;; Author: András Simonyi ;; 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 . ;; 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