From 5068bab12104ea607c5bd5617df3b639477c2243 Mon Sep 17 00:00:00 2001 From: Daniel Weschke Date: Wed, 5 Jan 2022 10:56:16 +0100 Subject: [PATCH] add missing libs and update settings to new versions --- lisp/citeproc/citeproc-biblatex.el | 521 +++++++++++++++++++ lisp/citeproc/citeproc-bibtex.el | 481 +++++++++++++++++ lisp/citeproc/citeproc-choose.el | 118 +++++ lisp/citeproc/citeproc-cite.el | 536 +++++++++++++++++++ lisp/citeproc/citeproc-context.el | 270 ++++++++++ lisp/citeproc/citeproc-date.el | 280 ++++++++++ lisp/citeproc/citeproc-disamb.el | 247 +++++++++ lisp/citeproc/citeproc-formatters.el | 331 ++++++++++++ lisp/citeproc/citeproc-generic-elements.el | 148 ++++++ lisp/citeproc/citeproc-itemdata.el | 101 ++++ lisp/citeproc/citeproc-itemgetters.el | 178 +++++++ lisp/citeproc/citeproc-lib.el | 164 ++++++ lisp/citeproc/citeproc-locale.el | 93 ++++ lisp/citeproc/citeproc-macro.el | 58 +++ lisp/citeproc/citeproc-name.el | 438 ++++++++++++++++ lisp/citeproc/citeproc-number.el | 160 ++++++ lisp/citeproc/citeproc-pkg.el | 19 + lisp/citeproc/citeproc-prange.el | 128 +++++ lisp/citeproc/citeproc-proc.el | 224 ++++++++ lisp/citeproc/citeproc-rt.el | 569 +++++++++++++++++++++ lisp/citeproc/citeproc-s.el | 274 ++++++++++ lisp/citeproc/citeproc-sort.el | 191 +++++++ lisp/citeproc/citeproc-style.el | 344 +++++++++++++ lisp/citeproc/citeproc-subbibs.el | 65 +++ lisp/citeproc/citeproc-term.el | 113 ++++ lisp/citeproc/citeproc-test-human.el | 207 ++++++++ lisp/citeproc/citeproc.el | 290 +++++++++++ lisp/my/my.el | 10 - lisp/queue.el | 192 +++++++ lisp/string-inflection.el | 396 ++++++++++++++ lisp/versions | 19 +- settings/bibliography-settings.el | 4 + settings/gui-settings.el | 160 +++--- settings/mail-settings.el | 10 +- 34 files changed, 7215 insertions(+), 124 deletions(-) create mode 100644 lisp/citeproc/citeproc-biblatex.el create mode 100644 lisp/citeproc/citeproc-bibtex.el create mode 100644 lisp/citeproc/citeproc-choose.el create mode 100644 lisp/citeproc/citeproc-cite.el create mode 100644 lisp/citeproc/citeproc-context.el create mode 100644 lisp/citeproc/citeproc-date.el create mode 100644 lisp/citeproc/citeproc-disamb.el create mode 100644 lisp/citeproc/citeproc-formatters.el create mode 100644 lisp/citeproc/citeproc-generic-elements.el create mode 100644 lisp/citeproc/citeproc-itemdata.el create mode 100644 lisp/citeproc/citeproc-itemgetters.el create mode 100644 lisp/citeproc/citeproc-lib.el create mode 100644 lisp/citeproc/citeproc-locale.el create mode 100644 lisp/citeproc/citeproc-macro.el create mode 100644 lisp/citeproc/citeproc-name.el create mode 100644 lisp/citeproc/citeproc-number.el create mode 100644 lisp/citeproc/citeproc-pkg.el create mode 100644 lisp/citeproc/citeproc-prange.el create mode 100644 lisp/citeproc/citeproc-proc.el create mode 100644 lisp/citeproc/citeproc-rt.el create mode 100644 lisp/citeproc/citeproc-s.el create mode 100644 lisp/citeproc/citeproc-sort.el create mode 100644 lisp/citeproc/citeproc-style.el create mode 100644 lisp/citeproc/citeproc-subbibs.el create mode 100644 lisp/citeproc/citeproc-term.el create mode 100644 lisp/citeproc/citeproc-test-human.el create mode 100644 lisp/citeproc/citeproc.el create mode 100644 lisp/queue.el create mode 100644 lisp/string-inflection.el diff --git a/lisp/citeproc/citeproc-biblatex.el b/lisp/citeproc/citeproc-biblatex.el new file mode 100644 index 00000000..f6042b46 --- /dev/null +++ b/lisp/citeproc/citeproc-biblatex.el @@ -0,0 +1,521 @@ +;;; citeproc-biblatex.el --- convert biblatex entries to CSL -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 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: + +;; Convert biblatex bibliography entries to CSL. + +;;; Code: + +(require 'parse-time) +(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 csltype 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-number . chapter) + (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--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 (lambda (x) + (let* ((parsed (parse-time-string x)) + ;; TODO: use more elegant accessors for the parsed + ;; time while keeping Emacs 26 compatibility. + (year (elt parsed 5)) + (month (elt parsed 4)) + (day (elt parsed 3)) + date) + (when year + (when day (push day date)) + (when month (push month date)) + (push year date) + 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. Return nil if +V is undefined in B." + (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 + +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)) + ;; names + (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)) + ;; TODO: do this for editorb and editorc as well... 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 (citeproc-s-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 diff --git a/lisp/citeproc/citeproc-bibtex.el b/lisp/citeproc/citeproc-bibtex.el new file mode 100644 index 00000000..921c0b31 --- /dev/null +++ b/lisp/citeproc/citeproc-bibtex.el @@ -0,0 +1,481 @@ +;;; citeproc-bibtex.el --- convert BibTeX entries to CSL -*- lexical-binding: t; -*- + +;; Copyright (C) 2017-2021 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: + +;; Convert BibTeX bibliography entries to CSL. + +;;; Code: + +(require 'dash) +(require 'subr-x) +(require 'bibtex) +(require 'cl-lib) +(require 's) +(require 'org) +(require 'map) +;; 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 (*? anything)) "}")) ; {TEXT} + +(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 lhb "\\1" rhb) + t nil result) + match t)) + (t (setq match nil)))) + 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))) + (citeproc-s-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 "") + (when with-nocase "")) + (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))) + `((family . ,(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." + (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))))) + +(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 , Carsten Dominik and Eric Schulte . +;; 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 diff --git a/lisp/citeproc/citeproc-choose.el b/lisp/citeproc/citeproc-choose.el new file mode 100644 index 00000000..ee390d51 --- /dev/null +++ b/lisp/citeproc/citeproc-choose.el @@ -0,0 +1,118 @@ +;; citeproc-choose.el --- conditionally rendered CSL elements -*- lexical-binding: t; -*- + +;; Copyright (C) 2017 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: + +;; 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 diff --git a/lisp/citeproc/citeproc-cite.el b/lisp/citeproc/citeproc-cite.el new file mode 100644 index 00000000..7a220326 --- /dev/null +++ b/lisp/citeproc/citeproc-cite.el @@ -0,0 +1,536 @@ +;;; citeproc-cite.el --- cite and citation rendering -*- lexical-binding: t; -*- + +;; Copyright (C) 2017-2021 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) + +(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', +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))) + "Alist mapping citation modes to corresponding cite-level +key-value pair representations.") + +(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)) + 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) + 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)) + (rendered-varlist + (citeproc-render-varlist-in-rt (citeproc-cite--varlist cite) + style 'cite 'display internal-links))) + (when (s-present-p plain-suff) + (push (citeproc-rt-from-str suff) result) + (unless (= (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 (eq (citeproc-citation-mode c) 'textual) + (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)) + first-cite)) + (rendered-author (citeproc-cite--render author-cite style 'no-links))) + (when (and (listp rendered-author) + (alist-get 'stopped-rendering (car rendered-author))) + (setq result `(nil ,rendered-author " " ,result))))) + ;; Capitalize first + (if (citeproc-citation-capitalize-first c) + (citeproc-rt-change-case result #'citeproc-s-capitalize-first) + 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)) + (push mode-rep (car cites))) + (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-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 diff --git a/lisp/citeproc/citeproc-context.el b/lisp/citeproc/citeproc-context.el new file mode 100644 index 00000000..70059eb0 --- /dev/null +++ b/lisp/citeproc/citeproc-context.el @@ -0,0 +1,270 @@ +;;; citeproc-context.el --- rendering context for CSL elements -*- lexical-binding: t; -*- + +;; Copyright (C) 2017-2021 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: + +;; 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." + (if (eq form 'short) + (-if-let* ((short-var (alist-get var citeproc--short-long-var-alist)) + (short-var-val (alist-get short-var (citeproc-context-vars context)))) + short-var-val + (alist-get var (citeproc-context-vars context))) + (let ((var-val (alist-get var (citeproc-context-vars context)))) + (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-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))) + +(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)))) + (cond ((not matches) nil) + ((= (length matches) 1) + (citeproc-term-text (car matches))) + (t (citeproc-term--inflected-text-1 matches form number))))) + +(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-1 (matches form number) + (let ((match (--first (and (eq form (citeproc-term-form it)) + (or (not (citeproc-term-number it)) + (eq number (citeproc-term-number it)))) + matches))) + (if match + (citeproc-term-text match) + (citeproc-term--inflected-text-1 + matches + (alist-get form citeproc--term-form-fallback-alist) + number)))) + +(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-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 + (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)))) + (let* ((itemid-attr + (if (and note-style (not (eq internal-links 'bib-links))) + ;; For note styles link subsequent cites to the first ones + (if (eq (alist-get 'position var-alist) '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))) + (itemid-attr-val (cons itemid-attr + (alist-get 'citation-number var-alist)))) + (cond ((consp rendered) (setf (car rendered) + (-snoc (car rendered) itemid-attr-val))) + ((stringp rendered) (setq rendered + (list (list itemid-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 diff --git a/lisp/citeproc/citeproc-date.el b/lisp/citeproc/citeproc-date.el new file mode 100644 index 00000000..abf166f8 --- /dev/null +++ b/lisp/citeproc/citeproc-date.el @@ -0,0 +1,280 @@ +;;; citeproc-date.el --- CSL date rendering -*- lexical-binding: t; -*- + +;; Copyright (C) 2017 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: + +;; 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) + +(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-lib-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 "" 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 diff --git a/lisp/citeproc/citeproc-disamb.el b/lisp/citeproc/citeproc-disamb.el new file mode 100644 index 00000000..0f585105 --- /dev/null +++ b/lisp/citeproc/citeproc-disamb.el @@ -0,0 +1,247 @@ +;;; citeproc-disamb.el --- disambiguate ambiguous cites -*- lexical-binding: t; -*- + +;; Copyright (C) 2017 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: + +;; 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 diff --git a/lisp/citeproc/citeproc-formatters.el b/lisp/citeproc/citeproc-formatters.el new file mode 100644 index 00000000..7a808d2b --- /dev/null +++ b/lisp/citeproc/citeproc-formatters.el @@ -0,0 +1,331 @@ +;; citeproc-formatters.el --- output formatters -*- lexical-binding: t; -*- + +;; Copyright (C) 2017-2021 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: + +;; 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 'subr-x) +(require 's) +(require 'cl-lib) + + (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 "<>" x))) + (font-style-italic . ,(lambda (x) (concat "/" x "/"))) + (font-style-oblique . ,(lambda (x) (concat "/" x "/"))) + (font-variant-small-caps . ,(lambda (x) (upcase x))) + (font-weight-bold . ,(lambda (x) (concat "*" x "*"))) + (text-decoration-underline . ,(lambda (x) (concat "_" x "_"))) + (vertical-align-sub . ,(lambda (x) (concat "_{" x "}"))) + (vertical-align-sup . ,(lambda (x) (concat "^{" x "}"))) + (display-left-margin . ,(lambda (x) (concat x " "))))) + +;; 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 "" x ""))) + (cited-item-no . ,(lambda (x y) (concat "" + x ""))) + (bib-item-no . ,(lambda (x y) (concat "" + x))) + (font-style-italic . ,(lambda (x) (concat "" x ""))) + (font-style-oblique . ,(lambda (x) + (concat ""))) + (font-variant-small-caps . ,(lambda (x) + (concat + "" x ""))) + (font-weight-bold . ,(lambda (x) (concat "" x ""))) + (text-decoration-underline . + ,(lambda (x) + (concat + "" x ""))) + (vertical-align-sub . ,(lambda (x) (concat "" x ""))) + (vertical-align-sup . ,(lambda (x) (concat "" x ""))) + (vertical-align-baseline . ,(lambda (x) (concat "" x ""))) + (display-left-margin . ,(lambda (x) (concat "\n
" + x "
"))) + (display-right-inline . ,(lambda (x) (concat "
" + x "
\n "))) + (display-block . ,(lambda (x) (concat "\n\n
" + x "
\n"))) + (display-indent . ,(lambda (x) (concat "
" x "
\n "))))) + +(defconst citeproc-fmt--csl-test-alist + `((unformatted . citeproc-fmt--xml-escape) + (cited-item-no . ,(lambda (x y) (concat "" + x ""))) + (bib-item-no . ,(lambda (x y) (concat "" + x))) + (font-style-italic . ,(lambda (x) (concat "" x ""))) + (font-style-oblique . ,(lambda (x) + (concat ""))) + (font-variant-small-caps . ,(lambda (x) + (concat + "" x ""))) + (font-weight-bold . ,(lambda (x) (concat "" x ""))) + (text-decoration-underline . + ,(lambda (x) + (concat + "" x ""))) + (vertical-align-sub . ,(lambda (x) (concat "" x ""))) + (vertical-align-sup . ,(lambda (x) (concat "" x ""))) + (vertical-align-baseline . ,(lambda (x) (concat "" x ""))) + (display-left-margin . ,(lambda (x) (concat "\n
" + x "
"))) + (display-right-inline . ,(lambda (x) (concat "
" + x "
\n "))) + (display-block . ,(lambda (x) (concat "\n\n
" + x "
\n"))) + (display-indent . ,(lambda (x) (concat "
" x "
\n "))))) + +(defun citeproc-fmt--html-bib-formatter (items _bib-format) + "Return a html bibliography from already formatted ITEMS." + (concat "
\n" + (mapconcat (lambda (i) + (concat "
" i "
\n")) + items + "") + "
")) + +;; 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)) + +(defun citeproc-fmt--latex-href (text uri) + (let ((escaped-uri (replace-regexp-in-string "%" "\\\\%" 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-ODT + +(defconst citeproc-fmt--org-odt-alist + `((unformatted . citeproc-fmt--xml-escape) + (href . ,(lambda (x y) (concat "" x ""))) + (cited-item-no + . ,(lambda (x y) (concat "" x ""))) + (bib-item-no + . ,(lambda (x y) + (concat "" + "" + "" x))) + (font-style-italic + . ,(lambda (x) (concat "" x ""))) + (font-style-oblique + . ,(lambda (x) (concat "" x ""))) + ;; 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 "" x ""))) + (font-weight-bold + . ,(lambda (x) (concat "" x ""))) + (text-decoration-underline + . ,(lambda (x) (concat "" x ""))) + (vertical-align-sub + . ,(lambda (x) (concat "" x ""))) + (vertical-align-sup + . ,(lambda (x) + (concat "" x ""))) + ;; 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 "" i "")) + 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-formatter-fun-create citeproc-fmt--org-alist))) + (latex . ,(citeproc-formatter-create + :rt (citeproc-formatter-fun-create citeproc-fmt--latex-alist))) + (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 diff --git a/lisp/citeproc/citeproc-generic-elements.el b/lisp/citeproc/citeproc-generic-elements.el new file mode 100644 index 00000000..ffcecbf1 --- /dev/null +++ b/lisp/citeproc/citeproc-generic-elements.el @@ -0,0 +1,148 @@ +;;; citeproc-generic-elements.el --- render generic CSL elements -*- lexical-binding: t; -*- + +;; Copyright (C) 2017-2021 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: + +;; 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))))) + (cons (citeproc-rt-format-single attrs content context) type)))) + +(provide 'citeproc-generic-elements) + +;;; citeproc-generic-elements.el ends here diff --git a/lisp/citeproc/citeproc-itemdata.el b/lisp/citeproc/citeproc-itemdata.el new file mode 100644 index 00000000..9c582f4b --- /dev/null +++ b/lisp/citeproc/citeproc-itemdata.el @@ -0,0 +1,101 @@ +;;; citeproc-itemdata.el --- represent and access bibliography items -*- lexical-binding: t; -*- + +;; Copyright (C) 2017 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: + +;; 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." + varvals rawcite rawbibitem rc-uptodate sort-key occurred-before + disamb-pos subbib-nos) + +(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 diff --git a/lisp/citeproc/citeproc-itemgetters.el b/lisp/citeproc/citeproc-itemgetters.el new file mode 100644 index 00000000..8784b2eb --- /dev/null +++ b/lisp/citeproc/citeproc-itemgetters.el @@ -0,0 +1,178 @@ +;; citeproc-itemgetters.el --- functions for constructing itemgetters -*- lexical-binding: t; -*- + +;; Copyright (C) 2017-2021 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: + +;; 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)) + (puthash (car key-w-entry) (citeproc-bt-entry-to-csl + (cdr key-w-entry)) + cache))) + t (list file))) + (ext + (user-error "Unknown bibliography extension: %S" ext)))) + (maphash + (lambda (key entry) + (puthash key (citeproc-blt-entry-to-csl entry nil no-sentcase-wo-langid) + cache)) + 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 diff --git a/lisp/citeproc/citeproc-lib.el b/lisp/citeproc/citeproc-lib.el new file mode 100644 index 00000000..1d626c21 --- /dev/null +++ b/lisp/citeproc/citeproc-lib.el @@ -0,0 +1,164 @@ +;;; citeproc-lib.el --- misc functions and variables for citeproc-el -*- lexical-binding: t; -*- + +;; Copyright (C) 2017-2021 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: + +;; 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) + "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)))) + +(defun citeproc-lib-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)) + +(provide 'citeproc-lib) + +;;; citeproc-lib.el ends here diff --git a/lisp/citeproc/citeproc-locale.el b/lisp/citeproc/citeproc-locale.el new file mode 100644 index 00000000..81bbc65f --- /dev/null +++ b/lisp/citeproc/citeproc-locale.el @@ -0,0 +1,93 @@ +;; citeproc-locale.el --- CSL locale related functions -*- lexical-binding: t; -*- + +;; Copyright (C) 2017 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: + +;; 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 those 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." + (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) + 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 diff --git a/lisp/citeproc/citeproc-macro.el b/lisp/citeproc/citeproc-macro.el new file mode 100644 index 00000000..d4b6ddcd --- /dev/null +++ b/lisp/citeproc/citeproc-macro.el @@ -0,0 +1,58 @@ +;; citeproc-macro.el --- functions to render CSL macros -*- lexical-binding: t; -*- + +;; Copyright (C) 2017 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: + +;; 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 diff --git a/lisp/citeproc/citeproc-name.el b/lisp/citeproc/citeproc-name.el new file mode 100644 index 00000000..2bfd0cc6 --- /dev/null +++ b/lisp/citeproc/citeproc-name.el @@ -0,0 +1,438 @@ +;;; citeproc-name.el --- CSL name and label rendering -*- lexical-binding: t; -*- + +;; Copyright (C) 2017 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: + +;; 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) + +;; 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 ((form (alist-get 'form label-attrs)) + (rendered-label (car (citeproc--label label-attrs context)))) + (citeproc-rt-join-formatted `((rendered-var . ,var)) + (if (or label-before-names + (string= form "verb") + (string= form "verb-short")) + (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))) + (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))) + +(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 ((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))) + +;;NOTE: missing given names are currently dealt here by handling the names = +;;nil case there should be a more appropriate place. +(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." + (if (not names) nil + (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-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)))) + (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 diff --git a/lisp/citeproc/citeproc-number.el b/lisp/citeproc/citeproc-number.el new file mode 100644 index 00000000..bf9897bf --- /dev/null +++ b/lisp/citeproc/citeproc-number.el @@ -0,0 +1,160 @@ +;;; citeproc-number.el --- render CSL number elements -*- lexical-binding: t; -*- + +;; Copyright "(C) 2017 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: + +;; 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 diff --git a/lisp/citeproc/citeproc-pkg.el b/lisp/citeproc/citeproc-pkg.el new file mode 100644 index 00000000..b8871b9d --- /dev/null +++ b/lisp/citeproc/citeproc-pkg.el @@ -0,0 +1,19 @@ +(define-package "citeproc" "20220101.1527" "A CSL 1.0.2 Citation Processor" + '((emacs "25") + (dash "2.13.0") + (s "1.12.0") + (f "0.18.0") + (queue "0.2") + (string-inflection "1.0") + (org "9") + (parsebib "2.4")) + :commit "abf3e45946598dffebfba6d6bd9a8cda46815765" :authors + '(("András Simonyi" . "andras.simonyi@gmail.com")) + :maintainer + '("András Simonyi" . "andras.simonyi@gmail.com") + :keywords + '("bib") + :url "https://github.com/andras-simonyi/citeproc-el") +;; Local Variables: +;; no-byte-compile: t +;; End: diff --git a/lisp/citeproc/citeproc-prange.el b/lisp/citeproc/citeproc-prange.el new file mode 100644 index 00000000..52a5fb39 --- /dev/null +++ b/lisp/citeproc/citeproc-prange.el @@ -0,0 +1,128 @@ +;;; citeproc-prange.el --- page-range rendering -*- lexical-binding: t; -*- + +;; Copyright (C) 2017 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: + +;; Functions to render CSL page-ranges. + +;;; Code: + +(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 diff --git a/lisp/citeproc/citeproc-proc.el b/lisp/citeproc/citeproc-proc.el new file mode 100644 index 00000000..55774658 --- /dev/null +++ b/lisp/citeproc/citeproc-proc.el @@ -0,0 +1,224 @@ +;;; citeproc-proc.el --- construct and manage citation processors -*- lexical-binding: t; -*- + +;; Copyright (C) 2017 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: + +;; 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) + "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 :rc-uptodate nil))) + (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)))))) + +(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-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 + (let* ((filtered (-remove (lambda (x) (eq (car x) 'isInstitution)) it)) + (w-smart-aposts (--map (cons + (car it) + (let ((text-field (cdr it))) + (if (stringp text-field) + (citeproc-s-smart-apostrophes text-field) + text-field))) + filtered))) + (citeproc-proc--internalize-name w-smart-aposts 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))))) + +(provide 'citeproc-proc) + +;;; citeproc-proc.el ends here diff --git a/lisp/citeproc/citeproc-rt.el b/lisp/citeproc/citeproc-rt.el new file mode 100644 index 00000000..bff7da1a --- /dev/null +++ b/lisp/citeproc/citeproc-rt.el @@ -0,0 +1,569 @@ +;; citeproc-rt.el --- citeproc-el rich-text functions -*- lexical-binding: t; -*- + +;; Copyright (C) 2017-2021 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: + +;; 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 '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) + "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 sequentially 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) (citeproc-s-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 "" s)) + (let* ((parsed (citeproc-lib-parse-html-frag s)) + (body (cddr (cl-caddr parsed))) + (stripped (if (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))) + "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 "") + (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 "+" "" 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 ( ) 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-max-offset (itemdata) + "Return the maximal first field width in rich-texts RTS." + (cl-loop for itd being the hash-values of itemdata + when (listp (citeproc-itemdata-rawbibitem itd)) maximize + (length (citeproc-rt-to-plain (cadr (citeproc-itemdata-rawbibitem itd)))))) + +(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))) + +(provide 'citeproc-rt) + +;;; citeproc-rt.el ends here diff --git a/lisp/citeproc/citeproc-s.el b/lisp/citeproc/citeproc-s.el new file mode 100644 index 00000000..c462cd9e --- /dev/null +++ b/lisp/citeproc/citeproc-s.el @@ -0,0 +1,274 @@ +;;; citeproc-s.el --- citeproc-el string functions -*- lexical-binding: t; -*- + +;; Copyright (C) 2017 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: + +;; String utility functions for citeproc-el. + +;;; Code: + +(require 'thingatpt) +(require 's) + +;; Handle the unavailability of `string-replace' in early Emacs versions +(if (fboundp 'string-replace) + (defalias 'citeproc-s-replace #'string-replace) + (defalias 'citeproc-s-replace #'s-replace)) + +(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 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 "\\(\\|\\|: +\\w\\)")) + (protect-level 0) + (first t) + result) + (dolist (slice sliced) + (push + (pcase slice + ("" (cl-incf protect-level) (if omit-nocase nil slice)) + ("" (cl-decf protect-level) (if omit-nocase nil slice)) + ;; Don't touch the first letter after a colon since it is probably a subtitle. + ((pred (string-match-p "^:")) slice) + (_ (cond ((< 0 protect-level) (setq first nil) slice) + ((not first) (downcase slice)) + (t (setq first nil) + (concat (upcase (substring slice 0 1)) + (downcase (substring slice 1))))))) + 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 (citeproc-s-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.'" + (subst-char-in-string ?' ?ʼ (subst-char-in-string ?’ ?ʼ s t) t)) + +(defconst citeproc-s--cull-spaces-alist + '((" " . " ") (";;" . ";") ("..." . ".") (",," . ",") (".." . ".")) + "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") + ("\\([:.;!?]\\)\\." . "\\1") + ("\\([:;!]\\)!" . "!") + ("\\([:;?]\\)\\?" . "?") + ("\\.\\([”’‹›«»]\\)\\." . ".\\1") + (",\\([”’‹›«»]\\)," . ",\\1")) + result) + (setq result (replace-regexp-in-string (car match-rep) + (cdr match-rep) + result))))) + +(provide 'citeproc-s) + +;;; citeproc-s.el ends here diff --git a/lisp/citeproc/citeproc-sort.el b/lisp/citeproc/citeproc-sort.el new file mode 100644 index 00000000..f2b47219 --- /dev/null +++ b/lisp/citeproc/citeproc-sort.el @@ -0,0 +1,191 @@ +;;; citeproc-sort.el --- cite and bibliography sorting -*- lexical-binding: t; -*- + +;; Copyright (C) 2017 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: + +;; 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) + +(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 ((sorted-bib-p (citeproc-style-bib-sort (citeproc-proc-style proc))) + (filters (citeproc-proc-bib-filters proc))) + (when (or sorted-bib-p filters) + (let* ((itds (hash-table-values (citeproc-proc-itemdata proc))) + (sorted (if sorted-bib-p + (let ((sort-orders (citeproc-style-bib-sort-orders + (citeproc-proc-style proc)))) + (citeproc-sort-itds itds sort-orders)) + (citeproc-sort-itds-on-citnum itds)))) + ;; Additionally sort according to subbibliographies if there are filters. + (when filters + (setq sorted (sort sorted #'citeproc-sort-itds-on-subbib))) + ;; Set the CSL citation-number field according to the sort order. + (--each-indexed sorted + (citeproc-itd-setvar it 'citation-number + (number-to-string (1+ it-index)))))))) + +(provide 'citeproc-sort) + +;;; citeproc-sort.el ends here diff --git a/lisp/citeproc/citeproc-style.el b/lisp/citeproc/citeproc-style.el new file mode 100644 index 00000000..21283a5c --- /dev/null +++ b/lisp/citeproc/citeproc-style.el @@ -0,0 +1,344 @@ +;; citeproc-style.el --- CSL style structure and related functions -*- lexical-binding: t; -*- + +;; Copyright (C) 2017 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: + +;; 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. +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, +CITE-NOTE is non-nil iff the style's citation-format is \"note\", +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." + info opts bib-opts bib-sort bib-sort-orders + bib-layout cite-opts cite-note 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))) + (setf (citeproc-style-info style) info-lst + (citeproc-style-cite-note style) + (not (not (member '(category + ((citation-format . "note"))) + info-lst)))))) + ('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-lib-maybe-stop-rendering 'names context final))))) + +(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 diff --git a/lisp/citeproc/citeproc-subbibs.el b/lisp/citeproc/citeproc-subbibs.el new file mode 100644 index 00000000..8a6d5db0 --- /dev/null +++ b/lisp/citeproc/citeproc-subbibs.el @@ -0,0 +1,65 @@ +;;; citeproc-subbibs.el --- support for subbibliographies -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 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: + +;; Support for generating subbibliographies based on filtering items. + +;;; Code: + +(require 'dash) + +(require 'citeproc-proc) +(require 'citeproc-itemdata) + +(defun citeproc-sb-match-p (vv filter &optional use-blt-type) + "Return whether var-vals alist VV matches FILTER. +If optional USE-BLT-TYPE is non-nil then use the value for key +`blt-type' to evaluate type-based filter parts." + (let* ((type (alist-get (if use-blt-type 'blt-type 'type) vv)) + (keyword (alist-get 'keyword vv)) + (keywords (and keyword (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))) + (`(,key . ,_) (error "Unsupported Citeproc filter keyword `%s'" key))) + filter))) + +(defun citeproc-sb-add-subbib-info (proc) + "Add subbibliography information to the items in 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)))) + +(provide 'citeproc-subbibs) + +;;; citeproc-subbibs.el ends here diff --git a/lisp/citeproc/citeproc-term.el b/lisp/citeproc/citeproc-term.el new file mode 100644 index 00000000..ce9bbaf0 --- /dev/null +++ b/lisp/citeproc/citeproc-term.el @@ -0,0 +1,113 @@ +;;; citeproc-term.el --- functions for term localization -*- lexical-binding: t; -*- + +;; Copyright (C) 2017 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: + +;; 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 diff --git a/lisp/citeproc/citeproc-test-human.el b/lisp/citeproc/citeproc-test-human.el new file mode 100644 index 00000000..202e5e1f --- /dev/null +++ b/lisp/citeproc/citeproc-test-human.el @@ -0,0 +1,207 @@ +;; citeproc-test-human.el --- support tests in CSL suite format -*- lexical-binding: t; -*- + +;; Copyright (C) 2017-2021 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: + +;; Functions to create ERT tests from tests in CSL test suite format. The +;; official tests can be found at +;; . + +;;; 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 diff --git a/lisp/citeproc/citeproc.el b/lisp/citeproc/citeproc.el new file mode 100644 index 00000000..e1463631 --- /dev/null +++ b/lisp/citeproc/citeproc.el @@ -0,0 +1,290 @@ +;;; citeproc.el --- A CSL 1.0.2 Citation Processor -*- lexical-binding: t; -*- + +;; Copyright (C) 2017-2021 András Simonyi + +;; Author: András Simonyi +;; Maintainer: András Simonyi +;; URL: https://github.com/andras-simonyi/citeproc-el +;; Keywords: bib +;; Package-Requires: ((emacs "25") (dash "2.13.0") (s "1.12.0") (f "0.18.0") (queue "0.2") (string-inflection "1.0") (org "9") (parsebib "2.4")) +;; Version: 0.9 + +;; 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: + +;; 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) + ;; 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)) 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 subbib FILTERS to PROC. +FILTERS should be a list of alists in which the keys are one of +the symbols `type', `nottype', `keyword', `notkeyword', and +values are strings." + (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 filters + ;; There are filters, we need to select and sort the subbibs. + (let ((result (make-list (length filters) nil)) + (bib-sort (citeproc-style-bib-sort (citeproc-proc-style proc)))) + ;; Put the itds into subbib lists. + (maphash + (lambda (_ itd) + (dolist (subbib-no (citeproc-itemdata-subbib-nos itd)) + (push itd (elt result subbib-no)))) + itemdata) + ;; Sort the itds in each list according to the sort settings + (setq result + (--map (if bib-sort + (citeproc-sort-itds it (citeproc-style-bib-sort-orders + (citeproc-proc-style proc))) + (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 containg 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. + (max-offset (if (alist-get 'second-field-align bib-opts) + (citeproc-rt-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 diff --git a/lisp/my/my.el b/lisp/my/my.el index 4e4869eb..6e304de6 100644 --- a/lisp/my/my.el +++ b/lisp/my/my.el @@ -433,16 +433,6 @@ Usage: (if (> diff 0) "Need to pull" "Need to push")) diff)))) -(defun my-dashboard-config-update () - (if (featurep 'magit) - (let ((diff (my-magit-repo-status "~/.config/emacs" "master" t))) - (if (= diff 0) "Up-to-date" - (if (= diff 1) "1 update" - (if (= diff -1) "1 commit unpushed" - (if (> diff 0) (format "%s updates" diff) - (format "%s commits unpushed" (- diff))))))) - (require 'magit nil t) - "Check")) (provide 'my) ;;; my.el ends here diff --git a/lisp/queue.el b/lisp/queue.el new file mode 100644 index 00000000..5c9a88bd --- /dev/null +++ b/lisp/queue.el @@ -0,0 +1,192 @@ +;;; queue.el --- Queue data structure -*- lexical-binding: t; -*- + +;; Copyright (C) 1991-1995, 2008-2009, 2012, 2017 Free Software Foundation, Inc + +;; Author: Inge Wallin +;; Toby Cubitt +;; Maintainer: Toby Cubitt +;; Version: 0.2 +;; Keywords: extensions, data structures, queue +;; URL: http://www.dr-qubit.org/emacs.php +;; Repository: http://www.dr-qubit.org/git/predictive.git + +;; This file is part of Emacs. +;; +;; GNU Emacs 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. +;; +;; GNU Emacs 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 GNU Emacs. If not, see . + + +;;; Commentary: +;; +;; These queues can be used both as a first-in last-out (FILO) and as a +;; first-in first-out (FIFO) stack, i.e. elements can be added to the front or +;; back of the queue, and can be removed from the front. (This type of data +;; structure is sometimes called an "output-restricted deque".) +;; +;; You create a queue using `make-queue', add an element to the end of the +;; queue using `queue-enqueue', and push an element onto the front of the +;; queue using `queue-prepend'. To remove the first element from a queue, use +;; `queue-dequeue'. A number of other queue convenience functions are also +;; provided, all starting with the prefix `queue-'. Functions with prefix +;; `queue--' are for internal use only, and should never be used outside this +;; package. + + +;;; Code: + +(eval-when-compile (require 'cl)) + +(defmacro queue--when-generators (then) + "Evaluate THEN if `generator' library is available." + (declare (debug t)) + (if (require 'generator nil 'noerror) then)) + + +(defstruct (queue + ;; A tagged list is the pre-defstruct representation. + ;; (:type list) + :named + (:constructor nil) + (:constructor queue-create ()) + (:copier nil)) + head tail) + + +;;;###autoload +(defalias 'make-queue 'queue-create + "Create an empty queue data structure.") + + +(defun queue-enqueue (queue element) + "Append an ELEMENT to the end of the QUEUE." + (if (queue-head queue) + (setcdr (queue-tail queue) + (setf (queue-tail queue) (cons element nil))) + (setf (queue-head queue) + (setf (queue-tail queue) (cons element nil))))) + +(defalias 'queue-append 'queue-enqueue) + + +(defun queue-prepend (queue element) + "Prepend an ELEMENT to the front of the QUEUE." + (if (queue-head queue) + (push element (queue-head queue)) + (setf (queue-head queue) + (setf (queue-tail queue) (cons element nil))))) + + +(defun queue-dequeue (queue) + "Remove the first element of QUEUE and return it. +Returns nil if the queue is empty." + (unless (cdr (queue-head queue)) (setf (queue-tail queue) nil)) + (pop (queue-head queue))) + + +(defun queue-empty (queue) + "Return t if QUEUE is empty, otherwise return nil." + (null (queue-head queue))) + + +(defun queue-first (queue) + "Return the first element of QUEUE or nil if it is empty, +without removing it from the QUEUE." + (car (queue-head queue))) + + +(defun queue-nth (queue n) + "Return the nth element of a queue, without removing it. +If the length of the queue is less than N, return nil. The first +element in the queue has index 0." + (nth n (queue-head queue))) + + +(defun queue-last (queue) + "Return the last element of QUEUE, without removing it. +Returns nil if the QUEUE is empty." + (car (queue-tail queue))) + + +(defun queue-all (queue) + "Return a list of all elements of QUEUE or nil if it is empty. +The oldest element in the queue is the first in the list." + (queue-head queue)) + + +(defun queue-copy (queue) + "Return a copy of QUEUE. +The new queue contains the elements of QUEUE in the same +order. The elements themselves are *not* copied." + (let ((q (queue-create)) + (list (queue-head queue))) + (when (queue-head queue) + (setf (queue-head q) (cons (car (queue-head queue)) nil) + (queue-tail q) (queue-head q)) + (while (setq list (cdr list)) + (setf (queue-tail q) + (setcdr (queue-tail q) (cons (car list) nil))))) + q)) + + +(defun queue-length (queue) + "Return the number of elements in QUEUE." + (length (queue-head queue))) + + +(defun queue-clear (queue) + "Remove all elements from QUEUE." + (setf (queue-head queue) nil + (queue-tail queue) nil)) + + +(queue--when-generators + (iter-defun queue-iter (queue) + "Return a queue iterator object. + +Calling `iter-next' on this object will retrieve the next element +from the queue. The queue itself is not modified." + (let ((list (queue-head queue))) + (while list (iter-yield (pop list)))))) + +;;;; ChangeLog: + +;; 2017-08-16 Toby S. Cubitt +;; +;; Upgrade data structure packages to latest versions. +;; +;; 2014-05-15 Toby S. Cubitt +;; +;; queue.el: fix buggy queue-first and queue-empty definitions. +;; +;; 2012-04-30 Toby S. Cubitt +;; +;; Minor fixes to commentaries, package headers, and whitespace +;; +;; * queue.el: fix description of data structure in Commentary; add +;; Maintainer +;; header. +;; +;; * queue.el, heap.el, tNFA.el, trie.el, dict-tree.el: trivial whitespace +;; fixes. +;; +;; 2012-04-29 Toby S. Cubitt +;; +;; Add queue.el +;; + + + +(provide 'queue) + + +;;; queue.el ends here diff --git a/lisp/string-inflection.el b/lisp/string-inflection.el new file mode 100644 index 00000000..f41cf6c1 --- /dev/null +++ b/lisp/string-inflection.el @@ -0,0 +1,396 @@ +;;; string-inflection.el --- underscore -> UPCASE -> CamelCase -> lowerCamelCase conversion of names -*- lexical-binding: t -*- + +;; Copyright (C) 2004,2014,2016,2017,2018,2020,2021 Free Software Foundation, Inc. + +;; Author: akicho8 +;; Keywords: elisp +;; Package-Version: 20210918.419 +;; Package-Commit: fd7926ac17293e9124b31f706a4e8f38f6a9b855 +;; Version: 1.0.16 + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; This file 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 GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; There are three main functions: +;; +;; 1. For Ruby -> string-inflection-ruby-style-cycle (foo_bar => FOO_BAR => FooBar => foo_bar) +;; 2. For Python -> string-inflection-python-style-cycle (foo_bar => FOO_BAR => FooBar => foo_bar) +;; 3. For Java -> string-inflection-java-style-cycle (fooBar => FOO_BAR => FooBar => fooBar) +;; 4. For All -> string-inflection-all-cycle (foo_bar => FOO_BAR => FooBar => fooBar => foo-bar => Foo_Bar => foo_bar) +;; +;; +;; Example 1: +;; +;; (require 'string-inflection) +;; (global-unset-key (kbd "C-q")) +;; ;; C-q C-u is the key bindings similar to Vz Editor. +;; (global-set-key (kbd "C-q C-u") 'my-string-inflection-cycle-auto) +;; +;; (defun my-string-inflection-cycle-auto () +;; "switching by major-mode" +;; (interactive) +;; (cond +;; ;; for emacs-lisp-mode +;; ((eq major-mode 'emacs-lisp-mode) +;; (string-inflection-all-cycle)) +;; ;; for java +;; ((eq major-mode 'java-mode) +;; (string-inflection-java-style-cycle)) +;; ;; for python +;; ((eq major-mode 'python-mode) +;; (string-inflection-python-style-cycle)) +;; (t +;; ;; default +;; (string-inflection-ruby-style-cycle)))) +;; +;; +;; Example 2: +;; +;; (require 'string-inflection) +;; +;; ;; default +;; (global-set-key (kbd "C-c C-u") 'string-inflection-all-cycle) +;; +;; ;; for ruby +;; (add-hook 'ruby-mode-hook +;; '(lambda () +;; (local-set-key (kbd "C-c C-u") 'string-inflection-ruby-style-cycle))) +;; +;; ;; for python +;; (add-hook 'python-mode-hook +;; '(lambda () +;; (local-set-key (kbd "C-c C-u") 'string-inflection-python-style-cycle))) +;; +;; ;; for java +;; (add-hook 'java-mode-hook +;; '(lambda () +;; (local-set-key (kbd "C-c C-u") 'string-inflection-java-style-cycle))) +;; +;; You can also set `string-inflection-skip-backward-when-done' to `t' if +;; you don't like `string-inflect' moving your point to the end of the word. + +;;; Code: + +(defgroup string-inflection nil + "Change the casing of words." + :group 'convenience) + +(defcustom string-inflection-skip-backward-when-done nil + "Controls the position of the cursor after an inflection. + +If nil remain at the end of the string after inflecting, else move backward to +the beginning." + :group 'string-inflection + :type 'boolean) + +(defconst string-inflection-word-chars "a-zA-Z0-9_-") + +(defcustom string-inflection-erase-chars-when-region "./" + "When selected in the region, this character is included in the transformation as part of the string. + +Exactly assume that the underscore exists. +For example, when you select `Foo/Bar', it is considered that `Foo_Bar' is selected. +If include `:', select `FOO::VERSION' to run `M-x\ string-inflection-underscore' to `foo_version'." + :group 'string-inflection + :type 'string) + +;; -------------------------------------------------------------------------------- + +;;;###autoload +(defun string-inflection-ruby-style-cycle () + "foo_bar => FOO_BAR => FooBar => foo_bar" + (interactive) + (string-inflection-insert + (string-inflection-ruby-style-cycle-function (string-inflection-get-current-word)))) + +(fset 'string-inflection-cycle 'string-inflection-ruby-style-cycle) + +;;;###autoload +(defun string-inflection-python-style-cycle () + "foo_bar => FOO_BAR => FooBar => foo_bar" + (interactive) + (string-inflection-insert + (string-inflection-python-style-cycle-function (string-inflection-get-current-word)))) + +;;;###autoload +(defun string-inflection-java-style-cycle () + "fooBar => FOO_BAR => FooBar => fooBar" + (interactive) + (string-inflection-insert + (string-inflection-java-style-cycle-function (string-inflection-get-current-word)))) + +;;;###autoload +(defun string-inflection-all-cycle () + "foo_bar => FOO_BAR => FooBar => fooBar => foo-bar => Foo_Bar => foo_bar" + (interactive) + (string-inflection-insert + (string-inflection-all-cycle-function (string-inflection-get-current-word)))) + +;;;###autoload +(defun string-inflection-toggle () + "toggle foo_bar <=> FooBar" + (interactive) + (string-inflection-insert + (string-inflection-toggle-function (string-inflection-get-current-word)))) + +;;;###autoload +(defun string-inflection-camelcase () + "FooBar format" + (interactive) + (string-inflection-insert + (string-inflection-pascal-case-function (string-inflection-get-current-word)))) + +;;;###autoload +(defun string-inflection-lower-camelcase () + "fooBar format" + (interactive) + (string-inflection-insert + (string-inflection-camelcase-function (string-inflection-get-current-word)))) + +;;;###autoload +(defun string-inflection-underscore () + "foo_bar format" + (interactive) + (string-inflection-insert + (string-inflection-underscore-function (string-inflection-get-current-word)))) + +;;;###autoload +(defun string-inflection-capital-underscore () + "Foo_Bar format" + (interactive) + (string-inflection-insert + (string-inflection-capital-underscore-function (string-inflection-get-current-word)))) + +;;;###autoload +(defun string-inflection-upcase () + "FOO_BAR format" + (interactive) + (string-inflection-insert + (string-inflection-upcase-function (string-inflection-get-current-word)))) + +;;;###autoload +(defun string-inflection-kebab-case () + "foo-bar format" + (interactive) + (string-inflection-insert + (string-inflection-kebab-case-function (string-inflection-get-current-word)))) + +(fset 'string-inflection-lisp 'string-inflection-kebab-case) + +;; -------------------------------------------------------------------------------- + +(defun string-inflection-insert (s) + (insert s) + (when string-inflection-skip-backward-when-done (skip-chars-backward string-inflection-word-chars))) + +(defun string-inflection-non-word-chars () + (concat "^" string-inflection-word-chars)) + +(defun string-inflection-get-current-word () + "Gets the symbol near the cursor" + (interactive) + (let* ((start (if (use-region-p) + (region-end) + (progn + (skip-chars-forward string-inflection-word-chars) + + ;; https://github.com/akicho8/string-inflection/issues/30 + ;; + ;; objectName->method --> "objectName-" NG + ;; --> "objectName" OK + (when (and (not (eobp)) (not (bobp))) + (when (string= (buffer-substring (1- (point)) (1+ (point))) "->") + (forward-char -1))) + + (point)))) + (end (if (use-region-p) + (region-beginning) + (progn + (skip-chars-backward string-inflection-word-chars) + (point)))) + (str (buffer-substring start end))) + (prog1 + (progn + (when (use-region-p) + ;; https://github.com/akicho8/string-inflection/issues/31 + ;; Multiple lines will be one line because [:space:] are included to line breaks + (setq str (replace-regexp-in-string (concat "[" string-inflection-erase-chars-when-region "]+") "_" str)) ; 'aa::bb.cc dd/ee' => 'aa_bb_cc dd_ee' + + ;; kebabing a region can insert an unexpected hyphen + ;; https://github.com/akicho8/string-inflection/issues/34 + (with-syntax-table (copy-syntax-table) + (modify-syntax-entry ?_ "w") + (setq str (replace-regexp-in-string "_+\\b" "" str)) ; '__aA__ __aA__' => '__aA __aA' + (setq str (replace-regexp-in-string "\\b_+" "" str)) ; '__aA __aA' => 'aA aA' + ) + ) + str) + (delete-region start end)))) + +;; -------------------------------------------------------------------------------- + +(defun string-inflection-pascal-case-function (str) + "foo_bar => FooBar" + (setq str (string-inflection-underscore-function str)) + (mapconcat 'capitalize (split-string str "_") "")) + +(fset 'string-inflection-upper-camelcase-function 'string-inflection-pascal-case-function) + +(defun string-inflection-camelcase-function (str) + "foo_bar => fooBar" + (setq str (split-string (string-inflection-underscore-function str) "_")) + (concat (downcase (car str)) + (mapconcat 'capitalize (cdr str) ""))) + +(fset 'string-inflection-lower-camelcase-function 'string-inflection-camelcase-function) + +(defun string-inflection-upcase-function (str) + "FooBar => FOO_BAR" + (upcase (string-inflection-underscore-function str))) + +(defun string-inflection-underscore-function (str) + "FooBar => foo_bar" + (let ((case-fold-search nil)) + (setq str (replace-regexp-in-string "\\([a-z0-9]\\)\\([A-Z]\\)" "\\1_\\2" str)) + (setq str (replace-regexp-in-string "\\([A-Z]+\\)\\([A-Z][a-z]\\)" "\\1_\\2" str)) + (setq str (replace-regexp-in-string "-" "_" str)) ; FOO-BAR => FOO_BAR + (setq str (replace-regexp-in-string "_+" "_" str)) + (downcase str))) + +(defun string-inflection-capital-underscore-function (str) + "foo_bar => Foo_Bar" + (setq str (string-inflection-underscore-function str)) + (mapconcat 'capitalize (split-string str "_") "_")) + +(defun string-inflection-kebab-case-function (str) + "foo_bar => foo-bar" + (let ((case-fold-search nil)) + (setq str (string-inflection-underscore-function str)) + (setq str (replace-regexp-in-string "_" "-" str)))) + +(defun string-inflection-all-cycle-function (str) + "foo_bar => FOO_BAR => FooBar => fooBar => foo-bar => Foo_Bar => foo_bar + foo => FOO => Foo => foo" + (cond + ;; foo => FOO + ((string-inflection-word-p str) + (string-inflection-upcase-function str)) + ;; foo_bar => FOO_BAR + ((string-inflection-underscore-p str) + (string-inflection-upcase-function str)) + ;; FOO_BAR => FooBar + ((string-inflection-upcase-p str) + (string-inflection-pascal-case-function str)) + ;; FooBar => fooBar + ;; Foo => foo + ((string-inflection-pascal-case-p str) + (string-inflection-camelcase-function str)) + ;; fooBar => foo-bar + ((string-inflection-camelcase-p str) + (string-inflection-kebab-case-function str)) + ;; foo-bar => Foo_Bar + ((string-inflection-kebab-case-p str) + (string-inflection-capital-underscore-function str)) + ;; foo-bar => foo_bar + (t + (string-inflection-underscore-function str)))) + +(defun string-inflection-ruby-style-cycle-function (str) + "foo_bar => FOO_BAR => FooBar => foo_bar" + (cond + ((string-inflection-underscore-p str) + (string-inflection-upcase-function str)) + ((string-inflection-upcase-p str) + (string-inflection-pascal-case-function str)) + (t + (string-inflection-underscore-function str)))) + +(defalias 'string-inflection-python-style-cycle-function + 'string-inflection-ruby-style-cycle-function) + +(defun string-inflection-java-style-cycle-function (str) + "fooBar => FOO_BAR => FooBar => fooBar" + (cond + ((string-inflection-underscore-p str) + (string-inflection-upcase-function str)) + ((string-inflection-camelcase-p str) + (string-inflection-upcase-function str)) + ((string-inflection-upcase-p str) + (string-inflection-pascal-case-function str)) + (t + (string-inflection-camelcase-function str)))) + +;; Toggle function. But cycle function. +(defun string-inflection-toggle-function (str) + "Not so much the case that in all caps when using normal foo_bar <--> FooBar" + (cond + ((string-inflection-underscore-p str) + (string-inflection-pascal-case-function str)) + ((string-inflection-pascal-case-p str) + (string-inflection-camelcase-function str)) + (t + (string-inflection-underscore-function str)))) + +;; -------------------------------------------------------------------------------- + +(defun string-inflection-word-p (str) + "if foo => t" + (let ((case-fold-search nil)) + (string-match "\\`[a-z0-9]+\\'" str))) + +(defun string-inflection-underscore-p (str) + "if foo_bar => t" + (let ((case-fold-search nil)) + (string-match "\\`[a-z0-9_]+\\'" str))) + +(defun string-inflection-upcase-p (str) + "if FOO_BAR => t" + (let ((case-fold-search nil)) + (string-match "\\`[A-Z0-9_]+\\'" str))) + +(defun string-inflection-pascal-case-p (str) + "if FooBar => t" + (let ((case-fold-search nil)) + (and + (string-match "[a-z]" str) + (string-match "\\`[A-Z][a-zA-Z0-9]+\\'" str)))) + +(fset 'string-inflection-upper-camelcase-p 'string-inflection-pascal-case-p) + +(defun string-inflection-camelcase-p (str) + "if fooBar => t" + (let ((case-fold-search nil)) + (and + (string-match "[A-Z]" str) + (string-match "\\`[a-z][a-zA-Z0-9]+\\'" str)))) + +(fset 'string-inflection-lower-camelcase-p 'string-inflection-camelcase-p) + +(defun string-inflection-kebab-case-p (str) + "if foo-bar => t" + (string-match "-" str)) + +(defun string-inflection-capital-underscore-p (str) + "if Foo_Bar => t" + (let ((case-fold-search nil)) + (and + (string-match "[A-Z]" str) + (string-match "_" str) + (string-match "\\`[A-Z][a-zA-Z0-9_]+\\'" str)))) + +(provide 'string-inflection) +;;; string-inflection.el ends here diff --git a/lisp/versions b/lisp/versions index 38bd64fe..021cc46f 100644 --- a/lisp/versions +++ b/lisp/versions @@ -7,13 +7,14 @@ | amx.el | [[https://melpa.org/#/amx][melpa]] | 3.4 | 20210305.118 | 3.3 | 20210101.1921 | requires ivy or ido, imporves M-x saving history, etc. | | anaconda-mode | [[https://melpa.org/#/anaconda-mode][melpa]] | 0.1.15 | 20211122.817 | 0.1.13 | 20200912.239 | | | async | [[https://melpa.org/#/async][melpa]] | 1.9.5 | 20210823.528 | 1.9.4 | 20200809.501 | required by ob-async | -| avy.el | [[https://melpa.org/#/avy][melpa]] | 0.5.0 | 20220102.805 | 0.5.0 | 20201226.1734 | | +| avy.el | [[https://melpa.org/#/avy][melpa]] | 0.5.0 | 20220102.805 | 0.5.0 | 20201226.1734 | required by org-ref | | awesome-tray.el | [[https://github.com/manateelazycat/awesome-tray][GitHub]] | 4.2 | 20211129.311 | 4.2 | 20200618.2102 | modeline in echo area | -| biblio | [[https://melpa.org/#/biblio][melpa]] | 0.2 | 20210418.406 | 0.2 | 20200416.1407 | | -| biblio-core.el | [[https://melpa.org/#/biblio-core][melpa]] | 0.2.1 | 20210418.406 | 0.2.1 | 20200416.307 | | -| bibtex-completion.el | [[https://melpa.org/#/bibtex-completion][melpa]] | 1.0.0 | 20211019.1306 | 1.0.0 | 20200908.1017 | required by ivy-bibtex | +| biblio | [[https://melpa.org/#/biblio][melpa]] | 0.2 | 20210418.406 | 0.2 | 20200416.1407 | required by bibtex-completion | +| biblio-core.el | [[https://melpa.org/#/biblio-core][melpa]] | 0.2.1 | 20210418.406 | 0.2.1 | 20200416.307 | required by biblio | +| bibtex-completion.el | [[https://melpa.org/#/bibtex-completion][melpa]] | 1.0.0 | 20211019.1306 | 1.0.0 | 20200908.1017 | required by ivy-bibtex, org-ref | | bind-key.el | [[https://melpa.org/#/bind-key][melpa]] | 2.4 | 20210210.1609 | 2.4 | 20200805.1727 | required by use-package | | cl-libify.el | [[https://melpa.org/#/cl-libify][melpa]] | 0 | 20181130.230 | | | prevent: Package cl is deprecated | +| citeproc | [[https://melpa.org/#/citeproc][melpa]] | 0.9 | 20220101.1527 | | | | | company | [[https://melpa.org/#/company][melpa]] | 0.9.13 | 20220103.351 | 0.9.13 | 20210103.1124 | completion framework | | company-anaconda.el | [[https://melpa.org/#/company-anaconda][melpa]] | 0.2.0 | 20200404.1859 | 0.2.0 | 20181025.1305 | | | company-ledger.el | [[https://melpa.org/#/company-ledger][melpa]] | 0.1.0 | 20210910.250 | 0.1.0 | 20200726.1825 | | @@ -33,7 +34,7 @@ | emojify | [[https://melpa.org/#/emojify][melpa]] | 1.2.1 | 20210108.1111 | 1.2.1 | 20201130.1116 | | | ess | [[https://melpa.org/#/ess][melpa]] | 18.10.3snapshot | 20211231.1746 | 18.10.3snapshot | 20210106.1141 | | | ess-R-data-view.el | [[https://melpa.org/#/ess-R-data-view][melpa]] | 0.1 | 20130509.1158 | | | | -| f.el | [[https://melpa.org/#/f][melpa]] | 0.20.0 | 20210624.1103 | 0.20.0 | 20191110.1357 | | +| f.el | [[https://melpa.org/#/f][melpa]] | 0.20.0 | 20210624.1103 | 0.20.0 | 20191110.1357 | required by org-ref | | flycheck | [[https://melpa.org/#/flycheck][melpa]] | 32-cvs | 20210825.1804 | 32-cvs | 20201228.2104 | | | flycheck-ledger.el | [[https://melpa.org/#/flycheck-ledger][melpa]] | DEV | 20200304.2204 | DEV | 20180819.321 | | | flycheck-pos-tip.el | [[https://melpa.org/#/flycheck-pos-tip][melpa]] | 0.4-cvs | 20200516.1600 | 0.4-cvs | 20180610.1615 | | @@ -43,7 +44,7 @@ | gnuplot | [[https://melpa.org/#/gnuplot][melpa]] | 0.8.0 | 20220102.1637 | 0.8.0 | 20210104.1052 | | | gnuplot-mode.el | [[https://melpa.org/#/gnuplot-mode][melpa]] | 1.2.0 | 20171013.1616 | | | | | ht.el | [[https://melpa.org/#/ht][melpa]] | 2.4 | 20210119.741 | 2.3 | 20201119.518 | hash table library | -| htmlize.el | [[https://melpa.org/#/htmlize][melpa]] | 1.57 | 20210825.2150 | 1.56 | 20200816.746 | | +| htmlize.el | [[https://melpa.org/#/htmlize][melpa]] | 1.57 | 20210825.2150 | 1.56 | 20200816.746 | required by org-ref | | hydra | [[https://melpa.org/#/hydra][melpa]] | 0.15.0 | 20220102.803 | 0.15.0 | 20201115.1055 | required by org-ref | | indent-guide.el | [[https://melpa.org/#/indent-guide][melpa]] | 2.3.1 | 20210115.400 | 2.3.1 | 20191106.240 | | | iscroll.el | [[https://melpa.org/#/iscroll][melpa]] | 1.0.0 | 20210128.1938 | | | | @@ -75,7 +76,7 @@ | ox-reveal.el | [[https://melpa.org/#/ox-reveal][melpa]] | 1.0 | 20211128.1509 | 1.0 | 20201211.1518 | requires https://github.com/hakimel/reveal.js | | ox-tufte.el | [[https://melpa.org/#/ox-tufte][melpa]] | 1.0.0 | 20160926.1607 | | | | | page-break-lines.el | [[https://melpa.org/#/page-break-lines][melpa]] | 0 | 20210104.2224 | 0 | 20200305.244 | required by dashboard | -| parsebib.el | [[https://melpa.org/#/parsebib][melpa]] | 3.0 | 20211208.2335 | 2.3 | 20200513.2352 | | +| parsebib.el | [[https://melpa.org/#/parsebib][melpa]] | 3.0 | 20211208.2335 | 2.3 | 20200513.2352 | required by org-ref | | pdf-tools | [[https://melpa.org/#/pdf-tools][melpa]] | 1.0.0snapshot | 20220103.308 | 1.0 | 20200512.1524 | | | persist | [[https://elpa.gnu.org/packages/persist.html][elpa]] | 0.4 | - | | | required by org-drill | | pfuture.el | [[https://melpa.org/#/pfuture][melpa]] | 1.10.2 | 20211229.1513 | 1.9 | 20200425.1357 | | @@ -87,14 +88,16 @@ | pos-tip.el | [[https://melpa.org/#/pos-tip][melpa]] | 0.4.6 | 20191227.1356 | 0.4.6 | 20150318.1513 | | | powershell.el | [[https://melpa.org/#/powershell][melpa]] | 0.3 | 20220103.925 | 0.3 | 20201005.1642 | | | pythonic.el | [[https://melpa.org/#/pythonic][melpa]] | 0.2 | 20210122.1247 | 0.1.1 | 20200806.434 | | +| queue.el | [[https://elpa.gnu.org/packages/queue.html][elpa]] | 0.2 | - | | | required by citeproc | | rainbow-mode.el | [[https://elpa.gnu.org/packages/rainbow-mode.html][elpa]] | 1.0.5 | - | 1.0.4 | - | | | restart-emacs.el | [[https://melpa.org/#/restart-emacs][melpa]] | 0.1.1 | 20201127.1425 | 0.1.1 | 20180601.1031 | | -| s.el | [[https://melpa.org/#/s][melpa]] | 1.12.0 | 20210616.619 | 1.12.0 | 20180406.808 | required by emacs-application-framework | +| s.el | [[https://melpa.org/#/s][melpa]] | 1.12.0 | 20210616.619 | 1.12.0 | 20180406.808 | required by emacs-application-framework, org-ref | | spacemancs-theme | [[https://melpa.org/#/spacemacs-theme][melpa]] | 0.1 | 20210924.1220 | 0.1 | 20200825.1818 | | | sphinx-doc.el | [[https://melpa.org/#/sphinx-doc][melpa]] | 0.3.0 | 20210213.1250 | 0.3.0 | 20160116.1117 | | | sql-indent | [[https://elpa.gnu.org/packages/sql-indent.html][elpa]] | 1.6 | - | 1.5 | - | | | srefactor | [[https://melpa.org/#/srefactor][melpa]] | 0.3 | 20180703.1810 | | | | | stickyfunc-enhance.el | [[https://melpa.org/#/stickyfunc-enhance][melpa]] | 0.1 | 20150429.1814 | | | | +| string-inflection.el | [[https://melpa.org/#/string-inflection][melpa]] | 1.0.16 | 20210918.419 | | | required by citeproc | | swiper.el | [[https://melpa.org/#/swiper][melpa]] | 0.13.4 | 20210919.1221 | 0.13.0 | 20201208.1419 | | | systemd | [[https://melpa.org/#/systemd][melpa]] | 1.6 | 20210209.2052 | | 20191219.2304 | | | transient | [[https://melpa.org/#/transient][melpa]] | 0.3.7 | 20220104.1601 | 0.2.0 | 20210103.1546 | | diff --git a/settings/bibliography-settings.el b/settings/bibliography-settings.el index 204745ce..8c8e8e03 100644 --- a/settings/bibliography-settings.el +++ b/settings/bibliography-settings.el @@ -23,6 +23,10 @@ :load-path (lambda() (concat config-dir "lisp/biblio")) :defer t) ;; used by org-ref +(use-package citeproc + :load-path (lambda() (concat config-dir "lisp/citeproc")) + :defer t) ;; used by org-ref + (use-package org-ref ;; used with some preamble defs and \printbibliography (biblatex/biber, no html export), see also ox-bibtex :load-path (lambda() (concat config-dir "lisp/org-ref")) :after (org) diff --git a/settings/gui-settings.el b/settings/gui-settings.el index a71bbac2..fd5c6311 100644 --- a/settings/gui-settings.el +++ b/settings/gui-settings.el @@ -208,6 +208,7 @@ DISPLAY-START: `integer', e.g. 3820" "Init info with packages loaded and init time." (setq dashboard-startup-banner 'logo) (setq dashboard-set-navigator t) + (setq dashboard-page-separator "\n\f\n") ;; \f requires page-break-lines-mode ;; (setq dashboard-navigator-buttons ;; Format: "(icon title help action face prefix suffix)" ;; (list (list ;; line1 ;; ;; "☆" "Star" "Show stars" (lambda (&rest _) (show-stars)) warning "[" "]") @@ -215,101 +216,47 @@ DISPLAY-START: `integer', e.g. 3820" ;; ))) (require 'all-the-icons) (defun dashboard-navigator-buttons-func () - ;; Format: "(icon title help action face prefix suffix)" - `(( ;; views - ("" "Custom Views:" "custom views" nil default "" "") - (,(all-the-icons-fileicon "elisp" :height 1.0 :v-adjust -0.1) - "ELisp" "my-view-elisp" (lambda (&rest _) (my-tab-view-elisp))) - (,(all-the-icons-alltheicon "python" :height 1.0 :v-adjust 0.0) - "Python" "my-view-python" (lambda (&rest _) (my-tab-view-python))) - (,(all-the-icons-alltheicon "script" :height 1.0 :v-adjust 0.0) - "Shell" "my-view-shell" (lambda (&rest _) (my-tab-view-shell))) - (,(all-the-icons-octicon "file-media" :height 1.0 :v-adjust 0.0) - "Gnuplot" "my-view-gnuplot" (lambda (&rest _) (my-tab-view-gnuplot))) - (,(all-the-icons-octicon "file-pdf" :height 1.0 :v-adjust 0.0) - "Org PDF" "my-view-org-pdf" (lambda (&rest _) (my-tab-view-org-pdf))) - ) - ( ;; major modes first line - ("" "Major Modes:" "major modes" nil default "" "") - ("" - "Deft" "deft" (lambda (&rest _) (deft))) - ("" - "EShell" "eshell-mode" (lambda (&rest _) (eshell))) - ("" - "Magit" "magit" (lambda (&rest _) (magit))) - (,(all-the-icons-octicon "mail" :height 1.0 :v-adjust 0.0) - "Mu4e" "mu4e" (lambda (&rest _) (mu4e))) - (,(all-the-icons-octicon "mail" :height 1.0 :v-adjust 0.0) - "Notmuch" "notmuch" (lambda (&rest _) (notmuch))) - ("" - "Org-Brain" "org-brain-visualize" (lambda (&rest _) (call-interactively 'org-brain-visualize))) - ) - ( ;; major modes second line - ("" - "Org-Drill" "org-drill" (lambda (&rest _) (org-drill))) - ("" - "Powershell" "powershell" (lambda (&rest _) (powershell))) - ("" - "Shell" "shell" (lambda (&rest _) (shell))) - ("" - "Treemacs" "treemacs" (lambda (&rest _) (treemacs))) - ) - ( ;; line1 - ;; "☆" "Star" "Show stars" (lambda (&rest _) (show-stars)) warning "[" "]") - (,(all-the-icons-material "help_outline" :height 1.1 :v-adjust -0.15) ;; all-the-icons-octicon "question" - "Help" "?/h" (lambda (&rest _) (describe-mode)) nil) ;; #'show-help - (,(all-the-icons-material "refresh" :height 1.1 :v-adjust -0.15) ;; all-the-icons-octicon "sync" - "Restart" "restart-emacs" (lambda (&rest _) (restart-emacs)) nil) - ("" ,(concat "Config: " (my-dashboard-config-update)) "config" (lambda (&rest _) (progn (my-dashboard-config-update) (setq dashboard-navigator-buttons (dashboard-navigator-buttons-func)) (dashboard-refresh-buffer))) default "" "") - ))) + ;; Format: "(icon title help action face prefix suffix)" + `( + ;; line: custom views + (("" "Custom Views:" "custom views" nil default "" "") + (,(all-the-icons-fileicon "elisp" :height 1.0 :v-adjust -0.1) + "ELisp" "my-view-elisp" (lambda (&rest _) (my-tab-view-elisp))) + (,(all-the-icons-alltheicon "python" :height 1.0 :v-adjust 0.0) + "Python" "my-view-python" (lambda (&rest _) (my-tab-view-python))) + (,(all-the-icons-alltheicon "script" :height 1.0 :v-adjust 0.0) + "Shell" "my-view-shell" (lambda (&rest _) (my-tab-view-shell))) + (,(all-the-icons-octicon "file-media" :height 1.0 :v-adjust 0.0) + "Gnuplot" "my-view-gnuplot" (lambda (&rest _) (my-tab-view-gnuplot))) + (,(all-the-icons-octicon "file-pdf" :height 1.0 :v-adjust 0.0) + "Org PDF" "my-view-org-pdf" (lambda (&rest _) (my-tab-view-org-pdf)))) + ;; line: major modes 1st + (("" "Major Modes:" "major modes" nil default "" "") + ("" "Deft" "deft" (lambda (&rest _) (deft))) + ("" "EShell" "eshell-mode" (lambda (&rest _) (eshell))) + ("" "Magit" "magit" (lambda (&rest _) (magit))) + (,(all-the-icons-octicon "mail" :height 1.0 :v-adjust 0.0) + "Mu4e" "mu4e" (lambda (&rest _) (mu4e))) + (,(all-the-icons-octicon "mail" :height 1.0 :v-adjust 0.0) + "Notmuch" "notmuch" (lambda (&rest _) (notmuch))) + ("" "Org-Brain" "org-brain-visualize" (lambda (&rest _) (call-interactively 'org-brain-visualize)))) + ;; line: major modes 2nd + (("" "Org-Drill" "org-drill" (lambda (&rest _) (org-drill))) + ("" "Powershell" "powershell" (lambda (&rest _) (powershell))) + ("" "Shell" "shell" (lambda (&rest _) (shell))) + ("" "Treemacs" "treemacs" (lambda (&rest _) (treemacs)))) + ;; last line + (;; "☆" "Star" "Show stars" (lambda (&rest _) (show-stars)) warning "[" "]") + (,(all-the-icons-material "help_outline" :height 1.1 :v-adjust -0.15) ;; all-the-icons-octicon "question" + "Help" "?/h" (lambda (&rest _) (describe-mode)) nil) ;; #'show-help + (,(all-the-icons-material "refresh" :height 1.1 :v-adjust -0.15) ;; all-the-icons-octicon "sync" + "Restart" "restart-emacs" (lambda (&rest _) (restart-emacs)) nil)))) (setq dashboard-navigator-buttons (dashboard-navigator-buttons-func)) (setq dashboard-items '((recents . 10) (bookmarks . 5) ;;(projects . 5) ;;(agenda . 5) (registers . 5))) - - ;;custom widget - (defun my-widget-item (icon icon-face title title-face help action) - (let ((action (or action #'ignore))) - (widget-create 'item - :tag (concat - (propertize icon 'face `(:inherit - ,(get-text-property 0 'face icon) - :inherit - ,icon-face)) - (propertize " " 'face 'variable-pitch) - (propertize title 'face title-face)) - :help-echo help - :action action - :button-face `(:underline nil) - :mouse-face 'highlight - ;;:button-prefix (propertize "" 'face 'dashboard-navigator) - ;;:button-suffix (propertize "" 'face 'dashboard-navigator) - :format "%[%t%]"))) - ;; (defun dashboard-insert-custom (list-size) - ;; (dashboard-insert-shortcut "v" "Views" t) - ;; (when (display-graphic-p) - ;; (insert (all-the-icons-material "view_quilt" :height 1.6 :v-adjust -0.25 - ;; :face 'dashboard-heading)) - ;; (insert " ")) - ;; (insert (propertize "Custom views:" 'face 'dashboard-heading)) - ;; (insert " (v)") - ;; (insert " ") - ;; (my-widget-item (all-the-icons-fileicon "elisp" :height 1.0 :v-adjust -0.1) - ;; 'all-the-icons-purple "ELisp" 'default "my-view-elisp" - ;; (lambda (&rest _) (my-view-elisp))) - ;; (insert " ") - ;; (my-widget-item (all-the-icons-alltheicon "python" :height 1.0 :v-adjust 0.0) - ;; 'all-the-icons-dblue "Python" 'default "my-view-python" - ;; (lambda (&rest _) (my-view-python))) - ;; (insert " ") - ;; (my-widget-item (all-the-icons-octicon "mail" :height 1.0 :v-adjust 0.0) - ;; 'all-the-icons-dblue "Notmuch" 'default "notmuch" - ;; (lambda (&rest _) (notmuch))) - ;; ) - ;; (add-to-list 'dashboard-item-generators '(custom . dashboard-insert-custom) t) - ;; see below add-to-list to dashboard-items ;; `clean-buffer-list' (defun my-buffer-name-list (&optional special internal) @@ -342,8 +289,7 @@ If INTERNAL non-nil then include internal buffers." ;; a pre-defined heading icon. This is used to include own icon. (defun dashboard-insert-heading (heading &optional shortcut suppress-icon) "Insert a widget HEADING in dashboard buffer, adding SHORTCUT if provided." - (when (and (display-graphic-p) - dashboard-set-heading-icons) + (when (and (display-graphic-p) dashboard-set-heading-icons) ;; Try loading `all-the-icons' (unless (or (fboundp 'all-the-icons-octicon) (require 'all-the-icons nil 'noerror)) @@ -372,7 +318,17 @@ If INTERNAL non-nil then include internal buffers." (insert " ")) (insert (propertize heading 'face 'dashboard-heading)) - (if shortcut (insert (format " (%s)" shortcut)))) + + ;; Turn the inserted heading into an overlay, so that we may freely change + ;; its name without breaking any of the functions that expect the default name. + ;; If there isn't a suitable entry in `dashboard-item-names', + ;; we fallback to using HEADING. In that case we still want it to be an + ;; overlay to maintain consistent behavior (such as the point movement) + ;; between modified and default headings. + (let ((ov (make-overlay (- (point) (length heading)) (point) nil t))) + (overlay-put ov 'display (or (cdr (assoc heading dashboard-item-names)) heading)) + (overlay-put ov 'face 'dashboard-heading)) + (when shortcut (insert (format " (%s)" shortcut)))) ;; overwrite to supress the logic to insert a pre-defined heading ;; icon. This is used to include own icon. (defmacro my-dashboard-insert-section (section-name list list-size shortcut action &rest widget-params) @@ -382,20 +338,22 @@ ACTION is theaction taken when the user activates the widget button. WIDGET-PARAMS are passed to the \"widget-create\" function." `(progn (dashboard-insert-heading ,section-name - (if (and ,list dashboard-show-shortcuts) ,shortcut) - t) ;; ADDED + (if (and ,list ,shortcut dashboard-show-shortcuts) ,shortcut) + t) ;; ADDED for the overwritten version, see above (if ,list - (when (dashboard-insert-section-list - ,section-name - (dashboard-subseq ,list 0 ,list-size) - ,action - ,@widget-params) + (when (and (dashboard-insert-section-list + ,section-name + (dashboard-subseq ,list ,list-size) + ,action + ,@widget-params) + ,shortcut) (dashboard-insert-shortcut ,shortcut ,section-name)) - (insert "\n --- No items ---")))) + (insert (propertize "\n --- No items ---" 'face 'dashboard-no-items-face))))) (defun dashboard-insert-buffers (list-size) "Add the list of LIST-SIZE items from buffers list. -See also `dashboard-insert-section'." +Example `dashboard-insert-recent'. +See also `dashboard-insert-section' for the sequence of elements." (when (display-graphic-p) (insert (all-the-icons-octicon "versions" diff --git a/settings/mail-settings.el b/settings/mail-settings.el index d256a361..2b39ef88 100644 --- a/settings/mail-settings.el +++ b/settings/mail-settings.el @@ -338,11 +338,11 @@ MSG is a message p-list from mu4e." (start-process-shell-command "offlineimap" "*offlineimap*" "offlineimap -o") - '(lambda (process event) - (notmuch-refresh-all-buffers) - (let ((w (get-buffer-window "*offlineimap*"))) - (when w - (with-selected-window w (recenter (window-end))))))) + #'(lambda (process event) + (notmuch-refresh-all-buffers) + (let ((w (get-buffer-window "*offlineimap*"))) + (when w + (with-selected-window w (recenter (window-end))))))) (popwin:display-buffer "*offlineimap*")) ;; add a special buffer config (add-to-list 'popwin:special-display-config